Day 17: Clumsy Crucible

README.md

@@ -21,3 +21,4 @@ Development occurs in language-specific directories:
 |[Day14.hs](hs/src/Day14.hs)|[Day14.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day14.kt)|[day14.py](py/aoc2023/day14.py)|[day14.rs](rs/src/day14.rs)|
 |[Day15.hs](hs/src/Day15.hs)|[Day15.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day15.kt)|[day15.py](py/aoc2023/day15.py)|[day15.rs](rs/src/day15.rs)|
 |[Day16.hs](hs/src/Day16.hs)|[Day16.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day16.kt)|[day16.py](py/aoc2023/day16.py)|[day16.rs](rs/src/day16.rs)|
+|[Day17.hs](hs/src/Day17.hs)||||

hs/aoc2023.cabal

@@ -36,7 +36,8 @@ library
         Day13,
         Day14,
         Day15,
-        Day16
+        Day16,
+        Day17
 
     -- Modules included in this library but not exported.
     other-modules:
@@ -47,6 +48,7 @@ library
     build-depends:
         base ^>=4.17.2.0,
         containers ^>=0.6.7,
+        heap ^>=1.0.4,
         megaparsec ^>=9.6.1,
         monad-loops ^>=0.4.3,
         mtl ^>=2.2.2,
@@ -100,7 +102,8 @@ test-suite aoc2023-test
         Day13Spec,
         Day14Spec,
         Day15Spec,
-        Day16Spec
+        Day16Spec,
+        Day17Spec
     build-depends:
         aoc2023,
         base ^>=4.17.2.0,

hs/app/Main.hs

@@ -17,6 +17,7 @@ import qualified Day13 (part1, part2)
 import qualified Day14 (part1, part2)
 import qualified Day15 (part1, part2)
 import qualified Day16 (part1, part2)
+import qualified Day17 (part1, part2)
 
 import Control.Monad (ap, when)
 import Data.Foldable (find)
@@ -63,3 +64,4 @@ main = do
     run 14 print [Day14.part1, Day14.part2]
     run 15 print [Day15.part1, Day15.part2]
     run 16 print [Day16.part1, Day16.part2]
+    run 17 (maybe (fail "error") print) [Day17.part1, Day17.part2]

hs/bench/Main.hs

@@ -22,6 +22,7 @@ import qualified Day13 (part1, part2)
 import qualified Day14 (part1, part2)
 import qualified Day15 (part1, part2)
 import qualified Day16 (part1, part2)
+import qualified Day17 (part1, part2)
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 import System.FilePath (combine)
 
@@ -103,4 +104,8 @@ main = defaultMain
       [ bench "part 1" $ nf Day16.part1 input
       , bench "part 2" $ nf Day16.part2 input
       ]
+  , env (getDayInput 17) $ \input -> bgroup "Day 17"
+      [ bench "part 1" $ nf Day17.part1 input
+      , bench "part 2" $ nf Day17.part2 input
+      ]
   ]

hs/src/Day17.hs

@@ -0,0 +1,68 @@
+{-|
+Module:         Day17
+Description:    <https://adventofcode.com/2023/day/17 Day 17: Clumsy Crucible>
+-}
+{-# LANGUAGE ViewPatterns #-}
+module Day17 (part1, part2) where
+
+import Control.Arrow (first, second)
+import Data.Char (digitToInt)
+import Data.Heap (FstMinPolicy, Heap)
+import qualified Data.Heap as Heap (insert, singleton, view)
+import Data.List (foldl')
+import qualified Data.Set as Set (empty, insert, member)
+import Data.Text (Text)
+import qualified Data.Text as T (index, lines, length, null)
+import qualified Data.Vector as V (Vector, (!), fromList, last, length)
+import qualified Data.Vector.Unboxed as UV (Vector, (!), generate, length)
+
+data Direction = U | L | D | R deriving (Bounded, Enum, Eq, Ord, Show)
+
+move :: Direction -> (Int, Int) -> (Int, Int)
+move U = first pred
+move L = second pred
+move D = first succ
+move R = second succ
+
+pred', succ' :: (Bounded a, Enum a, Eq a) => a -> a
+pred' a = if a == minBound then maxBound else pred a
+succ' a = if a == maxBound then minBound else succ a
+
+parse :: Text -> V.Vector (UV.Vector Int)
+parse = V.fromList . map digitsToInts . filter (not . T.null) . T.lines where
+    digitsToInts line = UV.generate (T.length line) $ digitToInt . T.index line
+
+part1, part2 :: Text -> Maybe Int
+part1 input = bfs (Heap.singleton @FstMinPolicy (0, (0, 0, R, 0))) Set.empty where
+    maze = parse input
+    bfs (Heap.view -> Just ((k, state@(y, x, d, n)), q)) visited
+      | Set.member state visited = bfs q visited
+      | y == V.length maze - 1 && x == UV.length (V.last maze) - 1 = Just $ k + y + x
+      | otherwise = bfs (foldl' (flip Heap.insert) q next) $ Set.insert state visited
+      where
+        next =
+          [ (k + maze V.! y' UV.! x' + y - y' + x - x', (y', x', d', n'))
+          | (d', n') <- (pred' d, 1) : (succ' d, 1) : [(d, n + 1) | n < 3]
+          , let (y', x') = move d' (y, x)
+          , 0 <= y' && y' < V.length maze
+          , 0 <= x' && x' < UV.length (maze V.! y')
+          ]
+    bfs _ _ = Nothing
+part2 input = bfs (Heap.singleton @FstMinPolicy (0, (0, 0, R, 0))) Set.empty where
+    maze = parse input
+    bfs (Heap.view -> Just ((k, state@(y, x, d, n)), q)) visited
+      | Set.member state visited = bfs q visited
+      | y == V.length maze - 1 && x == UV.length (V.last maze) - 1 && n >= 4 = Just $ k + y + x
+      | otherwise = bfs (foldl' (flip Heap.insert) q next) $ Set.insert state visited
+      where
+        next =
+          [ (k + maze V.! y' UV.! x' + y - y' + x - x', (y', x', d', n'))
+          | (d', n') <-
+                [(pred' d, 1) | n >= 4] ++
+                [(succ' d, 1) | n >= 4] ++
+                [(d, n + 1) | n < 10]
+          , let (y', x') = move d' (y, x)
+          , 0 <= y' && y' < V.length maze
+          , 0 <= x' && x' < UV.length (maze V.! y')
+          ]
+    bfs _ _ = Nothing

hs/test/Day17Spec.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day17Spec (spec) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unlines)
+import Day17 (part1, part2)
+import Test.Hspec (Spec, describe, it, shouldBe, it)
+
+example1, example2 :: Text
+example1 = T.unlines
+  [ -- :r!wl-paste | sed 's/.*/  , "&"/;1s/,/ /'
+    "2413432311323"
+  , "3215453535623"
+  , "3255245654254"
+  , "3446585845452"
+  , "4546657867536"
+  , "1438598798454"
+  , "4457876987766"
+  , "3637877979653"
+  , "4654967986887"
+  , "4564679986453"
+  , "1224686865563"
+  , "2546548887735"
+  , "4322674655533"
+  ]
+example2 = T.unlines
+  [ -- :r!wl-paste | sed 's/.*/  , "&"/;1s/,/ /'
+    "111111111111"
+  , "999999999991"
+  , "999999999991"
+  , "999999999991"
+  , "999999999991"
+  ]
+
+spec :: Spec
+spec = do
+    describe "part 1" $ do
+        it "examples" $ do
+            part1 example1 `shouldBe` Just 102
+    describe "part 2" $ do
+        it "examples" $ do
+            part2 example1 `shouldBe` Just 94
+            part2 example2 `shouldBe` Just 71