Optimised day 16

diff --git a/advent16/Main.hs b/advent16/Main.hs
index 17bb54d3ae58417aa10cf890aea8807dfa42ca23..d8b44d430342fa115284dbe64562792d3b203380 100644 (file)
--- 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 (file)
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 600bd365c11095ecc8c7414fd00b9f7731f22260..3f0c67b75245c707d0f2a860891c50b8609d763b 100644 (file)
--- 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