Day 11

aoc2022.cabal

@@ -28,6 +28,8 @@ library
       Day1
       Day1.Internal
       Day10
+      Day11
+      Day11.Parser
       Day2
       Day2.Part1
       Day2.Part2
@@ -63,10 +65,13 @@ library
     , containers
     , heredoc
     , hspec
+    , hspec-megaparsec
     , lens
     , matrix
     , megaparsec
+    , mtl
     , parsec
+    , sort
     , split
     , text
     , transformers
@@ -87,10 +92,13 @@ executable aoc2022-exe
     , containers
     , heredoc
     , hspec
+    , hspec-megaparsec
     , lens
     , matrix
     , megaparsec
+    , mtl
     , parsec
+    , sort
     , split
     , text
     , transformers
@@ -102,6 +110,7 @@ test-suite aoc2022-test
   main-is: Spec.hs
   other-modules:
       Day10Spec
+      Day11Spec
       Day1Spec
       Day2Spec
       Day3Spec
@@ -122,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/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

@@ -10,10 +10,7 @@ module Day10
 where
 
 import Control.Arrow ((>>>))
-import qualified Data.Matrix as M
-import Debug.Trace (trace)
 import Data.List.Split (chunksOf)
-import Data.List (intercalate)
 
 data Instruction = Addx Int | Noop
   deriving (Show, Eq)

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

@@ -12,9 +12,10 @@ 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, day10]
+days = [day1, day2, day3, day4, day5, day6, day7, day8, day9, day10, day11]
 
 sep :: IO ()
 sep = putStrLn "---------"

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