Day 11

aoc2022.cabal

@@ -27,6 +27,9 @@ library
   exposed-modules:
       Day1
       Day1.Internal
+      Day10
+      Day11
+      Day11.Parser
       Day2
       Day2.Part1
       Day2.Part2
@@ -62,10 +65,13 @@ library
     , containers
     , heredoc
     , hspec
+    , hspec-megaparsec
     , lens
     , matrix
     , megaparsec
+    , mtl
     , parsec
+    , sort
     , split
     , text
     , transformers
@@ -86,10 +92,13 @@ executable aoc2022-exe
     , containers
     , heredoc
     , hspec
+    , hspec-megaparsec
     , lens
     , matrix
     , megaparsec
+    , mtl
     , parsec
+    , sort
     , split
     , text
     , transformers
@@ -100,6 +109,8 @@ test-suite aoc2022-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Day10Spec
+      Day11Spec
       Day1Spec
       Day2Spec
       Day3Spec
@@ -120,10 +131,13 @@ test-suite aoc2022-test
     , containers
     , heredoc
     , hspec
+    , hspec-megaparsec
     , lens
     , matrix
     , megaparsec
+    , mtl
     , parsec
+    , sort
     , split
     , text
     , transformers

package.yaml

@@ -34,6 +34,9 @@ dependencies:
 - vector
 - megaparsec
 - transformers
+- hspec-megaparsec
+- mtl
+- sort
 
 ghc-options:
 - -Wall

ressources/day10-input

@@ -0,0 +1,139 @@
+addx 1
+noop
+noop
+noop
+addx 5
+addx 5
+noop
+noop
+addx 9
+addx -5
+addx 1
+addx 4
+noop
+noop
+noop
+addx 6
+addx -1
+noop
+addx 5
+addx -2
+addx 7
+noop
+addx 3
+addx -2
+addx -38
+noop
+noop
+addx 32
+addx -22
+noop
+addx 2
+addx 3
+noop
+addx 2
+addx -2
+addx 7
+addx -2
+noop
+addx 3
+addx 2
+addx 5
+addx 2
+addx -5
+addx 10
+noop
+addx 3
+noop
+addx -38
+addx 1
+addx 27
+noop
+addx -20
+noop
+addx 2
+addx 27
+noop
+addx -22
+noop
+noop
+noop
+noop
+addx 3
+addx 5
+addx 2
+addx -11
+addx 16
+addx -2
+addx -17
+addx 24
+noop
+noop
+addx 1
+addx -38
+addx 15
+addx 10
+addx -15
+noop
+addx 2
+addx 26
+noop
+addx -21
+addx 19
+addx -33
+addx 19
+noop
+addx -6
+addx 9
+addx 3
+addx 4
+addx -21
+addx 4
+addx 20
+noop
+addx 3
+addx -38
+addx 28
+addx -21
+addx 9
+addx -8
+addx 2
+addx 5
+addx 2
+addx -9
+addx 14
+addx -2
+addx -5
+addx 12
+addx 3
+addx -2
+addx 2
+addx 7
+noop
+noop
+addx -27
+addx 28
+addx -36
+noop
+addx 1
+addx 5
+addx -1
+noop
+addx 6
+addx -1
+addx 5
+addx 5
+noop
+noop
+addx -2
+addx 20
+addx -10
+addx -3
+addx 1
+addx 3
+addx 2
+addx 4
+addx 3
+noop
+addx -30
+noop

ressources/day11-input

@@ -0,0 +1,55 @@
+Monkey 0:
+  Starting items: 52, 78, 79, 63, 51, 94
+  Operation: new = old * 13
+  Test: divisible by 5
+    If true: throw to monkey 1
+    If false: throw to monkey 6
+
+Monkey 1:
+  Starting items: 77, 94, 70, 83, 53
+  Operation: new = old + 3
+  Test: divisible by 7
+    If true: throw to monkey 5
+    If false: throw to monkey 3
+
+Monkey 2:
+  Starting items: 98, 50, 76
+  Operation: new = old * old
+  Test: divisible by 13
+    If true: throw to monkey 0
+    If false: throw to monkey 6
+
+Monkey 3:
+  Starting items: 92, 91, 61, 75, 99, 63, 84, 69
+  Operation: new = old + 5
+  Test: divisible by 11
+    If true: throw to monkey 5
+    If false: throw to monkey 7
+
+Monkey 4:
+  Starting items: 51, 53, 83, 52
+  Operation: new = old + 7
+  Test: divisible by 3
+    If true: throw to monkey 2
+    If false: throw to monkey 0
+
+Monkey 5:
+  Starting items: 76, 76
+  Operation: new = old + 4
+  Test: divisible by 2
+    If true: throw to monkey 4
+    If false: throw to monkey 7
+
+Monkey 6:
+  Starting items: 75, 59, 93, 69, 76, 96, 65
+  Operation: new = old * 19
+  Test: divisible by 17
+    If true: throw to monkey 1
+    If false: throw to monkey 3
+
+Monkey 7:
+  Starting items: 89
+  Operation: new = old + 2
+  Test: divisible by 19
+    If true: throw to monkey 2
+    If false: throw to monkey 4

src/Day10.hs

@@ -0,0 +1,76 @@
+module Day10
+  ( Instruction (..),
+    parseProgram,
+    signalStrength,
+    executeProgram,
+    draw,
+    isSpriteDrawn,
+    day10
+  )
+where
+
+import Control.Arrow ((>>>))
+import Data.List.Split (chunksOf)
+
+data Instruction = Addx Int | Noop
+  deriving (Show, Eq)
+
+newtype Pixel = Pixel Bool deriving (Eq)
+
+instance Show Pixel where
+  show (Pixel True) = "▓"
+  show (Pixel False) = "░"
+
+
+type CRT = String
+
+parseProgram :: String -> [Instruction]
+parseProgram = lines >>> map parseProgram'
+  where
+    parseProgram' :: String -> Instruction
+    parseProgram' "noop" = Noop
+    parseProgram' line = splitAt 4 >>> snd >>> read >>> Addx $ line
+
+
+isSpriteDrawn :: Int -> Int -> Bool
+isSpriteDrawn x p = abs (position - x) <= 1
+  where
+    position = p `mod` 40
+
+draw :: [Int] -> CRT
+draw registerValues = unlines lastPicture
+  where
+    pictures = zipWith isSpriteDrawn registerValues [0..]
+    lastPicture = concatMap (show . Pixel) >>> chunksOf 40 $ pictures
+
+
+
+signalStrength :: [Int] -> Int
+signalStrength e = start + sum computedRest
+  where
+    start = e !! 20 * 20
+    rest = drop 20 e
+    withCycle = zip [60, 100..] (every 40 rest)
+    computedRest = [c*r | (c,r) <- withCycle]
+
+every :: Int -> [a] -> [a]
+every n xs = case drop (n-1) xs of
+              y : ys -> y : every n ys
+              [] -> []
+
+executeProgram :: [Instruction] -> [Int]
+executeProgram = scanl (+) 1 . concatMap execOne
+  where
+    execOne instruction = case instruction of
+        Noop   -> [0]
+        Addx x -> [0, x]
+
+day10 :: IO ()
+day10 = do
+  input <- readFile "ressources/day10-input"
+  putStrLn "Day10"
+  let states = parseProgram >>> executeProgram $ input
+  let signal = signalStrength states
+  let crt = draw states
+  putStrLn ("Signal strength: " ++ show signal)
+  putStrLn ("CRT picture: \n" ++ crt)

src/Day11.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Day11
+  ( runMonkeyMachine,
+    mostActiveMonkeys,
+    monkeyBusiness,
+    day11,
+    runPart1Machine,
+    runPart2Machine,
+    worryLimit,
+    divideBy3,
+  )
+where
+
+import Control.Monad.State.Strict (execState, get, modify', put)
+import qualified Control.Monad.State.Strict as St
+import Data.Foldable (forM_, toList)
+import Data.List (sortOn)
+import Data.Ord (Down (..))
+import Data.Sequence ((|>))
+import qualified Data.Sequence as S
+import Data.Text (pack)
+import Day11.Parser
+
+day11 :: IO ()
+day11 = do
+  input <- readFile "ressources/day11-input"
+  putStrLn "Day11"
+  let monkeys = (monkeyBusiness . mostActiveMonkeys . runPart1Machine . parseMonkeys) (pack input)
+  putStrLn ("Part 1 monkey business: " ++ show monkeys)
+  let monkeys' = (monkeyBusiness . mostActiveMonkeys . runPart2Machine . parseMonkeys) (pack input)
+  putStrLn ("Part 2 monkey business: " ++ show monkeys')
+
+type MonkeyState = St.State (S.Seq Monkey)
+
+runPart1Machine :: [Monkey] -> [Monkey]
+runPart1Machine = runMonkeyMachine divideBy3 20
+
+runPart2Machine :: [Monkey] -> [Monkey]
+runPart2Machine monkeys = runMonkeyMachine (worryLimit monkeys) 10000 monkeys
+
+worryLimit :: [Monkey] -> WorryReducer
+worryLimit monkeys = (`mod` limit)
+  where
+    limit = product $ map _test monkeys
+
+    
+runMonkeyMachine :: WorryReducer -> Int -> [Monkey] -> [Monkey]
+runMonkeyMachine eval i monkeys = toList (infiniteMachine !! i)
+  where
+    infiniteMachine = iterate go $ S.fromList monkeys
+    go :: S.Seq Monkey -> S.Seq Monkey
+    go m = execState go' m
+    go' :: MonkeyState ()
+    go' = mapM_ (doMonkey eval) [0 .. length monkeys - 1]
+
+mostActiveMonkeys :: [Monkey] -> [Monkey]
+mostActiveMonkeys = take 2 . sortOn (Down . _inspectionCount)
+
+monkeyBusiness :: [Monkey] -> Int
+monkeyBusiness = product . map _inspectionCount
+
+-- update a sequence of monkeys according to the moves of the monkey at position idx
+doMonkey :: WorryReducer -> Int -> MonkeyState ()
+doMonkey reducer idx = do
+  horde <- get
+  let m = horde `S.index` idx
+  let targets = fmap (evalMonkey reducer m) (_items m)
+  let m' = m {_items = S.empty, _inspectionCount = _inspectionCount m + S.length (_items m)}
+  put $ S.update idx m' horde
+  forM_ targets $ \movement ->
+    modify' (move movement)
+
+-- update other monkeys according to a list of calculated moves
+move :: (Int, Int) -> S.Seq Monkey -> S.Seq Monkey
+move (to, item) horde
+  | item < 0 = error ("Item worry level overflow: " ++ show (to, item))
+  | otherwise =
+    let m = horde `S.index` to
+        m' = m {_items = _items m |> item}
+     in S.update to m' horde
+
+type WorryReducer = Int -> Int
+
+divideBy3 :: WorryReducer
+divideBy3 = flip div 3
+
+evalMonkey :: WorryReducer -> Monkey -> Int -> (Int, Int)
+evalMonkey reducer monkey item = (target, newLevel)
+  where
+    afterOp = case _operation monkey of
+      Add Old -> item * 2
+      Add (Fixed x) -> item + x
+      Multiply Old -> item * item
+      Multiply (Fixed x) -> item * x
+    newLevel = reducer afterOp
+    isDivisible = newLevel `mod` _test monkey == 0
+    target =
+      if isDivisible
+        then _ifDivisible monkey
+        else _otherwise monkey

src/Day11/Parser.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day11.Parser (
+  parseMonkeys,
+  Monkey (..),
+  Operation (..),
+  Op (..),
+)
+ where
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Data.Text (Text)
+import Data.Void (Void)
+import Control.Monad (void)
+import qualified Data.Sequence as S
+
+type Parser = Parsec Void Text
+
+data Op = Fixed Int | Old
+  deriving (Show, Eq)
+
+data Operation = Add Op | Multiply Op
+  deriving (Show, Eq)
+
+data Monkey = Monkey
+  { _nr :: Int
+  , _items :: S.Seq Int
+  , _operation :: Operation
+  , _test :: Int
+  , _ifDivisible :: Int
+  , _otherwise :: Int
+  , _inspectionCount :: Int }
+  deriving (Show, Eq)
+
+parseMonkeys :: Text -> [Monkey]
+parseMonkeys input = case parse (monkey `sepBy` void eol) "" input of
+  Left err -> error (show err)
+  Right result -> result
+
+monkey :: Parser Monkey
+monkey = do
+  void (string "Monkey ")
+  nr <- many numberChar
+  void (char ':')
+  void eol
+  startingItems <- items
+  operation <- op
+  d <- divisor
+  ifDiv <- ifDivisible
+  ifOther <- ifOtherwise
+  return Monkey
+   { _nr=read nr
+   , _items=S.fromList startingItems
+   , _operation=operation
+   , _test=d
+   , _ifDivisible=ifDiv
+   , _otherwise=ifOther
+   , _inspectionCount=0 }
+
+ifDivisible :: Parser Int
+ifDivisible = do
+  x <- read <$> (string "    If true: throw to monkey " >> many numberChar)
+  void eol
+  return x
+
+ifOtherwise :: Parser Int
+ifOtherwise = do
+  x <- read <$> (string "    If false: throw to monkey " >> many numberChar)
+  void eol
+  return x
+
+divisor :: Parser Int
+divisor = do
+  d <- read <$> (string "  Test: divisible by " >> many numberChar)
+  void eol
+  return d
+
+items :: Parser [Int]
+items = do
+  void (string "  Starting items: ")
+  startingItems <- sepBy1 (many numberChar) (string ", ")
+  void eol
+  return (map read startingItems)
+
+op :: Parser Operation
+op = do
+  o <- void (string "  Operation: new = old ") >> addOp <|> mulOp
+  void eol
+  return o
+  where
+    old = string "old" >> return Old
+    num = Fixed . read <$> many numberChar
+    addOp = do
+      void (string "+ ")
+      Add <$> (old <|> num)
+    mulOp = do
+      void (string "* ")
+      Multiply <$> (old <|> num)

src/Lib.hs

@@ -11,9 +11,11 @@ import Day6 (day6)
 import Day7 (day7)
 import Day8 (day8)
 import Day9 (day9)
+import Day10 (day10)
+import Day11 (day11)
 
 days :: [IO ()]
-days = [day1, day2, day3, day4, day5, day6, day7, day8, day9]
+days = [day1, day2, day3, day4, day5, day6, day7, day8, day9, day10, day11]
 
 sep :: IO ()
 sep = putStrLn "---------"

test/Day10Spec.hs

@@ -0,0 +1,193 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Day10Spec (spec) where
+
+import Control.Arrow ((>>>))
+import Day10
+import Test.Hspec
+import Text.Heredoc
+
+testInput :: String
+testInput = [str|noop
+                |addx 3
+                |addx -5
+                |]
+
+testProgram :: [Instruction]
+testProgram = [Noop, Addx 3, Addx (-5)]
+
+testInput2 :: String
+testInput2 = [str|addx 15
+                 |addx -11
+                 |addx 6
+                 |addx -3
+                 |addx 5
+                 |addx -1
+                 |addx -8
+                 |addx 13
+                 |addx 4
+                 |noop
+                 |addx -1
+                 |addx 5
+                 |addx -1
+                 |addx 5
+                 |addx -1
+                 |addx 5
+                 |addx -1
+                 |addx 5
+                 |addx -1
+                 |addx -35
+                 |addx 1
+                 |addx 24
+                 |addx -19
+                 |addx 1
+                 |addx 16
+                 |addx -11
+                 |noop
+                 |noop
+                 |addx 21
+                 |addx -15
+                 |noop
+                 |noop
+                 |addx -3
+                 |addx 9
+                 |addx 1
+                 |addx -3
+                 |addx 8
+                 |addx 1
+                 |addx 5
+                 |noop
+                 |noop
+                 |noop
+                 |noop
+                 |noop
+                 |addx -36
+                 |noop
+                 |addx 1
+                 |addx 7
+                 |noop
+                 |noop
+                 |noop
+                 |addx 2
+                 |addx 6
+                 |noop
+                 |noop
+                 |noop
+                 |noop
+                 |noop
+                 |addx 1
+                 |noop
+                 |noop
+                 |addx 7
+                 |addx 1
+                 |noop
+                 |addx -13
+                 |addx 13
+                 |addx 7
+                 |noop
+                 |addx 1
+                 |addx -33
+                 |noop
+                 |noop
+                 |noop
+                 |addx 2
+                 |noop
+                 |noop
+                 |noop
+                 |addx 8
+                 |noop
+                 |addx -1
+                 |addx 2
+                 |addx 1
+                 |noop
+                 |addx 17
+                 |addx -9
+                 |addx 1
+                 |addx 1
+                 |addx -3
+                 |addx 11
+                 |noop
+                 |noop
+                 |addx 1
+                 |noop
+                 |addx 1
+                 |noop
+                 |noop
+                 |addx -13
+                 |addx -19
+                 |addx 1
+                 |addx 3
+                 |addx 26
+                 |addx -30
+                 |addx 12
+                 |addx -1
+                 |addx 3
+                 |addx 1
+                 |noop
+                 |noop
+                 |noop
+                 |addx -9
+                 |addx 18
+                 |addx 1
+                 |addx 2
+                 |noop
+                 |noop
+                 |addx 9
+                 |noop
+                 |noop
+                 |noop
+                 |addx -1
+                 |addx 2
+                 |addx -37
+                 |addx 1
+                 |addx 3
+                 |noop
+                 |addx 15
+                 |addx -21
+                 |addx 22
+                 |addx -6
+                 |addx 1
+                 |noop
+                 |addx 2
+                 |addx 1
+                 |noop
+                 |addx -10
+                 |noop
+                 |noop
+                 |addx 20
+                 |addx 1
+                 |addx 2
+                 |addx 2
+                 |addx -6
+                 |addx -11
+                 |noop
+                 |noop
+                 |noop
+                |]
+
+spec :: Spec
+spec =
+  describe "Day10" $ do
+    describe "Part1" $ do
+      it "parses" $ do
+        parseProgram testInput `shouldBe` testProgram
+      it "executes" $ do
+        executeProgram testProgram `shouldBe` [1,1,1,4,4,-1]
+      it "executes larger program" $ do
+        let registerValues = parseProgram >>> executeProgram $ testInput2
+        registerValues !! 20 `shouldBe` 21
+        registerValues !! 60 `shouldBe` 19
+        registerValues !! 100 `shouldBe` 18
+        registerValues !! 140 `shouldBe` 21
+        registerValues !! 180 `shouldBe` 16
+        registerValues !! 220 `shouldBe` 18
+      it "computes signal strength" $ do
+        let registerValues = parseProgram >>> executeProgram $ testInput2
+        signalStrength registerValues `shouldBe` 13140
+      it "prints a crt" $ do
+        let registerValues = parseProgram >>> executeProgram $ testInput2
+        putStrLn $ draw registerValues
+      it "sprites drawn" $ do
+        isSpriteDrawn 1 1 `shouldBe` True
+        isSpriteDrawn 1 1 `shouldBe` True
+

test/Day11Spec.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Day11Spec (spec) where
+
+import Data.Foldable (toList)
+import qualified Data.Sequence as S
+import Data.Text (Text)
+import Day11
+import Day11.Parser
+import Test.Hspec
+import Text.Heredoc
+import Data.Int (Int64)
+
+testInput :: Text
+testInput =
+  [str|Monkey 0:
+                |  Starting items: 79, 98
+                |  Operation: new = old * 19
+                |  Test: divisible by 23
+                |    If true: throw to monkey 2
+                |    If false: throw to monkey 3
+                |
+                |Monkey 1:
+                |  Starting items: 54, 65, 75, 74
+                |  Operation: new = old + 6
+                |  Test: divisible by 19
+                |    If true: throw to monkey 2
+                |    If false: throw to monkey 0
+                |
+                |Monkey 2:
+                |  Starting items: 79, 60, 97
+                |  Operation: new = old * old
+                |  Test: divisible by 13
+                |    If true: throw to monkey 1
+                |    If false: throw to monkey 3
+                |
+                |Monkey 3:
+                |  Starting items: 74
+                |  Operation: new = old + 3
+                |  Test: divisible by 17
+                |    If true: throw to monkey 0
+                |    If false: throw to monkey 1
+                |]
+
+exampleMonkeys :: [Monkey]
+exampleMonkeys = parseMonkeys testInput
+
+spec :: Spec
+spec =
+  describe "Day11" $ do
+    describe "Part1" $ do
+      it "parses" $ do
+        head exampleMonkeys `shouldBe` Monkey 0 (S.fromList [79, 98]) (Multiply (Fixed 19)) 23 2 3 0
+        _items (exampleMonkeys !! 1) `shouldBe` S.fromList [54, 65, 75, 74]
+      it "runs part 1 monkey machine for 20 rounds" $ do
+        let monkeys = runMonkeyMachine divideBy3 20 exampleMonkeys
+        map _inspectionCount monkeys
+          `shouldBe` [101, 95, 7, 105]
+        map _inspectionCount (mostActiveMonkeys monkeys) `shouldBe` [105, 101]
+        map _nr (mostActiveMonkeys monkeys) `shouldBe` [3, 0]
+        monkeyBusiness (mostActiveMonkeys monkeys) `shouldBe` 10605
+
+      it "runs part 2 monkey machine for 10000 rounds" $ do
+        let monkeys = runMonkeyMachine (worryLimit exampleMonkeys) 10000 exampleMonkeys
+        map _inspectionCount monkeys
+          `shouldBe` [52166, 47830, 1938, 52013]
+        monkeyBusiness (mostActiveMonkeys monkeys) `shouldBe` 2713310158