Merge pull request #137 from ephemient/hs/day21

.github/workflows/hs-bench.yml

@@ -49,6 +49,7 @@ jobs:
       - run: cabal bench bench:aoc2024-bench --benchmark-options='-o aoc2024-bench.html'
         env:
           AOC2024_DATADIR: ${{ github.workspace }}/inputs
+          TRACE: 0
         working-directory: hs
       - uses: actions/checkout@v4
         with:

README.md

@@ -25,3 +25,4 @@ Development occurs in language-specific directories:
 |[Day18.hs](hs/src/Day18.hs)|[Day18.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day18.kt)|[day18.py](py/aoc2024/day18.py)|[day18.rs](rs/src/day18.rs)|
 |[Day19.hs](hs/src/Day19.hs)|[Day19.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day19.kt)|[day19.py](py/aoc2024/day19.py)|[day19.rs](rs/src/day19.rs)|
 |[Day20.hs](hs/src/Day20.hs)|[Day20.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day20.kt)|[day20.py](py/aoc2024/day20.py)|[day20.rs](rs/src/day20.rs)|
+|[Day21.hs](hs/src/Day21.hs)||||

hs/aoc2024.cabal

@@ -34,6 +34,7 @@ library
     Day19
     Day2
     Day20
+    Day21
     Day3
     Day4
     Day5
@@ -94,6 +95,7 @@ test-suite aoc2024-test
     Day19Spec
     Day1Spec
     Day20Spec
+    Day21Spec
     Day2Spec
     Day3Spec
     Day4Spec

hs/app/Main.hs

@@ -22,6 +22,7 @@ import Day18 qualified (part1, part2)
 import Day19 qualified (solve)
 import Day2 qualified (part1, part2)
 import Day20 qualified (solve)
+import Day21 qualified (solve)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
 import Day5 qualified (part1, part2)
@@ -72,3 +73,4 @@ main = do
   run 18 (either fail putStrLn) [fmap show . Day18.part1, fmap (uncurry $ (. (',' :) . show) . shows) . Day18.part2]
   run 19 (uncurry (>>) . bimap print print) [Day19.solve]
   run 20 print [Day20.solve 2 100, Day20.solve 20 100]
+  run 21 print [Day21.solve 2, Day21.solve 25]

hs/bench/Main.hs

@@ -19,6 +19,7 @@ import Day18 qualified (part1, part2)
 import Day19 qualified (solve)
 import Day2 qualified (part1, part2)
 import Day20 qualified (solve)
+import Day21 qualified (solve)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
 import Day5 qualified (part1, part2)
@@ -161,5 +162,11 @@ main =
           "Day 20"
           [ bench "part 1" $ nf (Day20.solve 2 100) input,
             bench "part 2" $ nf (Day20.solve 20 100) input
+          ],
+      env (getDayInput 21) $ \input ->
+        bgroup
+          "Day 21"
+          [ bench "part 1" $ nf (Day21.solve 2) input,
+            bench "part 2" $ nf (Day21.solve 25) input
           ]
     ]

hs/src/Day21.hs

@@ -0,0 +1,52 @@
+-- |
+-- Module:         Day21
+-- Description:    <https://adventofcode.com/2024/day/21 Day 21: Keypad Conundrum>
+module Day21 (solve) where
+
+import Data.Array.Unboxed (UArray, listArray, range, (!))
+import Data.Char (digitToInt, isDigit)
+import Data.Function (on)
+import Data.List (permutations)
+import Data.Text (Text)
+import Data.Text qualified as T (foldl', lines, unpack)
+
+luts :: [UArray ((Int, Int), (Int, Int)) Int]
+luts =
+  iterate buildLut . listArray ((lo, lo), (hi, hi)) $
+    [abs (x2 - x1) + abs (y2 - y1) + 1 | ((x1, y1), (x2, y2)) <- range ((lo, lo), (hi, hi))]
+  where
+    (lo, hi) = ((0, -1), (2, 3))
+    buildLut lut =
+      listArray (((0, -1), (0, -1)), ((2, 3), (2, 3))) $
+        [ foldl' min maxBound $ map cost $ filter check $ permutations moves
+        | ((x1, y1), (x2, y2)) <- range ((lo, lo), (hi, hi)),
+          let moves =
+                replicate (x2 - x1) (2, -1)
+                  ++ replicate (y2 - y1) (1, 0)
+                  ++ replicate (y1 - y2) (1, -1)
+                  ++ replicate (x1 - x2) (0, -1)
+              check = notElem (0, 0) . scanl move (x1, y1)
+              cost string = sum $ zipWith (curry (lut !)) ((2, 0) : string) (string ++ [(2, 0)])
+        ]
+    move (x, y) (1, 0) = (x, y + 1)
+    move (x, y) (0, -1) = (x - 1, y)
+    move (x, y) (1, -1) = (x, y - 1)
+    move (x, y) (2, -1) = (x + 1, y)
+
+solve :: Int -> Text -> Int
+solve depth input = sum [cost (T.unpack line) * T.foldl' accumDigits 0 line | line <- T.lines input]
+  where
+    cost string = sum $ zipWith (curry (luts !! depth !) `on` pos) ('A' : string) string
+    accumDigits n d | isDigit d = 10 * n + digitToInt d
+    accumDigits n _ = n
+    pos '0' = (1, 0)
+    pos '1' = (0, 1)
+    pos '2' = (1, 1)
+    pos '3' = (2, 1)
+    pos '4' = (0, 2)
+    pos '5' = (1, 2)
+    pos '6' = (2, 2)
+    pos '7' = (0, 3)
+    pos '8' = (1, 3)
+    pos '9' = (2, 3)
+    pos _ = (2, 0)

hs/test/Day21Spec.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day21Spec (spec) where
+
+import Data.Text (Text)
+import Data.Text qualified as T (unlines)
+import Day21 (solve)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example =
+  T.unlines
+    [ "029A",
+      "980A",
+      "179A",
+      "456A",
+      "379A"
+    ]
+
+spec :: Spec
+spec = do
+  describe "part 1" $ do
+    it "examples" $ do
+      solve 2 example `shouldBe` 126384