Merge pull request #173 from ephemient/hs/cleanup

hs/src/Day17.hs

@@ -3,49 +3,51 @@
 -- |
 -- Module:         Day17
 -- Description:    <https://adventofcode.com/2024/day/17 Day 17: Chronospatial Computer>
-module Day17 (part1, part2, run, step) where
+module Day17 (part1, part2) where
 
-import Data.Bits (shiftR, xor, (.&.))
-import Data.List (isSuffixOf, unfoldr)
-import Data.Maybe (catMaybes)
+import Control.Exception (assert)
+import Data.Bits (Bits, shiftR, xor, (.&.))
+import Data.Char (digitToInt)
+import Data.Functor (void)
+import Data.List (isSuffixOf)
 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 (MonadParsec, ParseErrorBundle, Stream (Token, Tokens), between, oneOf, 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 :: (MonadParsec e s m, IsString (Tokens s), Token s ~ Char, Num a) => m ((a, a, a), [Int])
 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 ','
+  void newline
+  program <- between (string "Program: ") newline $ (digitToInt <$> oneOf ['0' .. '7']) `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)))
+run :: (Bits a, Integral a) => [Int] -> (a, a, a) -> [a]
+run program = run' 0
   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,)
+    run' ip registers@(a, b, c)
+      | ip < 0 || ip >= length program = []
+      | 0 <- instruction = run' ip' (a `shiftR` fromIntegral (combo registers operand), b, c)
+      | 1 <- instruction = run' ip' (a, b `xor` fromIntegral operand, c)
+      | 2 <- instruction = run' ip' (a, combo registers operand .&. 7, c)
+      | 3 <- instruction = run' (if a == 0 then ip + 2 else operand) registers
+      | 4 <- instruction = run' ip' (a, b `xor` c, c)
+      | 5 <- instruction = combo registers operand .&. 7 : run' ip' registers
+      | 6 <- instruction = run' ip' (a, a `shiftR` fromIntegral (combo registers operand), b)
+      | 7 <- instruction = run' ip' (a, b, a `shiftR` fromIntegral (combo registers operand))
+      | otherwise = assert False []
+      where
+        instruction = program !! ip
+        operand = program !! (ip + 1)
+        ip' = ip + 2
+    combo (a, _, _) 4 = a
+    combo (_, b, _) 5 = b
+    combo (_, _, c) 6 = c
+    combo _ operand = fromIntegral operand
 
 part1 :: Text -> Either (ParseErrorBundle Text Void) [Int]
 part1 input = do

hs/src/Day21.hs

@@ -3,6 +3,7 @@
 -- Description:    <https://adventofcode.com/2024/day/21 Day 21: Keypad Conundrum>
 module Day21 (solve) where
 
+import Control.Exception (assert)
 import Data.Array.Unboxed (UArray, listArray, range, (!))
 import Data.Char (digitToInt, isDigit)
 import Data.Function (on)
@@ -33,6 +34,7 @@ luts =
     move (x, y) (0, -1) = (x - 1, y)
     move (x, y) (1, -1) = (x, y - 1)
     move (x, y) (2, -1) = (x + 1, y)
+    move pos _ = assert False pos
 
 solve :: Int -> Text -> Int
 solve depth input = sum [cost (T.unpack line) * T.foldl' accumDigits 0 line | line <- T.lines input]

hs/src/Day6.hs

@@ -1,45 +1,60 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- |
 -- Module:         Day6
 -- Description:    <https://adventofcode.com/2024/day/6 Day 6: Guard Gallivant>
 module Day6 (part1, part2) where
 
 import Control.Monad (ap)
-import Control.Parallel.Strategies (parMap, rseq)
+import Control.Parallel.Strategies (parList, rseq, withStrategy)
 import Data.Containers.ListUtils (nubOrd)
 import Data.List ((\\))
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Maybe (catMaybes, isJust)
-import Data.Set qualified as Set (empty, insert, member)
+import Data.Semigroup (Max (Max), sconcat)
+import Data.Set (Set)
+import Data.Set qualified as Set (empty, insert, member, singleton)
 import Data.Text (Text)
-import Data.Text qualified as T (concat, drop, index, length, lines, take, unpack)
+import Data.Text qualified as T (lines, unpack)
+
+parse :: Text -> ((Int, Int), Set (Int, Int), [(Int, Int)])
+parse input = ((maxY, maxX), blocks, start)
+  where
+    (Max maxY, Max maxX, (blocks, start)) =
+      sconcat $
+        (Max 0, Max 0, mempty)
+          :| [ ( Max y,
+                 Max x,
+                 case char of
+                   '^' -> (mempty, [(y, x)])
+                   '#' -> (Set.singleton (y, x), mempty)
+                   _ -> mempty
+               )
+             | (y, line) <- zip [0 ..] $ T.lines input,
+               (x, char) <- zip [0 ..] $ T.unpack line
+             ]
 
-visited :: [Text] -> (Int, Int) -> [((Int, Int), (Int, Int))]
-visited g pos0 = catMaybes $ takeWhile isJust $ iterate (>>= step) $ Just (pos0, (-1, 0))
+visited :: (Int, Int) -> Set (Int, Int) -> (Int, Int) -> [((Int, Int), (Int, Int))]
+visited (maxY, maxX) blocks start = catMaybes $ takeWhile isJust $ iterate (>>= step) $ Just (start, (-1, 0))
   where
     step (pos@(y, x), d@(dy, dx))
-      | y' < 0 || length g <= y' || x' < 0 || T.length line <= x' = Nothing
-      | line `T.index` x' == '#' = step (pos, (dx, -dy))
+      | y' < 0 || maxY < y' || x' < 0 || maxX < x' = Nothing
+      | (y', x') `Set.member` blocks = step (pos, (dx, -dy))
       | otherwise = Just ((y', x'), d)
       where
         y' = y + dy
         x' = x + dx
-        line = g !! y'
 
 part1 :: Text -> Int
-part1 input = length $ nubOrd $ fst <$> visited g pos0
+part1 input = length $ nubOrd $ map fst $ start >>= visited maxes blocks
   where
-    g = T.lines input
-    [pos0] = [(y, x) | (y, line) <- zip [0 ..] g, (x, '^') <- zip [0 ..] $ T.unpack line]
+    (maxes, blocks, start) = parse input
 
 part2 :: Text -> Int
 part2 input =
-  length . filter id . parMap rseq isLoop $
-    [ above ++ T.concat [T.take x line, "#", T.drop (x + 1) line] : below
-    | (y, x) <- nubOrd (fst <$> visited g pos0) \\ [pos0],
-      let (above, line : below) = splitAt y g
+  length . filter id . withStrategy (parList rseq) $
+    [ isLoop (Set.insert add blocks) pos0
+    | pos0 <- start,
+      add <- nubOrd (fst <$> visited maxes blocks pos0) \\ [pos0]
     ]
   where
-    g = T.lines input
-    [pos0] = [(y, x) | (y, line) <- zip [0 ..] g, (x, '^') <- zip [0 ..] $ T.unpack line]
-    isLoop g' = any (uncurry Set.member) $ zip `ap` scanl (flip Set.insert) Set.empty $ visited g' pos0
+    (maxes, blocks, start) = parse input
+    isLoop blocks' pos0 = any (uncurry Set.member) $ zip `ap` scanl (flip Set.insert) Set.empty $ visited maxes blocks' pos0

hs/test/Day17Spec.hs

@@ -4,7 +4,7 @@ module Day17Spec (spec) where
 
 import Data.Text (Text)
 import Data.Text qualified as T (unlines)
-import Day17 (part1, part2, run, step)
+import Day17 (part1, part2)
 import Test.Hspec (Spec, describe, it, shouldBe)
 
 example1, example2 :: Text
@@ -29,11 +29,6 @@ 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