Day 23 part 2

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index ec2ef49c2b74c786d66d46b335d3ddf16f29d4f8..ff496043d6779b45c8bf71ed22ac31ee31fbd4cd 100644 (file)
--- a/advent-of-code23.cabal
+++ b/advent-of-code23.cabal
@@ -230,5 +230,4 @@ executable advent22
 executable advent23
   import: common-extensions, build-directives
   main-is: advent23/Main.hs
-  build-depends: linear, containers
-  
\ No newline at end of file
+  build-depends: linear, containers, lens

diff --git a/advent23/Main.hs b/advent23/Main.hs
index b8110822660813e39b2dc1ba552bf00e65e8a877..457f42bf4ae3ccf0c3395f2e98da083a2cf0da42 100644 (file)
--- a/advent23/Main.hs
+++ b/advent23/Main.hs
@@ -1,77 +1,126 @@
--- Writeup at https://work.njae.me.uk/2023/12/29/advent-of-code-2023-day-21/
+-- Writeup at https://work.njae.me.uk/2024/01/02/advent-of-code-2023-day-23/
+
+import qualified Debug.Trace as DT
 
 import AoC
-import Linear (V2(..), (^+^))
+import Linear -- (V2(..), (^+^))
 import qualified Data.Set as S
 import qualified Data.Map as M
+import Control.Lens
+import Data.List (foldl')
 
 data Slide = SlideLeft | SlideRight | SlideUp | SlideDown
   deriving (Show, Eq)
 
 type Position = V2 Int -- r, c
+
+_r, _c :: Lens' (V2 Int) Int
+_r = _x
+_c = _y
+
 type Grid = S.Set Position
 type Slides = M.Map Position Slide
 
+data CompressedPath = CPath { _nextPos :: Position, _pathLen :: Int }
+  deriving (Show, Eq)
+makeLenses ''CompressedPath
+
+type CompressedMap = M.Map Position [CompressedPath]
+
+
 main :: IO ()
-main = 
+main =
   do  dataFileName <- getDataFileName
       text <- readFile dataFileName
       let (forest, slides, start, end) = mkGrid text
-      -- print forest
-      -- print slides
-      -- print start
-      -- print end
-      -- print $ searchStep slides forest [start ^+^ (V2 1 0), start]
-      -- let paths = search slides forest end [] [[start ^+^ (V2 1 0), start]]
-      -- print $ fmap length paths
       print $ part1 slides forest start end
+      print $ part2 slides forest start end
 
-part1 slides forest start end = (maximum $ fmap length paths) - 1
-  where paths = search slides forest end [] [[start ^+^ (V2 1 0), start]]
+part1, part2 :: Slides -> Grid -> Position -> Position -> Int
+part1 slides forest start end = maximum $ fmap (pathLength cMap) paths
+  where cMap = compress slides forest start end
+        paths = searchCompressed cMap end [] [[start]]
+part2 _ forest start end = maximum $ fmap (pathLength cMap) paths
+  where cMap = compress M.empty forest start end
+        paths = searchCompressed cMap end [] [[start]]
 
 adjacents :: Position -> Slides -> Grid -> [Position]
-adjacents here slides walls = filter (`S.notMember` walls) $ fmap (^+^ here) deltas
+adjacents here slides forest = filter (`S.notMember` forest) $ fmap (here ^+^) deltas
   where deltas = case M.lookup here slides of
                   Nothing ->  [ V2 0 1, V2 1 0, V2 0 (-1), V2 (-1) 0 ]
                   Just SlideLeft -> [ V2 0 (-1) ]
                   Just SlideRight -> [ V2 0 1 ]
                   Just SlideUp -> [ V2 (-1) 0 ]
                   Just SlideDown -> [ V2 1 0 ]
-  
+
 searchStep :: Slides -> Grid -> [Position] -> [[Position]]
 searchStep _ _ [] = []
 searchStep slides forest path@(here:rest) = fmap (:path) valids
   where nexts = adjacents here slides forest
         valids = filter (`notElem` rest) nexts
 
-
-search :: Slides -> Grid -> Position -> [[Position]] -> [[Position]] -> [[Position]]
+search :: Slides -> Grid -> [Position] -> CompressedMap -> [[Position]] -> CompressedMap
 search _ _ _ foundPaths [] = foundPaths
-search slides forest goal foundPaths (current:agenda)
-  | head current == goal = search slides forest goal (current:foundPaths) agenda
-  | otherwise = search slides forest goal foundPaths (agenda ++ extendeds) 
+search slides forest goals foundPaths (current:agenda)
+  | head current `elem` goals = search slides forest goals foundPaths' agenda
+  | otherwise = search slides forest goals foundPaths (agenda ++ extendeds)
   where extendeds = searchStep slides forest current
+        origin = last current
+        foundPaths' = if origin == head current then foundPaths
+                        else M.adjust (cp :) origin foundPaths
+        cp = CPath (head current) (length current - 1)
+
+-- collapsing the map
+
+interestingPoints :: Slides -> Grid -> Position -> Position -> CompressedMap
+interestingPoints slides forest start end = M.fromList [(p, []) | p <- pointsSE]
+  where Just minR = minimumOf (folded . _r) forest
+        Just maxR = maximumOf (folded . _r) forest
+        Just minC = minimumOf (folded . _c) forest
+        Just maxC = maximumOf (folded . _c) forest
+        points = [ V2 r c | r <- [(minR + 2)..(maxR - 2)]
+                 , c <- [(minC + 1)..(maxC - 1)]
+                 , (V2 r c) `S.notMember` forest
+                 , (length $ adjacents (V2 r c) slides forest) > 2
+                 ]
+        pointsSE = start : end : points
+
+compress :: Slides -> Grid -> Position -> Position -> CompressedMap
+compress slides forest start end = foldl' go compressed0 iPoints
+  where compressed0 = interestingPoints slides forest start end
+        iPoints = M.keys compressed0
+        go com here = search slides forest iPoints com $ fmap (: [here]) $ adjacents here slides forest
+
+
+searchCompressed :: CompressedMap -> Position -> [[Position]] -> [[Position]] -> [[Position]]
+-- searchCompressed _ _ _ (c:_) _ | DT.trace (show c) False = undefined
+searchCompressed _ _ found [] = found
+searchCompressed map goal found (current:agenda) 
+  | head current == goal = searchCompressed map goal (current:found) agenda
+  | otherwise = searchCompressed map goal found (nextPositions ++ agenda)
+  where neighbours0 = map M.! (head current)
+        neighbours = neighbours0 ^.. folded . filtered ((`notElem` current) . _nextPos)
+        nextPositions = fmap ((: current) . _nextPos) neighbours
 
+pathLength :: CompressedMap -> [Position] -> Int
+pathLength map ps = sum $ zipWith (stepLength map) ps $ tail ps
 
--- showGrid :: Grid -> (Position, Position) -> Grid -> String
--- showGrid rocks bounds cells = unlines $ intercalate [" "] $ chunksOf 7 $ fmap (showRow rocks bounds cells) [-28..34]
---   where showRow rocks bounds cells r = intercalate " " $ chunksOf 7 $ fmap ((showCell rocks bounds cells) . V2 r) [-28..34]
---         showCell rocks bounds cells here
---           | not $ notAtRock rocks bounds here = '#'
---           | here `S.member` cells = 'O'
---           | otherwise = '.'
+stepLength :: CompressedMap -> Position -> Position -> Int
+stepLength map here there = 
+  -- head $ (map M.! there) ^.. folded . filtered ((== here) . _nextPos) . pathLen
+  head $ (map M.! there) ^.. folded . filteredBy (nextPos . only here) . pathLen
 
 -- reading the map
 
 mkGrid :: String -> (Grid, Slides, Position, Position)
-mkGrid text = (forest, slides, start, end)
+mkGrid text = ((S.union forest caps), slides, start, end)
   where rows = lines text
         maxR = length rows - 1
         maxC = (length $ head rows) - 1
         forest = S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC]
                             , rows !! r !! c == '#'
                             ]
-        slides = M.fromList [ (V2 r c, readSlide (rows !! r !! c)) 
+        slides = M.fromList [ (V2 r c, readSlide (rows !! r !! c))
                             | r <- [0..maxR], c <- [0..maxC]
                             , elem (rows !! r !! c) ("<>^v" :: String)
                             ]
@@ -81,6 +130,7 @@ mkGrid text = (forest, slides, start, end)
         end = head $ [ V2 maxR c | c <- [0..maxC]
                      , rows !! maxR !! c == '.'
                      ]
+        caps = S.fromList [start ^+^ (V2 -1 0), end ^+^ (V2 1 0)]
 
 readSlide :: Char -> Slide
 readSlide '<' = SlideLeft