From: Neil Smith <NeilNjae@users.noreply.github.com>
Date: Sun, 28 Jul 2024 09:20:18 +0000 (+0100)
Subject: Optimised day 23
X-Git-Url: https://git.njae.me.uk/?a=commitdiff_plain;h=a98eb2707e395f87b87e7370df1503158d0e1a1a;p=advent-of-code-23.git
Optimised day 23
---
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;}
</style>
<link rel="stylesheet" href="modest.css" />
- <!--[if lt IE 9]>
- <script src="//cdnjs.cloudflare.com/ajax/libs/html5shiv/3.7.3/html5shiv-printshiv.min.js"></script>
- <![endif]-->
</head>
<body>
<header id="title-block-header">
@@ -156,14 +157,14 @@ in the cabal file:</p>
ghc-options: -O2
-Wall
-threaded
- -eventlog
-rtsopts "-with-rtsopts=-N -p -s -hT"</code></pre>
-<p>Only include the <code>-eventlog</code> directive if you want to use
-Threadscope to investigate parallel behaviour.</p>
<p>then running</p>
<pre><code>cabal run advent01prof --enable-profiling</code></pre>
<p>Generate the profile graph with</p>
<pre><code>hp2ps -M advent01.hp</code></pre>
+<p>To generate an eventlog (used for tracking multi-core performance),
+pass in the <code>-l</code> RTS flag:</p>
+<pre><code>cabal run advent01 --enable-profiling -- +RTS -N -p -s -hT -l</code></pre>
<h1 id="packages">Packages</h1>
<p>Packages I used a lot:</p>
<ul>
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