Merge pull request #102 from ephemient/hs/day16

Day 16: Reindeer Maze

README.md

@@ -20,3 +20,4 @@ Development occurs in language-specific directories:
 |[Day13.hs](hs/src/Day13.hs)|[Day13.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day13.kt)|[day13.py](py/aoc2024/day13.py)||
 |[Day14.hs](hs/src/Day14.hs)|[Day14.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day14.kt)|||
 |[Day15.hs](hs/src/Day15.hs)||||
+|[Day16.hs](hs/src/Day16.hs)||||

hs/aoc2024.cabal

@@ -28,6 +28,7 @@ library
     Day13
     Day14
     Day15
+    Day16
     Day2
     Day3
     Day4
@@ -44,6 +45,7 @@ library
     array ^>=0.5.7.0,
     base ^>=4.20.0.0,
     containers ^>=0.7,
+    heap ^>=1.0.4,
     megaparsec ^>=9.7.0,
     parallel ^>=3.2.2.0,
     split ^>=0.2.5,
@@ -82,6 +84,7 @@ test-suite aoc2024-test
     Day13Spec
     Day14Spec
     Day15Spec
+    Day16Spec
     Day1Spec
     Day2Spec
     Day3Spec

hs/app/Main.hs

@@ -14,6 +14,7 @@ import Day12 qualified (part1, part2)
 import Day13 qualified (part1, part2)
 import Day14 qualified (part1, part2)
 import Day15 qualified (part1, part2)
+import Day16 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -60,3 +61,4 @@ main = do
   run 13 (either (fail . errorBundlePretty) print) [Day13.part1, Day13.part2]
   run 14 (either (fail . errorBundlePretty) print) [Day14.part1, Day14.part2]
   run 15 (either fail print) [Day15.part1, Day15.part2]
+  run 16 (maybe (fail "error") print) [Day16.part1, Day16.part2]

hs/bench/Main.hs

@@ -13,6 +13,7 @@ import Day12 qualified (part1, part2)
 import Day13 qualified (part1, part2)
 import Day14 qualified (part1, part2)
 import Day15 qualified (part1, part2)
+import Day16 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -127,5 +128,11 @@ main =
           "Day 15"
           [ bench "part 1" $ nf Day15.part1 input,
             bench "part 2" $ nf Day15.part2 input
+          ],
+      env (getDayInput 16) $ \input ->
+        bgroup
+          "Day 16"
+          [ bench "part 1" $ nf Day16.part1 input,
+            bench "part 2" $ nf Day16.part2 input
           ]
     ]

hs/src/Day16.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE ViewPatterns #-}
+
+-- |
+-- Module:         Day16
+-- Description:    <https://adventofcode.com/2024/day/16 Day 16: Reindeer Maze>
+module Day16 (part1, part2) where
+
+import Control.Arrow (second)
+import Control.Exception (assert)
+import Data.Heap (FstMinPolicy)
+import Data.Heap qualified as Heap (insert, singleton, view)
+import Data.Map qualified as Map (empty, insert, (!?))
+import Data.Set (Set)
+import Data.Set qualified as Set (empty, fromList, insert, member, notMember, size)
+import Data.Text (Text)
+import Data.Text qualified as T (foldl)
+
+parse :: Text -> Maybe (Set (Int, Int), (Int, Int), (Int, Int))
+parse input = case T.foldl parse' (0, 0, Set.empty, [], []) input of
+  (_, _, maze, [start], [end]) -> Just (maze, start, end)
+  _ -> Nothing
+  where
+    parse' (y, _, maze, start, end) '\n' = (y + 1, 0, maze, start, end)
+    parse' (y, x, maze, start, end) '#' = (y, x + 1, Set.insert (y, x) maze, start, end)
+    parse' (y, x, maze, start, end) 'S' = (y, x + 1, maze, (y, x) : start, end)
+    parse' (y, x, maze, start, end) 'E' = (y, x + 1, maze, start, (y, x) : end)
+    parse' (y, x, maze, start, end) _ = (y, x + 1, maze, start, end)
+
+part1 :: Text -> Maybe Int
+part1 input = do
+  (maze, start, end) <- parse input
+  let go visited (Heap.view -> Just ((score, pv@(p@(y, x), v@(dy, dx))), queue'))
+        | p == end = Just score
+        | pv `Set.member` visited = go visited queue'
+        | otherwise =
+            go (Set.insert pv visited) . foldl' (flip Heap.insert) queue' $
+              [(score + 1, (p', v)) | let p' = (y + dy, x + dx), p' `Set.notMember` maze]
+                ++ [(score + 1000, (p, (-dx, dy))), (score + 1000, (p, (dx, -dy)))]
+      go _ _ = Nothing
+  go Set.empty $ Heap.singleton @FstMinPolicy (0 :: Int, (start, (0, 1)))
+
+part2 :: Text -> Maybe Int
+part2 input = do
+  (maze, start, end) <- parse input
+  best <- part1 input
+  let go acc visited (Heap.view -> Just ((score, (pv@(p@(y, x), v@(dy, dx)), path)), queue))
+        | p == end = assert (score == best) $ go (acc <> Set.fromList (p : path)) visited' queue
+        | Just score' <- visited Map.!? pv, score' < score = go acc visited queue
+        | otherwise =
+            go acc visited' . foldl' (flip Heap.insert) queue . map (second (,path')) . filter ok $
+              [(score + 1, (p', v)) | let p' = (y + dy, x + dx), p' `Set.notMember` maze]
+                ++ [(score + 1000, (p, (-dx, dy))), (score + 1000, (p, (dx, -dy)))]
+        where
+          visited' = Map.insert pv score visited
+          path' = p : path
+          ok (score', pv') = score' <= best && maybe True (>= score) (visited Map.!? pv')
+      go acc _ _ = Set.size acc
+  pure $ go Set.empty Map.empty $ Heap.singleton @FstMinPolicy (0 :: Int, ((start, (0, 1)), []))

hs/test/Day16Spec.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day16Spec (spec) where
+
+import Data.Text (Text)
+import Data.Text qualified as T (unlines)
+import Day16 (part1, part2)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example1, example2 :: Text
+example1 =
+  T.unlines
+    [ -- :r!pbpaste | sed 's/.*/  , "&"/;1s/,/ /'
+      "###############",
+      "#.......#....E#",
+      "#.#.###.#.###.#",
+      "#.....#.#...#.#",
+      "#.###.#####.#.#",
+      "#.#.#.......#.#",
+      "#.#.#####.###.#",
+      "#...........#.#",
+      "###.#.#####.#.#",
+      "#...#.....#.#.#",
+      "#.#.#.###.#.#.#",
+      "#.....#...#.#.#",
+      "#.###.#.#.#.#.#",
+      "#S..#.....#...#",
+      "###############"
+    ]
+example2 =
+  T.unlines
+    [ "#################",
+      "#...#...#...#..E#",
+      "#.#.#.#.#.#.#.#.#",
+      "#.#.#.#...#...#.#",
+      "#.#.#.#.###.#.#.#",
+      "#...#.#.#.....#.#",
+      "#.#.#.#.#.#####.#",
+      "#.#...#.#.#.....#",
+      "#.#.#####.#.###.#",
+      "#.#.#.......#...#",
+      "#.#.###.#####.###",
+      "#.#.#...#.....#.#",
+      "#.#.#.#####.###.#",
+      "#.#.#.........#.#",
+      "#.#.#.#########.#",
+      "#S#.............#",
+      "#################"
+    ]
+
+spec :: Spec
+spec = do
+  describe "part 1" $ do
+    it "examples" $ do
+      part1 example1 `shouldBe` Just 7036
+      part1 example2 `shouldBe` Just 11048
+  describe "part 2" $ do
+    it "examples" $ do
+      part2 example1 `shouldBe` Just 45
+      part2 example2 `shouldBe` Just 64