Merge pull request #96 from ephemient/hs/day14

Day 14: Restroom Redoubt

README.md

@@ -18,3 +18,4 @@ Development occurs in language-specific directories:
 |[Day11.hs](hs/src/Day11.hs)|[Day11.kt](kt/aoc2024-lib/src/commonMain/kotlin/com/github/ephemient/aoc2024/Day11.kt)|[day11.py](py/aoc2024/day11.py)|[day11.rs](rs/src/day11.rs)|
 |[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)||||

hs/aoc2024.cabal

@@ -26,6 +26,7 @@ library
     Day11
     Day12
     Day13
+    Day14
     Day2
     Day3
     Day4
@@ -77,6 +78,7 @@ test-suite aoc2024-test
     Day11Spec
     Day12Spec
     Day13Spec
+    Day14Spec
     Day1Spec
     Day2Spec
     Day3Spec

hs/app/Main.hs

@@ -12,6 +12,7 @@ import Day10 qualified (part1, part2)
 import Day11 qualified (part1, part2)
 import Day12 qualified (part1, part2)
 import Day13 qualified (part1, part2)
+import Day14 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -56,3 +57,4 @@ main = do
   run 11 (either fail print) [Day11.part1, Day11.part2]
   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]

hs/bench/Main.hs

@@ -11,6 +11,7 @@ import Day10 qualified (part1, part2)
 import Day11 qualified (part1, part2)
 import Day12 qualified (part1, part2)
 import Day13 qualified (part1, part2)
+import Day14 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -113,5 +114,11 @@ main =
           "Day 13"
           [ bench "part 1" $ nf Day13.part1 input,
             bench "part 2" $ nf Day13.part2 input
+          ],
+      env (getDayInput 14) $ \input ->
+        bgroup
+          "Day 14"
+          [ bench "part 1" $ nf Day14.part1 input,
+            bench "part 2" $ nf Day14.part2 input
           ]
     ]

hs/src/Common.hs

@@ -1,4 +1,4 @@
-module Common (readEntire, readMany, readSome) where
+module Common (groupConsecutiveBy, readEntire, readMany, readSome) where
 
 import Control.Arrow (first)
 import Data.Char (isSpace)
@@ -7,6 +7,13 @@ import Data.Text (Text)
 import Data.Text qualified as T (dropWhile, null)
 import Data.Text.Read (Reader)
 
+groupConsecutiveBy :: (a -> a -> Bool) -> [a] -> [[a]]
+groupConsecutiveBy f xs = chunk id $ zip xs $ True : zipWith f xs (drop 1 xs)
+  where
+    chunk k [] = filter (not . null) [k []]
+    chunk k ((x, False) : rest) = k [] : chunk (x :) rest
+    chunk k ((x, True) : rest) = chunk (k . (x :)) rest
+
 readEntire :: Reader a -> Text -> Either String a
 readEntire reader input = do
   (a, t) <- reader input

hs/src/Day14.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module:         Day14
+-- Description:    <https://adventofcode.com/2024/day/14 Day 14: Restroom Redoubt>
+module Day14 (part1, part1', part2) where
+
+import Common (groupConsecutiveBy)
+import Control.Monad (join, liftM2)
+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 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)
+
+parser :: (MonadParsec e s m, IsString (Tokens s), Token s ~ Char, Num a) => m [((a, a), (a, a))]
+parser = line `sepEndBy1` newline
+  where
+    line = (,) <$> (string "p=" *> v2) <*> (string " v=" *> v2)
+    v2 = (,) <$> (L.signed (pure ()) L.decimal <* char ',') <*> (L.signed (pure ()) L.decimal)
+
+part1 :: Text -> Either (ParseErrorBundle Text Void) Int
+part1 = part1' 101 103
+
+part1' :: Int -> Int -> Text -> Either (ParseErrorBundle Text Void) Int
+part1' width height input = do
+  robots <- parse parser "" input
+  let totals =
+        Map.fromListWith (+) $
+          [ ((compare x $ width `div` 2, compare y $ height `div` 2), 1)
+          | ((x0, y0), (vx, vy)) <- robots,
+            let x = (x0 + vx * t) `mod` width
+                y = (y0 + vy * t) `mod` height
+          ]
+  pure $ product [Map.findWithDefault 0 k totals | k <- join (liftM2 (,)) [LT, GT]]
+  where
+    t = 100
+
+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
+    ]
+  where
+    width = 101
+    height = 103

hs/test/Day14Spec.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day14Spec (spec) where
+
+import Data.Text (Text)
+import Data.Text qualified as T (unlines)
+import Day14 (part1')
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example =
+  T.unlines
+    [ "p=0,4 v=3,-3",
+      "p=6,3 v=-1,-3",
+      "p=10,3 v=-1,2",
+      "p=2,0 v=2,-1",
+      "p=0,0 v=1,3",
+      "p=3,0 v=-2,-2",
+      "p=7,6 v=-1,-3",
+      "p=3,0 v=-1,-2",
+      "p=9,3 v=2,3",
+      "p=7,3 v=-1,2",
+      "p=2,4 v=2,-3",
+      "p=9,5 v=-3,-3"
+    ]
+
+spec :: Spec
+spec = do
+  describe "part 1" $ do
+    it "examples" $ do
+      part1' 11 7 example `shouldBe` Right 12