Merge pull request #104 from ephemient/hs/day17

Day 17: Chronospatial Computer

README.md

@@ -21,3 +21,4 @@ Development occurs in language-specific directories:
 |[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)||||
 |[Day16.hs](hs/src/Day16.hs)||||
+|[Day17.hs](hs/src/Day17.hs)||||

hs/aoc2024.cabal

@@ -29,6 +29,7 @@ library
     Day14
     Day15
     Day16
+    Day17
     Day2
     Day3
     Day4
@@ -85,6 +86,7 @@ test-suite aoc2024-test
     Day14Spec
     Day15Spec
     Day16Spec
+    Day17Spec
     Day1Spec
     Day2Spec
     Day3Spec

hs/app/Main.hs

@@ -4,6 +4,7 @@ module Main (main) where
 
 import Control.Monad (ap, when)
 import Data.Foldable (find)
+import Data.List (intercalate)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Text.IO qualified as TIO (readFile)
@@ -15,6 +16,7 @@ import Day13 qualified (part1, part2)
 import Day14 qualified (part1, part2)
 import Day15 qualified (part1, part2)
 import Day16 qualified (part1, part2)
+import Day17 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -62,3 +64,4 @@ main = do
   run 14 (either (fail . errorBundlePretty) print) [Day14.part1, Day14.part2]
   run 15 (either fail print) [Day15.part1, Day15.part2]
   run 16 (maybe (fail "error") print) [Day16.part1, Day16.part2]
+  run 17 (either (fail . errorBundlePretty) $ putStrLn . intercalate "," . map show) [Day17.part1, fmap (: []) . Day17.part2]

hs/bench/Main.hs

@@ -14,6 +14,7 @@ import Day13 qualified (part1, part2)
 import Day14 qualified (part1, part2)
 import Day15 qualified (part1, part2)
 import Day16 qualified (part1, part2)
+import Day17 qualified (part1, part2)
 import Day2 qualified (part1, part2)
 import Day3 qualified (part1, part2)
 import Day4 qualified (part1, part2)
@@ -134,5 +135,11 @@ main =
           "Day 16"
           [ 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 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module:         Day17
+-- Description:    <https://adventofcode.com/2024/day/17 Day 17: Chronospatial Computer>
+module Day17 (part1, part2, run, step) where
+
+import Data.Bits (shiftR, xor, (.&.))
+import Data.List (isSuffixOf, unfoldr)
+import Data.Maybe (catMaybes)
+import Data.String (IsString)
+import Data.Text (Text)
+import Data.Void (Void)
+import Text.Megaparsec (MonadParsec, ParseErrorBundle, Stream (Token, Tokens), between, parse, sepBy)
+import Text.Megaparsec.Char (char, newline, string)
+import Text.Megaparsec.Char.Lexer qualified as L (decimal)
+
+parser :: (MonadParsec e s m, IsString (Tokens s), Token s ~ Char, Num a) => m ((a, a, a), [a])
+parser = do
+  a <- between (string "Register A: ") newline L.decimal
+  b <- between (string "Register B: ") newline L.decimal
+  c <- between (string "Register C: ") newline L.decimal
+  newline
+  program <- between (string "Program: ") newline $ L.decimal `sepBy` char ','
+  pure ((a, b, c), program)
+
+step :: [Int] -> (Int, (Int, Int, Int)) -> Maybe (Maybe Int, (Int, (Int, Int, Int)))
+step program (ip, registers@(a, b, c))
+  | ip < 0 || ip >= length program = Nothing
+  | 0 <- instruction = Just (Nothing, (ip + 2, (a `shiftR` combo, b, c)))
+  | 1 <- instruction = Just (Nothing, (ip + 2, (a, b `xor` operand, c)))
+  | 2 <- instruction = Just (Nothing, (ip + 2, (a, combo .&. 7, c)))
+  | 3 <- instruction = Just (Nothing, (if a == 0 then ip + 2 else operand, registers))
+  | 4 <- instruction = Just (Nothing, (ip + 2, (a, b `xor` c, c)))
+  | 5 <- instruction = Just (Just $ combo .&. 7, (ip + 2, registers))
+  | 6 <- instruction = Just (Nothing, (ip + 2, (a, a `shiftR` combo, c)))
+  | 7 <- instruction = Just (Nothing, (ip + 2, (a, b, a `shiftR` combo)))
+  where
+    instruction = program !! ip
+    operand = program !! (ip + 1)
+    combo
+      | 0 <= operand && operand <= 3 = operand
+      | 4 <- operand = a
+      | 5 <- operand = b
+      | 6 <- operand = c
+
+run :: [Int] -> (Int, Int, Int) -> [Int]
+run program = catMaybes . unfoldr (step program) . (0,)
+
+part1 :: Text -> Either (ParseErrorBundle Text Void) [Int]
+part1 input = do
+  (registers, program) <- parse parser "" input
+  pure $ run program registers
+
+part2 :: Text -> Either (ParseErrorBundle Text Void) Int
+part2 input = do
+  ((_, b, c), program) <- parse parser "" input
+  let go nums
+        | (a, _) : _ <- filter ((== program) . snd) next = a
+        | otherwise = go $ fst <$> next
+        where
+          next =
+            [ (a, output)
+            | a <- (+) . (8 *) <$> nums <*> [0 .. 7],
+              let output = run program (a, b, c),
+              output `isSuffixOf` program
+            ]
+  pure $ go [0]

hs/test/Day17Spec.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day17Spec (spec) where
+
+import Data.Text (Text)
+import Data.Text qualified as T (unlines)
+import Day17 (part1, part2, run, step)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example1, example2 :: Text
+example1 =
+  T.unlines
+    [ "Register A: 729",
+      "Register B: 0",
+      "Register C: 0",
+      "",
+      "Program: 0,1,5,4,3,0"
+    ]
+example2 =
+  T.unlines
+    [ "Register A: 2024",
+      "Register B: 0",
+      "Register C: 0",
+      "",
+      "Program: 0,3,5,4,3,0"
+    ]
+
+spec :: Spec
+spec = do
+  describe "part 1" $ do
+    it "examples" $ do
+      step [2, 6] (0, (-1, -1, 9)) `shouldBe` Just (Nothing, (2, (-1, 1, 9)))
+      run [5, 0, 5, 1, 5, 4] (10, -1, -1) `shouldBe` [0, 1, 2]
+      run [0, 1, 5, 4, 3, 0] (2024, -1, -1) `shouldBe` [4, 2, 5, 6, 7, 7, 7, 7, 3, 1, 0]
+      step [1, 7] (0, (-1, 29, -1)) `shouldBe` Just (Nothing, (2, (-1, 26, -1)))
+      step [4, 0] (0, (-1, 2024, 43690)) `shouldBe` Just (Nothing, (2, (-1, 44354, 43690)))
+      part1 example1 `shouldBe` Right [4, 6, 3, 5, 6, 3, 5, 2, 1, 0]
+  describe "part 2" $ do
+    it "examples" $ do
+      part2 example2 `shouldBe` Right 117440