From a98eb2707e395f87b87e7370df1503158d0e1a1a Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sun, 28 Jul 2024 10:20:18 +0100 Subject: [PATCH] Optimised day 23 --- README.html | 21 ++-- README.md | 8 +- advent-of-code23.cabal | 10 +- advent23/Main.hs | 179 ++++++++--------------------------- advent23/MainNoDepthLimit.hs | 160 +++++++++++++++++++++++++++++++ advent23/MainTree.hs | 141 +++++++++++++++++++++++++++ 6 files changed, 368 insertions(+), 151 deletions(-) create mode 100644 advent23/MainNoDepthLimit.hs create mode 100644 advent23/MainTree.hs diff --git a/README.html b/README.html index 13d51f8..4ad5959 100644 --- a/README.html +++ b/README.html @@ -11,14 +11,19 @@ div.columns{display: flex; gap: min(4vw, 1.5em);} div.column{flex: auto; overflow-x: auto;} div.hanging-indent{margin-left: 1.5em; text-indent: -1.5em;} - ul.task-list{list-style: none;} + /* The extra [class] is a hack that increases specificity enough to + override a similar rule in reveal.js */ + ul.task-list[class]{list-style: none;} ul.task-list li input[type="checkbox"] { + font-size: inherit; width: 0.8em; margin: 0 0.8em 0.2em -1.6em; vertical-align: middle; } + .display.math{display: block; text-align: center; margin: 0.5rem auto;} + /* CSS for syntax highlighting */ pre > code.sourceCode { white-space: pre; position: relative; } - pre > code.sourceCode > span { display: inline-block; line-height: 1.25; } + pre > code.sourceCode > span { line-height: 1.25; } pre > code.sourceCode > span:empty { height: 1.2em; } .sourceCode { overflow: visible; } code.sourceCode > span { color: inherit; text-decoration: inherit; } @@ -29,7 +34,7 @@ } @media print { pre > code.sourceCode { white-space: pre-wrap; } - pre > code.sourceCode > span { text-indent: -5em; padding-left: 5em; } + pre > code.sourceCode > span { display: inline-block; text-indent: -5em; padding-left: 5em; } } pre.numberSource code { counter-reset: source-line 0; } @@ -80,12 +85,8 @@ code span.va { color: #19177c; } /* Variable */ code span.vs { color: #4070a0; } /* VerbatimString */ code span.wa { color: #60a0b0; font-weight: bold; font-style: italic; } /* Warning */ - .display.math{display: block; text-align: center; margin: 0.5rem auto;} -

@@ -156,14 +157,14 @@ in the cabal file:

ghc-options: -O2 -Wall -threaded - -eventlog -rtsopts "-with-rtsopts=-N -p -s -hT" -

Only include the -eventlog directive if you want to use -Threadscope to investigate parallel behaviour.

then running

cabal run advent01prof --enable-profiling

Generate the profile graph with

hp2ps -M advent01.hp

To generate an eventlog (used for tracking multi-core performance), +pass in the -l RTS flag:

cabal run advent01 --enable-profiling -- +RTS -N -p -s -hT -l

Packages

Packages I used a lot:

diff --git a/README.md b/README.md index de92218..81f372c 100644 --- a/README.md +++ b/README.md @@ -86,12 +86,9 @@ executable advent01prof ghc-options: -O2 -Wall -threaded - -eventlog -rtsopts "-with-rtsopts=-N -p -s -hT" ``` -Only include the `-eventlog` directive if you want to use Threadscope to investigate parallel behaviour. - then running ``` @@ -104,6 +101,11 @@ Generate the profile graph with hp2ps -M advent01.hp ``` +To generate an eventlog (used for tracking multi-core performance), pass in the `-l` RTS flag: + +``` +cabal run advent01 --enable-profiling -- +RTS -N -p -s -hT -l +``` # Packages diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index 5548512..6a821f7 100644 --- a/advent-of-code23.cabal +++ b/advent-of-code23.cabal @@ -238,7 +238,15 @@ executable advent22 executable advent23 import: common-extensions, build-directives main-is: advent23/Main.hs - build-depends: linear, containers, lens, pqueue, mtl + build-depends: linear, containers, lens, monad-par, monad-par-extras +executable advent23tree + import: common-extensions, build-directives + main-is: advent23/MainTree.hs + build-depends: linear, containers, lens +executable advent23ndl + import: common-extensions, build-directives + main-is: advent23/MainNoDepthLimit.hs + build-depends: linear, containers, lens, monad-par, monad-par-extras executable advent23original import: common-extensions, build-directives main-is: advent23/MainOriginal.hs diff --git a/advent23/Main.hs b/advent23/Main.hs index 7a24884..b653f31 100644 --- a/advent23/Main.hs +++ b/advent23/Main.hs @@ -6,14 +6,13 @@ import AoC import Linear -- (V2(..), (^+^)) import qualified Data.Set as S import qualified Data.Map.Strict as M -import qualified Data.Sequence as Q -import Data.Sequence (Seq( (:|>), (:<|) ) ) import Control.Lens import Data.List (foldl') -import Control.Monad.Reader -import qualified Data.PQueue.Prio.Max as P -import Data.Foldable -import Data.Maybe + +import Control.Monad.Par +-- import Control.Monad.Par.Scheds.Trace +-- import Control.Monad.Par.Scheds.Sparks +import Control.Monad.Par.Combinator data Slide = SlideLeft | SlideRight | SlideUp | SlideDown deriving (Show, Eq) @@ -32,45 +31,26 @@ data CompressedPath = CPath { _nextPos :: Position, _pathLen :: Int } makeLenses ''CompressedPath type CompressedMap = M.Map Position [CompressedPath] -data Mountain = Mountain - { _paths :: CompressedMap - , _start :: Position - , _goal :: Position - } deriving (Eq, Show) -makeLenses ''Mountain - -type MountainContext = Reader Mountain - -data Agendum = - Agendum { _current :: Position - , _trail :: Q.Seq Position - , _trailCost :: Int - , _cost :: Int - } deriving (Show, Eq) -makeLenses ''Agendum -type Agenda = P.MaxPQueue Int Agendum - -type ExploredStates = M.Map Position Int +parallelDepthLimit = 7 :: Int main :: IO () main = do dataFileName <- getDataFileName text <- readFile dataFileName let (forest, slides, start, end) = mkGrid text - -- print $ compress slides forest start end print $ part1 slides forest start end print $ part2 slides forest start end part1, part2 :: Slides -> Grid -> Position -> Position -> Int -part1 slides forest start end = searchCompressed $ Mountain cMap start end +part1 slides forest start end = maximum $ fmap (pathLength cMap) paths where cMap = compress slides forest start end -part2 slides forest start end = searchCompressed $ Mountain cMap start end + paths = searchCompressed cMap end [start] +part2 _ forest start end = maximum $ fmap (pathLength cMap) paths +-- part2 _ forest start end = maximum $ fmap length paths where cMap = compress M.empty forest start end --- part2 _ forest start end = maximum $ fmap (pathLength cMap) paths --- where cMap = compress M.empty forest start end --- paths = searchCompressed cMap start end + paths = searchCompressed cMap end [start] adjacents :: Position -> Slides -> Grid -> [Position] adjacents here slides forest = filter (`S.notMember` forest) $ fmap (here ^+^) deltas @@ -120,112 +100,37 @@ compress slides forest start end = foldl' go compressed0 iPoints 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 - -searchCompressed :: Mountain -> Int -searchCompressed mountain = maybe 0 _trailCost result - where result = runReader searchMountain mountain - -searchMountain :: MountainContext (Maybe Agendum) -searchMountain = - do agenda <- initAgenda - aStar agenda Nothing - -initAgenda :: MountainContext Agenda -initAgenda = - do s <- asks _start - c <- estimateCost Q.Empty s - let agendum = Agendum { _current = s, _trail = Q.empty, _trailCost = 0, _cost = c} - let agenda = P.singleton c agendum - return agenda - -aStar :: Agenda -> (Maybe Agendum) -> MountainContext (Maybe Agendum) -aStar agenda best - -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined - -- | DT.trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ) False = undefined - -- | DT.trace ("Peeping " ++ (show $ snd $ P.findMax agenda) ) False = undefined - -- | DT.trace ("Peeping " ++ (show agenda) ) False = undefined - | P.null agenda = return best - | (fst $ P.findMax agenda) < maybe 0 _trailCost best = return best - | otherwise = - do let (_, currentAgendum) = P.findMax agenda - let reached = currentAgendum ^. current - nexts <- candidates currentAgendum - let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMax agenda) nexts - reachedGoal <- isGoal reached - let best' = updateBest reachedGoal best currentAgendum - -- let closed' = M.insert reached (currentAgendum ^. trailCost) closed - if reachedGoal -- || (reached `S.member` closed) - then aStar (P.deleteMax agenda) best' -- closed' - else aStar newAgenda best' -- closed' - -updateBest :: Bool -> Maybe Agendum -> Agendum -> Maybe Agendum -updateBest False current _ = current -updateBest True Nothing best - -- | DT.trace ("Nothing " ++ show best) False = undefined - | otherwise = Just best -updateBest True (Just current) best - -- | DT.trace (show current ++ " " ++ show best) False = undefined - | (current ^. trailCost) > (best ^. trailCost) = Just current - | otherwise = Just best - - - - -candidates :: Agendum -> MountainContext (Q.Seq Agendum) -candidates agendum = - do let here = agendum ^. current - let previous = agendum ^. trail - let prevCost = agendum ^. trailCost - ts <- asks _paths - let succs = Q.fromList $ ts M.! here - -- succs <- successors candidate - let nonloops = Q.filter (\s -> (s ^. nextPos) `notElem` previous) succs - mapM (makeAgendum previous prevCost here) nonloops - - -makeAgendum :: (Q.Seq Position) -> Int -> Position -> CompressedPath -> MountainContext Agendum -makeAgendum previous prevCost here step = - do let newTrail = previous :|> here - predicted <- estimateCost newTrail $ step ^. nextPos - -- ts <- asks _trails - let incurred = prevCost + step ^. pathLen - return Agendum { _current = step ^. nextPos - , _trail = newTrail - , _trailCost = incurred - , _cost = incurred + predicted - } - - -isGoal :: Position -> MountainContext Bool -isGoal here = - do goal <- asks _goal - return $ here == goal - -estimateCost :: Q.Seq Position -> Position -> MountainContext Int -estimateCost r e = - do ts <- asks _paths - let endCost = fromMaybe 0 $ maximumOf (folded . filtered ((`notElem` r) . _nextPos) . pathLen) $ ts M.! e - let res = S.fromList $ toList (r :|> e) - let otherPaths = concat $ M.elems $ ts `M.withoutKeys` res - let restCost = sumOf (folded . filtered ((`notElem` r) . _nextPos) . pathLen) otherPaths - return $ (restCost `div` 2) + endCost - --- pathLength :: CompressedMap -> [Position] -> Int --- pathLength map ps = sum $ zipWith (stepLength map) ps $ tail ps - --- 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 +searchCompressed :: CompressedMap -> Position -> [Position] -> [[Position]] +searchCompressed map goal current = runPar $ searchCompressedM parallelDepthLimit map goal current + +searchCompressedM :: Int -> CompressedMap -> Position -> [Position] -> Par [[Position]] +-- searchCompressed _ _ _ (c:_) _ | DT.trace (show c) False = undefined +searchCompressedM depthLimit map goal current + | head current == goal = return [current] + | depthLimit == 0 = return $ searchCompressedTree map goal current + | otherwise = + do paths <- parMapM (searchCompressedM (depthLimit - 1) map goal) nextPositions + return $ concat paths + where neighbours0 = map M.! (head current) + neighbours = neighbours0 ^.. folded . filtered ((`notElem` current) . _nextPos) + nextPositions = fmap ((: current) . _nextPos) neighbours + +searchCompressedTree :: CompressedMap -> Position -> [Position] -> [[Position]] +-- searchCompressed _ _ _ (c:_) _ | DT.trace (show c) False = undefined +searchCompressedTree map goal current + | head current == goal = [current] + | otherwise = concatMap (searchCompressedTree map goal) nextPositions + 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 + +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 diff --git a/advent23/MainNoDepthLimit.hs b/advent23/MainNoDepthLimit.hs new file mode 100644 index 0000000..baf19a5 --- /dev/null +++ b/advent23/MainNoDepthLimit.hs @@ -0,0 +1,160 @@ +-- 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 qualified Data.Set as S +import qualified Data.Map.Strict as M +import Control.Lens +import Data.List (foldl') + +import Control.Monad.Par +-- import Control.Monad.Par.Scheds.Trace +-- import Control.Monad.Par.Scheds.Sparks +import Control.Monad.Par.Combinator + +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] + + +parallelDepthLimit = 7 + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- readFile dataFileName + let (forest, slides, start, end) = mkGrid text + print $ part1 slides forest start end + print $ part2 slides forest start end + +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 +-- part2 _ forest start end = maximum $ fmap length paths + where cMap = compress M.empty forest start end + paths = searchCompressed cMap end [start] + +adjacents :: Position -> Slides -> Grid -> [Position] +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] -> CompressedMap -> [[Position]] -> CompressedMap +search _ _ _ foundPaths [] = foundPaths +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]] +searchCompressed map goal current = runPar $ searchCompressedM map goal current + +searchCompressedM :: CompressedMap -> Position -> [Position] -> Par [[Position]] +-- searchCompressed _ _ _ (c:_) _ | DT.trace (show c) False = undefined +searchCompressedM map goal current + | head current == goal = return [current] + | otherwise = + do paths <- parMapM (searchCompressedM map goal) nextPositions + return $ concat paths + where neighbours0 = map M.! (head current) + neighbours = neighbours0 ^.. folded . filtered ((`notElem` current) . _nextPos) + nextPositions = fmap ((: current) . _nextPos) neighbours + +-- searchCompressedTree :: CompressedMap -> Position -> [Position] -> [[Position]] +-- -- searchCompressed _ _ _ (c:_) _ | DT.trace (show c) False = undefined +-- searchCompressedTree map goal current +-- | head current == goal = [current] +-- | otherwise = concatMap (searchCompressedTree map goal) nextPositions +-- 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 + +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 = ((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)) + | r <- [0..maxR], c <- [0..maxC] + , elem (rows !! r !! c) ("<>^v" :: String) + ] + start = head $ [ V2 0 c | c <- [0..maxC] + , rows !! 0 !! c == '.' + ] + 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 +readSlide '>' = SlideRight +readSlide '^' = SlideUp +readSlide 'v' = SlideDown diff --git a/advent23/MainTree.hs b/advent23/MainTree.hs new file mode 100644 index 0000000..143a351 --- /dev/null +++ b/advent23/MainTree.hs @@ -0,0 +1,141 @@ +-- 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 qualified Data.Set as S +import qualified Data.Map.Strict as M +import Control.Lens +import Data.List (foldl') + +-- import Control.Monad.Par.Scheds.Trace +-- import Control.Monad.Par.Combinator + +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 = + do dataFileName <- getDataFileName + text <- readFile dataFileName + let (forest, slides, start, end) = mkGrid text + print $ part1 slides forest start end + print $ part2 slides forest start end + +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 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] -> CompressedMap -> [[Position]] -> CompressedMap +search _ _ _ foundPaths [] = foundPaths +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]] +-- searchCompressed _ _ _ (c:_) _ | DT.trace (show c) False = undefined +searchCompressed map goal current + | head current == goal = [current] + | otherwise = concatMap (searchCompressed map goal) nextPositions + 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 + +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 = ((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)) + | r <- [0..maxR], c <- [0..maxC] + , elem (rows !! r !! c) ("<>^v" :: String) + ] + start = head $ [ V2 0 c | c <- [0..maxC] + , rows !! 0 !! c == '.' + ] + 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 +readSlide '>' = SlideRight +readSlide '^' = SlideUp +readSlide 'v' = SlideDown -- 2.34.1