From d73ce64ea5ea7ca1ac4b6f960731f8c784ca77c2 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Fri, 3 Jan 2025 12:03:42 +0000 Subject: [PATCH] Optimised day 16 --- advent16/Main.hs | 20 +++--- advent16/MainOriginal.hs | 146 +++++++++++++++++++++++++++++++++++++++ adventofcode24.cabal | 4 ++ 3 files changed, 162 insertions(+), 8 deletions(-) create mode 100644 advent16/MainOriginal.hs diff --git a/advent16/Main.hs b/advent16/Main.hs index 17bb54d..d8b44d4 100644 --- a/advent16/Main.hs +++ b/advent16/Main.hs @@ -8,6 +8,9 @@ import Linear (V2(..), (^+^), (^-^)) import qualified Data.Set as S -- import Data.Maybe import Data.List +import qualified Data.PQueue.Prio.Min as P +import Data.PQueue.Prio.Min ( MinPQueue( Empty, (:<) ) ) + type Position = V2 Int -- r, c @@ -33,7 +36,7 @@ data Agendum = , cost :: Int } deriving (Show, Eq) -type Agenda = [Agendum] +type Agenda = P.MinPQueue Int Agendum main :: IO () main = @@ -76,16 +79,16 @@ initAgenda = , trail = [r0] , cost = 0 } - return [agendum] + return $ P.singleton 0 agendum bfs :: Agenda -> Closed -> [Agendum] -> MazeContext [Agendum] -bfs [] _ founds = return founds -bfs (currentAgendum : restAgenda) closed founds = +bfs Empty _ founds = return founds +bfs ((_, currentAgendum) :< restAgenda) closed founds = do let reached = currentAgendum.current nexts <- candidates currentAgendum closed let newAgenda = if viable currentAgendum founds - then sortOn cost $ restAgenda ++ nexts - else restAgenda + then P.union restAgenda nexts + else Empty reachedGoal <- isGoal reached let founds' = if reachedGoal then updateFounds currentAgendum founds @@ -103,12 +106,13 @@ viable :: Agendum -> [Agendum] -> Bool viable _ [] = True viable agendum (f:_) = agendum.cost <= f.cost -candidates :: Agendum -> Closed -> MazeContext [Agendum] +candidates :: Agendum -> Closed -> MazeContext Agenda candidates agendum closed = do let here = agendum.current succs <- successors here let viableSuccs = filter (\(r, _) -> not $ r `S.member` closed) succs - mapM (makeAgendum agendum.trail agendum.cost) viableSuccs + cands <- mapM (makeAgendum agendum.trail agendum.cost) viableSuccs + return $ P.fromList $ fmap (\a -> (cost a, a)) cands makeAgendum :: Trail -> Int -> (Reindeer, Int) -> MazeContext Agendum makeAgendum previous pCost (here, stepCost) = diff --git a/advent16/MainOriginal.hs b/advent16/MainOriginal.hs new file mode 100644 index 0000000..ae81312 --- /dev/null +++ b/advent16/MainOriginal.hs @@ -0,0 +1,146 @@ +-- Writeup at https://work.njae.me.uk/2024/12/16/advent-of-code-2024-day-16/ + +import AoC + +-- import Data.Char +import Control.Monad.Reader +import Linear (V2(..), (^+^), (^-^)) +import qualified Data.Set as S +-- import Data.Maybe +import Data.List + +type Position = V2 Int -- r, c + +data Direction = N | E | S | W deriving (Show, Eq, Ord) +data Reindeer = Reindeer { pos :: Position, dir :: Direction } + deriving (Show, Eq, Ord) + +type Walls = S.Set Position +type Trail = [Reindeer] +type Closed = S.Set Reindeer + +data Maze = Maze + { walls :: Walls + , start :: Position + , goal :: Position + } deriving (Eq, Ord, Show) + +type MazeContext = Reader Maze + +data Agendum = + Agendum { current :: Reindeer + , trail :: Trail + , cost :: Int + } deriving (Show, Eq) + +type Agenda = [Agendum] + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- readFile dataFileName + let maze = mkMaze text + -- print maze + let allTrails = allRoutesFrom maze + -- print allTrails + print $ part1 allTrails + print $ part2 allTrails + +allRoutesFrom :: Maze -> [Agendum] +allRoutesFrom maze = runReader searchMaze maze + +part1, part2 :: [Agendum] -> Int +part1 trails = cost $ head trails +part2 trails = S.size $ S.unions $ fmap trailPos trails + where trailPos t = S.fromList $ fmap pos $ t.trail + +mkMaze :: String -> Maze +mkMaze text = Maze { walls = walls, start = start, goal = goal } + where rows = lines text + rMax = length rows - 1 + cMax = (length $ head rows) - 1 + walls = S.fromList [ V2 r c | r <- [0..rMax], c <- [0..cMax], rows !! r !! c == '#' ] + start = head [ V2 r c | r <- [0..rMax], c <- [0..cMax], rows !! r !! c == 'S' ] + goal = head [ V2 r c | r <- [0..rMax], c <- [0..cMax], rows !! r !! c == 'E' ] + +searchMaze :: MazeContext [Agendum] +searchMaze = + do agenda <- initAgenda + bfs agenda S.empty [] + +initAgenda :: MazeContext Agenda +initAgenda = + do s <- asks start + let r0 = Reindeer { pos = s, dir = E} + let agendum = Agendum { current = r0 + , trail = [r0] + , cost = 0 + } + return [agendum] + +bfs :: Agenda -> Closed -> [Agendum] -> MazeContext [Agendum] +bfs [] _ founds = return founds +bfs (currentAgendum : restAgenda) closed founds = + do let reached = currentAgendum.current + nexts <- candidates currentAgendum closed + let newAgenda = if viable currentAgendum founds + then {-# SCC agendaSort #-} sortOn cost $ restAgenda ++ nexts + else restAgenda + reachedGoal <- isGoal reached + let founds' = if reachedGoal + then updateFounds currentAgendum founds + else founds + bfs newAgenda (S.insert reached closed) founds' + +updateFounds :: Agendum -> [Agendum] -> [Agendum] +updateFounds agendum [] = [agendum] +updateFounds agendum founds@(f:_) + | agendum.cost < f.cost = [agendum] + | agendum.cost == f.cost = agendum : founds + | otherwise = founds + +viable :: Agendum -> [Agendum] -> Bool +viable _ [] = True +viable agendum (f:_) = agendum.cost <= f.cost + +candidates :: Agendum -> Closed -> MazeContext [Agendum] +candidates agendum closed = + do let here = agendum.current + succs <- successors here + let viableSuccs = filter (\(r, _) -> not $ r `S.member` closed) succs + mapM (makeAgendum agendum.trail agendum.cost) viableSuccs + +makeAgendum :: Trail -> Int -> (Reindeer, Int) -> MazeContext Agendum +makeAgendum previous pCost (here, stepCost) = + do let newTrail = (here : previous) + return Agendum { current = here + , trail = newTrail + , cost = pCost + stepCost + } + +successors :: Reindeer -> MazeContext [(Reindeer, Int)] +successors reindeer = + do w <- asks walls + let turns = [ (reindeer { dir = d }, 1000) + | d <- turnDirections (reindeer.dir) ] + let ahead = reindeer { pos = reindeer.pos ^+^ delta (reindeer.dir) } + return $ if ahead.pos `S.member` w + then turns + else (ahead, 1) : turns + +isGoal :: Reindeer -> MazeContext Bool +isGoal here = + do g <- asks goal + return $ here.pos == g + +delta :: Direction -> Position +delta N = V2 (-1) 0 +delta S = V2 1 0 +delta W = V2 0 (-1) +delta E = V2 0 1 + +turnDirections :: Direction -> [Direction] +turnDirections N = [E, W] +turnDirections S = [E, W] +turnDirections E = [N, S] +turnDirections W = [N, S] diff --git a/adventofcode24.cabal b/adventofcode24.cabal index 600bd36..3f0c67b 100644 --- a/adventofcode24.cabal +++ b/adventofcode24.cabal @@ -173,6 +173,10 @@ executable advent15 executable advent16 import: warnings, common-extensions, build-directives, common-modules main-is: advent16/Main.hs + build-depends: containers, linear, mtl, pqueue +executable advent16orig + import: warnings, common-extensions, build-directives, common-modules + main-is: advent16/MainOriginal.hs build-depends: containers, linear, mtl executable advent16sa import: warnings, common-extensions, build-directives, common-modules -- 2.34.1