Day 15: Warehouse Woes

ephemient · Dec 16, 2024 · fc1c330 · fc1c330
1 parent a4d2aef
commit fc1c330
Show file tree

Hide file tree

Showing 6 changed files with 162 additions and 0 deletions.
diff --git a/README.md b/README.md
@@ -19,3 +19,4 @@ Development occurs in language-specific directories:
 |[Day12.hs](hs/src/Day12.hs)|[Day12.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day12.kt)|[day12.py](py/aoc2024/day12.py)||
 |[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)||||
diff --git a/hs/aoc2024.cabal b/hs/aoc2024.cabal
@@ -27,6 +27,7 @@ library
     Day12
     Day13
     Day14
+    Day15
     Day2
     Day3
     Day4
@@ -40,6 +41,7 @@ library
     Common
 
   build-depends:
+    array ^>=0.5.7.0,
     base ^>=4.20.0.0,
     containers ^>=0.7,
     megaparsec ^>=9.7.0,
@@ -79,6 +81,7 @@ test-suite aoc2024-test
     Day12Spec
     Day13Spec
     Day14Spec
+    Day15Spec
     Day1Spec
     Day2Spec
     Day3Spec

diff --git a/hs/app/Main.hs b/hs/app/Main.hs
@@ -13,6 +13,7 @@ import Day11 qualified (part1, part2)
 import Day12 qualified (part1, part2)
 import Day13 qualified (part1, part2)
 import Day14 qualified (part1, part2)
+import Day15 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -58,3 +59,4 @@ main = do
   run 12 print [Day12.part1, Day12.part2]
   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]
diff --git a/hs/bench/Main.hs b/hs/bench/Main.hs
@@ -12,6 +12,7 @@ import Day11 qualified (part1, part2)
 import Day12 qualified (part1, part2)
 import Day13 qualified (part1, part2)
 import Day14 qualified (part1, part2)
+import Day15 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -120,5 +121,11 @@ main =
           "Day 14"
           [ bench "part 1" $ nf Day14.part1 input,
             bench "part 2" $ nf Day14.part2 input
+          ],
+      env (getDayInput 15) $ \input ->
+        bgroup
+          "Day 15"
+          [ bench "part 1" $ nf Day15.part1 input,
+            bench "part 2" $ nf Day15.part2 input
           ]
     ]
diff --git a/hs/src/Day15.hs b/hs/src/Day15.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module:         Day15
+-- Description:    <https://adventofcode.com/2024/day/15 Day 15: Warehouse Woes>
+module Day15 (part1, part2) where
+
+import Control.Arrow (Arrow (first, second))
+import Control.Exception (assert)
+import Data.Array.Unboxed (IArray, UArray, assocs, listArray, (!), (//))
+import Data.List (sort)
+import Data.Text (Text)
+import Data.Text qualified as T (breakOn, concat, concatMap, foldl', justifyLeft, length, lines, singleton, unpack)
+import Data.Text.Read (Reader)
+
+parse :: (IArray a Char) => Reader (a (Int, Int) Char)
+parse input
+  | null grid = Left "empty warehouse"
+  | otherwise =
+      Right
+        ( listArray ((0, 0), (height - 1, width - 1)) . T.unpack . T.concat $
+            T.justifyLeft width '.' <$> grid,
+          rest
+        )
+  where
+    (grid, rest) = first T.lines $ T.breakOn "\n\n" input
+    height = length grid
+    width = maximum $ 0 : map T.length grid
+
+part1 :: Text -> Either String Int
+part1 input = do
+  (grid0, moves) <- parse @UArray input
+  pos0 <- case filter ((== '@') . snd) $ assocs grid0 of
+    [(pos0, _)] -> Right pos0
+    _ -> Left "can't find @"
+  pure . sum $
+    [ 100 * y + x
+    | ((y, x), c) <- assocs . fst $ T.foldl' move (grid0, pos0) moves,
+      c == 'O' || c == '['
+    ]
+  where
+    move state@(grid, pos) c
+      | '^' <- c = move' moveY (first pred pos) (-1)
+      | 'v' <- c = move' moveY (first succ pos) 1
+      | '<' <- c = move' moveX (second pred pos) (-1)
+      | '>' <- c = move' moveX (second succ pos) 1
+      where
+        move' mover pos' delta =
+          assert (grid ! pos == '@') . maybe state ((,pos') . (grid //) . sort) $
+            mover delta pos' [(pos', '@'), (pos, '.')]
+        moveY, moveX :: Int -> (Int, Int) -> [((Int, Int), Char)] -> Maybe [((Int, Int), Char)]
+        moveY dy pos'@(y, x) k = case grid ! pos' of
+          '.' -> Just k
+          'O' -> moveY dy (y + dy, x) $ ((y + dy, x), 'O') : (pos', '.') : k
+          '[' ->
+            assert (grid ! (y, x + 1) == ']') do
+              k' <-
+                moveY dy (y + dy, x) $
+                  ((y + dy, x), '[') : ((y + dy, x + 1), ']') : ((y, x), '.') : ((y, x + 1), '.') : k
+              moveY dy (y + dy, x + 1) k'
+          ']' -> assert (grid ! (y, x - 1) == '[') do
+            k' <- moveY dy (y + dy, x) $ ((y + dy, x - 1), '[') : ((y + dy, x), ']') : ((y, x - 1), '.') : ((y, x), '.') : k
+            moveY dy (y + dy, x - 1) k'
+          _ -> Nothing
+        moveX dx pos'@(y, x) k = case grid ! pos' of
+          '.' -> Just k
+          d | d == 'O' || d == '[' || d == ']' -> moveX dx (y, x + dx) $ ((y, x + dx), d) : (pos', '.') : k
+          _ -> Nothing
+    move state _ = state
+
+part2 :: Text -> Either String Int
+part2 =
+  part1 . T.concatMap \case
+    '#' -> "##"
+    '.' -> ".."
+    '@' -> "@."
+    'O' -> "[]"
+    c -> T.singleton c
diff --git a/hs/test/Day15Spec.hs b/hs/test/Day15Spec.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day15Spec (spec) where
+
+import Data.Text (Text)
+import Data.Text qualified as T (unlines)
+import Day15 (part1, part2)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example1, example2, example3 :: Text
+example1 =
+  T.unlines
+    [ "##########",
+      "#..O..O.O#",
+      "#......O.#",
+      "#.OO..O.O#",
+      "#[email protected].#",
+      "#O#..O...#",
+      "#O..O..O.#",
+      "#.OO.O.OO#",
+      "#....O...#",
+      "##########",
+      "",
+      "<vv>^<v^>v>^vv^v>v<>v^v<v<^vv<<<^><<><>>v<vvv<>^v^>^<<<><<v<<<v^vv^v>^",
+      "vvv<<^>^v^^><<>>><>^<<><^vv^^<>vvv<>><^^v>^>vv<>v<<<<v<^v>^<^^>>>^<v<v",
+      "><>vv>v^v^<>><>>>><^^>vv>v<^^^>>v^v^<^^>v^^>v^<^v>v<>>v^v^<v>v^^<^^vv<",
+      "<<v<^>>^^^^>>>v^<>vvv^><v<<<>^^^vv^<vvv>^>v<^^^^v<>^>vvvv><>>v^<<^^^^^",
+      "^><^><>>><>^^<<^^v>>><^<v>^<vv>>v>>>^v><>^v><<<<v>>v<v<v>vvv>^<><<>^><",
+      "^>><>^v<><^vvv<^^<><v<<<<<><^v<<<><<<^^<v<^^^><^>>^<v^><<<^>>^v<v^v<v^",
+      ">^>>^v>vv>^<<^v<>><<><<v<<v><>v<^vv<<<>^^v^>^^>>><<^v>>v^v><^^>>^<>vv^",
+      "<><^^>^^^<><vvvvv^v<v<<>^v<v>v<<^><<><<><<<^^<<<^<<>><<><^^^>^^<>^>v<>",
+      "^^>vv<^v^v<vv>^<><v<^v>^^^>>>^^vvv^>vvv<>>>^<^>>>>>^<<^v>^vvv<>^<><<v>",
+      "v^^>>><<^^<>>^v^<v^vv<>v^<<>^<^v^v><^<<<><<^<v><v<>vv>>v><v^<vv<>v^<<^"
+    ]
+example2 =
+  T.unlines
+    [ "########",
+      "#..O.O.#",
+      "##@.O..#",
+      "#...O..#",
+      "#.#.O..#",
+      "#...O..#",
+      "#......#",
+      "########",
+      "",
+      "<^^>>>vv<v>>v<<"
+    ]
+example3 =
+  T.unlines
+    [ "#######",
+      "#...#.#",
+      "#.....#",
+      "#..OO@#",
+      "#..O..#",
+      "#.....#",
+      "#######",
+      "",
+      "<vv<<^^<<^^"
+    ]
+
+spec :: Spec
+spec = do
+  describe "part 1" $ do
+    it "examples" $ do
+      part1 example2 `shouldBe` Right 2028
+      part1 example1 `shouldBe` Right 10092
+  describe "part 2" $ do
+    it "examples" $ do
+      part2 example3 `shouldBe` Right 618
+      part2 example1 `shouldBe` Right 9021