From 969cc86d1824a6815e4527f37a2a3ebf61c5872e Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Thu, 1 Feb 2024 13:49:17 +0000 Subject: [PATCH] Initial attempt at optimising day 23 --- advent-of-code23.cabal | 6 +- advent23/Main.hs | 155 ++++++++++++++++++++++++++++++++++----- advent23/MainOriginal.hs | 139 +++++++++++++++++++++++++++++++++++ 3 files changed, 280 insertions(+), 20 deletions(-) create mode 100644 advent23/MainOriginal.hs diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index 5f475b1..fd53102 100644 --- a/advent-of-code23.cabal +++ b/advent-of-code23.cabal @@ -238,8 +238,12 @@ executable advent22 executable advent23 import: common-extensions, build-directives main-is: advent23/Main.hs + build-depends: linear, containers, lens, pqueue, mtl +executable advent23original + import: common-extensions, build-directives + main-is: advent23/MainOriginal.hs build-depends: linear, containers, lens - + executable advent24 import: common-extensions, build-directives main-is: advent24/Main.hs diff --git a/advent23/Main.hs b/advent23/Main.hs index 8298261..7a24884 100644 --- a/advent23/Main.hs +++ b/advent23/Main.hs @@ -6,8 +6,14 @@ 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 data Slide = SlideLeft | SlideRight | SlideUp | SlideDown deriving (Show, Eq) @@ -26,6 +32,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 main :: IO () @@ -33,16 +59,18 @@ 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 = maximum $ fmap (pathLength cMap) paths +part1 slides forest start end = searchCompressed $ Mountain cMap start end where cMap = compress slides forest start end - paths = searchCompressed cMap end [] [[start]] -part2 _ forest start end = maximum $ fmap (pathLength cMap) paths +part2 slides forest start end = searchCompressed $ Mountain cMap start end where cMap = compress M.empty 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 start end adjacents :: Position -> Slides -> Grid -> [Position] adjacents here slides forest = filter (`S.notMember` forest) $ fmap (here ^+^) deltas @@ -92,23 +120,112 @@ 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 :: 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 +-- 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 +-- 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/MainOriginal.hs b/advent23/MainOriginal.hs new file mode 100644 index 0000000..8298261 --- /dev/null +++ b/advent23/MainOriginal.hs @@ -0,0 +1,139 @@ +-- 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') + +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]] -> [[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 + +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