Day 15: Warehouse Woes

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)||||

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

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]

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
           ]
     ]

hs/src/Day14.hs

@@ -7,13 +7,15 @@ module Day14 (part1, part1', part2) where
 
 import Common (groupConsecutiveBy)
 import Control.Monad (join, liftM2)
+import Data.Char (intToDigit)
 import Data.Map qualified as Map (findWithDefault)
 import Data.Map.Strict qualified as Map (fromListWith)
 import Data.Ord (Down (Down))
 import Data.Set qualified as Set (fromList, toList)
 import Data.String (IsString)
 import Data.Text (Text)
 import Data.Void (Void)
+import Debug.Trace (traceM)
 import Text.Megaparsec (MonadParsec, ParseErrorBundle, Stream (Token, Tokens), parse, sepEndBy1)
 import Text.Megaparsec.Char (char, newline, string)
 import Text.Megaparsec.Char.Lexer qualified as L (decimal, signed)
@@ -22,7 +24,7 @@ parser :: (MonadParsec e s m, IsString (Tokens s), Token s ~ Char, Num a) => m [
 parser = line `sepEndBy1` newline
   where
     line = (,) <$> (string "p=" *> v2) <*> (string " v=" *> v2)
-    v2 = (,) <$> (L.signed (pure ()) L.decimal <* char ',') <*> (L.signed (pure ()) L.decimal)
+    v2 = (,) <$> (L.signed (pure ()) L.decimal <* char ',') <*> L.signed (pure ()) L.decimal
 
 part1 :: Text -> Either (ParseErrorBundle Text Void) Int
 part1 = part1' 101 103
@@ -44,16 +46,30 @@ part1' width height input = do
 part2 :: Text -> Either (ParseErrorBundle Text Void) Int
 part2 input = do
   robots <- parse parser "" input
-  pure . snd . minimum $
-    [ (Down $ maximum $ map length verticalLines, t)
-    | t <- [0 .. lcm width height - 1],
-      let verticalLines =
-            groupConsecutiveBy isLine . Set.toList . Set.fromList $
-              [ ((y0 + vy * t) `mod` height, (x0 + vx * t) `mod` width)
-              | ((x0, y0), (vx, vy)) <- robots
-              ]
-          isLine (y0, x0) (y1, x1) = y0 == y1 && x0 + 1 == x1
-    ]
+  let (_, bestTime) =
+        minimum
+          [ (Down $ maximum $ map length verticalLines, t)
+          | t <- [0 .. lcm width height - 1],
+            let verticalLines =
+                  groupConsecutiveBy isLine . Set.toList . Set.fromList $
+                    [ ((y0 + vy * t) `mod` height, (x0 + vx * t) `mod` width)
+                    | ((x0, y0), (vx, vy)) <- robots
+                    ]
+                isLine (y0, x0) (y1, x1) = y0 == y1 && x0 + 1 == x1
+          ]
+      positions =
+        Map.fromListWith (+) $
+          [ (((x0 + vx * bestTime) `mod` width, (y0 + vy * bestTime) `mod` height), 1)
+          | ((x0, y0), (vx, vy)) <- robots
+          ]
+      line y =
+        [ case Map.findWithDefault 0 (x, y) positions of
+            0 -> '.'
+            n -> if n < 10 then intToDigit n else '+'
+        | x <- [0 .. width - 1]
+        ]
+  mapM_ (traceM . line) [0 .. height - 1]
+  pure bestTime
   where
     width = 101
     height = 103

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

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