Day 11 - Monkeying Around

Today's problem was definitely the trickiest so far. It was the most complicated input format yet, and the part 2 twist definitely threw a wrench in the works. I also didn't get started until almost midnight, rather than the usual 9pm pacific time, which made things interesting.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Monkeys have stolen our things and are throwing them around playing keep away. Apparently they can tell how worried we are about losing our items, and will throw the items to different monkeys depending on these numbers. Generally, we decide we'll track down the two monkeys who throw the most items.

In part 1, we'll simulate 20 rounds of the monkeys throwing and determine who threw the most items. In part 2 though, we encounter significant scaling problems. Our "worry" value for each item changes each round, often multiplicatively. Part 2 removes a feature that lets us divide the value back down each time. We also run 10000 rounds, so the size of these values will get out of control if we're not careful!

Solution Approach and Insights

Overall, this is a state evolution problem. We run a certain number of steps, and evolve our state each time. Folding mechanics will also play into this.

The key trick for part 2 lies in how we use the "worry" values. What happens each time a monkey inspects an item is that a divisibility check is performed, and the new monkey to get the item depends on the outcome of this check.

But since this is the only use for the worry value, instead of storing the value itself, we'll store a mapping of its modulus with respect to all the divisibility check values.

Parsing the Input

The input is quite intricate. We've taken a lot of "notes" on the monkeys' behavior. So we can parse the "worry" values of the items they start with. But we also note an "operation", which is how much the worry value rises each time that monkey inspects an item.

Finally, there is a "test" for each monkey. It will tell us a number to divide by. If the worry value is divisible by that number, it will throw to the first monkey on the following line. Otherwise, the item is thrown to the monkey on the "false" line.

Here's a sample input:

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

We'll need a MonkeyRule type that tracks the rules for each monkey telling us the operation performed on the worry value, the divisibility check number, and the monkeys we might throw to. From perusing the input files, we can see that the possible operations are 1.) adding a number, 2.) multiplying by a number and 3.) squaring the old number. So capture these in an Operation type.

data MonkeyRule = MonkeyRule
  { mrOperation :: Operation
  , testDivisible :: Int
  , throwTrue :: Int
  , throwFalse :: Int
  } deriving (Show)

data Operation =
  Addx Int |
  Multx Int |
  Square
  deriving (Show)

Now the rules themselves are static, so we can capture those in an Array. But we'll also want to track the sequence of items a monkey has. This will be dynamic, so it will live in a different HashMap structure.

type MonkeyRules = A.Array Int MonkeyRule
type MonkeyItems = HM.HashMap Int (Seq.Seq Int)
type InputType = (MonkeyItems, MonkeyRules)

Now let's parse the input! Essentially, we want one parser for each of the types of lines in our input. These follow the patterns we've generally seen, with string signifiers and then some numbers. Parsing an operation is a little tricky because of the old * old possibility, but alternatives still make this easy.

parseStartingItems :: (MonadLogger m) => ParsecT Void Text m [Int]
parseStartingItems = do
  string "  Starting items: "
  nums <- sepBy1 parsePositiveNumber (string ", ")
  eol
  return nums

parseOperation :: (MonadLogger m) => ParsecT Void Text m Operation
parseOperation = do
  string "  Operation: new = old "
  op <- try addOp <|> try multOp <|> squareOp
  eol
  return op
  where
    addOp = string "+ " >> parsePositiveNumber >>= return . Addx
    multOp = string "* " >> parsePositiveNumber >>= return . Multx
    squareOp = string "* old" >> return Square

parseTest :: (MonadLogger m) => ParsecT Void Text m Int
parseTest = do
  string "  Test: divisible by "
  i <- parsePositiveNumber
  eol
  return i

parseThrow :: (MonadLogger m) => ParsecT Void Text m Int
parseThrow = do
  string "    If "
  string "true" <|> string "false"
  string ": throw to monkey "
  i <- parsePositiveNumber
  eol
  return i

And now we combine all these together to parse a single Monkey. We'll return two tuples - one matching the monkey index to its sequence of items, and another to its rule.

parseMonkey :: (MonadLogger m) => ParsecT Void Text m ((Int, Seq.Seq Int), (Int, MonkeyRule))
parseMonkey = do
  string "Monkey "
  i <- parsePositiveNumber
  char ':'
  eol
  startingNums <- parseStartingItems
  op <- parseOperation
  test <- parseTest
  true <- parseThrow
  false <- parseThrow
  eol
  return ((i, Seq.fromList startingNums), (i, MonkeyRule op test true false))

The index is repeated because this makes it easier for us to construct our final types from the accumulation of monkey notes.

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  monkeys <- some parseMonkey
  let indices = fst . snd <$> monkeys
  return (HM.fromList (fst <$> monkeys), A.array (minimum indices, maximum indices) (snd <$> monkeys))

Getting the Solution

So with each "round", we loop through the monkeys. Each monkey processes all their items. And in processing each item, we update our state, which is the mapping from monkeys to the items they hold. We will play a total of 20 rounds.

With these rules in mind, we can start writing our solution outline. We'll define our state type with the items map, as well as an occurrence map for the number of times a monkey inspects an item (this will help us get our answer).

type StateType = (MonkeyItems, OccMap Int)

initialStateV :: MonkeyItems -> StateType
initialStateV i = (i, emptyOcc)

Now we'll have functions for 1.) running the full round, 2.) processing each monkey and 3.) processing each item.

playRound :: (MonadLogger m) => MonkeyRules -> StateType -> m StateType

playMonkey :: (MonadLogger m) => MonkeyRules -> StateType -> Int -> m StateType

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType

We'll write our solveStateN function, which will call playRound the given number of times, recursing with n - 1 until it reaches 0.

solveStateN :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> m StateType
solveStateN _ 0 st = return st
solveStateN rules n st = do
  st' <- playRound rules st
  solveStateN rules (n - 1) st'

Playing a full round is a simple fold through the monkeys. We use the "rules" array as the source of truth for all the indices we want to loop through, and to make sure we loop through them in order.

-- Play a full round (all monkeys)
playRound :: (MonadLogger m) => MonkeyRules -> StateType -> m StateType
playRound rules st = foldM (playMonkey rules) st (Ix.range (A.bounds rules))

Processing a monkey is also a simple fold loop through the items, with the added part that we set the monkey's own item list to empty after it's done. This spares us the trouble of making two map updates each time we process an item.

-- Process all the items a single monkey has
playMonkey :: (MonadLogger m) => MonkeyRules -> StateType -> Int -> m StateType
playMonkey rules st monkey = do
  (newItems, newOcc) <- foldM (playItem rules monkey) st (fst st HM.! monkey)
  return (HM.insert monkey Seq.empty newItems, newOcc)

Processing one item is where most of the core logic happens. To do the core processing, we first have to think about "applying" an operation. For part 1, this is simple, because our worry values are just Int values.

applyOp :: Operation -> Int -> Int 
applyOp (Addx x) a = x + a
applyOp (Multx x) a = x * a
applyOp Square a = a * a

Now that we can apply the operation to our worry values, we can use the rules correctly. We start by incrementing the counter for the monkey processing the item, and fetching its rule from the array.

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
  ...

Now we update the worry value. First, we apply the operation. Then, just for part 1, we divide it by 3.

playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOp (mrOperation rule) item
      worry2 = worry1 `quot` 3
      ...

Now we perform the throw check to determine which monkey we're throwing to.

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOp (mrOperation rule) item
      worry2 = worry1 `quot` 3
      throwTo = if worry2 `mod` testDivisible rule == 0
                  then throwTrue rule else throwFalse rule
      ...

Finally, we gather the pre-existing items sequence for the new monkey, insert the appended sequence into our state, and then return the updated state.

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOp (mrOperation rule) item
      worry2 = worry1 `quot` 3
      throwTo = if worry2 `mod` testDivisible rule == 0
                  then throwTrue rule else throwFalse rule
      currentThrowToSeq = items HM.! throwTo
      newItems = HM.insert throwTo (currentThrowToSeq Seq.|> worry2) items
  return (newItems, occ2)

This is all our core logic code for part 1. Before we combine everything and get our solution, let's see how the problem changes in part 2.

Part 2

In part 2 we no longer divide by 3, and we run 10000 rounds. This means our worry values will get too big. So instead of treating each item as an Int, we'll track its modulus with respect to all the divisibility check values in the rules, calling this a ModulusHash. Our stateful type will map monkey indices to sequences of this type instead of Int. Here's how we initialize this type given our starting values:

type ModuloHash = HM.HashMap Int Int
type StateType2 = (HM.HashMap Int (Seq.Seq ModuloHash), OccMap Int)

initialStateHard :: (MonkeyItems, MonkeyRules) -> StateType2
initialStateHard (items, rules) = (HM.map (fmap mkModuloHash) items, emptyOcc)
  where
    allDivisibles = testDivisible <$> A.elems rules
    mkModuloHash x = HM.fromList (map (\d -> (d, x `mod` d)) allDivisibles)

Applying an operation now looks a little different. The keys in this map are all the divisors for the different monkeys and their divisibility checks. The values in the map tell us the existing moduluses (moduli?) for each key. If we add a value to the modulus and re-take the modulus, the resulting modulus is the same as if we were just tracking the original number. Same with multiplication. We can use mapWithKeys to capture the idea of modifying each value, but using the key to help with this process.

applyOpHard :: Operation -> ModuloHash -> ModuloHash
applyOpHard (Addx x) modHash = HM.mapWithKey (\k v1 -> (v1 + x) `mod` k) modHash
applyOpHard (Multx x) modHash = HM.mapWithKey (\k v1 -> (v1 * x) `mod` k) modHash
applyOpHard Square modHash = HM.mapWithKey (\k v1 -> (v1 * v1) `mod` k) modHash

The inner parentheses on each line (as in (v1 + x)) are necessary! Otherwise x mod k takes precedence and you'll get the wrong result!

But now we can rewrite playItem to work with this function. It looks very similar, except without division by 3.

playItemHard :: (MonadLogger m) => MonkeyRules -> Int -> StateType2 -> ModuloHash -> m StateType2
playItemHard rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOpHard (mrOperation rule) item
      throwTo = if worry1 HM.! testDivisible rule == 0
                  then throwTrue rule else throwFalse rule
      currentThrowToSeq = items HM.! throwTo
      newItems = HM.insert throwTo (currentThrowToSeq Seq.|> worry1) items
  return (newItems, occ2)

And now I found the perfect way to generalize this idea across part 1 and part 2.

Just kidding.

It was 1:30am at this point so I just copied most of my part 1 code over and tweaked the types a bit.

solveStateNHard :: (MonadLogger m) => MonkeyRules -> Int -> StateType2 -> m StateType2
solveStateNHard _ 0 st = return st
solveStateNHard rules n st = do
  st' <- playRoundHard rules st
  solveStateNHard rules (n - 1) st'

playRoundHard :: (MonadLogger m) => MonkeyRules -> StateType2 -> m StateType2
playRoundHard rules st = foldM (playMonkeyHard rules) st (Ix.range (A.bounds rules))

playMonkeyHard :: (MonadLogger m) => MonkeyRules -> StateType2 -> Int -> m StateType2
playMonkeyHard rules st monkey = do
  (newItems, newOcc) <- foldM (playItemHard rules monkey) st (fst st HM.! monkey)
  return (HM.insert monkey Seq.empty newItems, newOcc)

Answering the Question

At long last we're ready to answer the question. For part 1, we run solveStateN 20 times and take the snd value, which is the occurrence map.

type EasySolutionType = OccMap Int

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (initialItems, rules) = snd <$> solveStateN rules 20 (initialStateV initialItems)

Then we sort its elements, take the highest 2, and multiply them.

findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe Int)
findEasySolution finalOccMap = do
  let results = take 2 . reverse . sort $ M.elems finalOccMap
  return $ Just $ fromIntegral $ product results

Part 2 is similar, but we run 10000 rounds:

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard input@(_, rules) = snd <$> solveStateNHard rules 10000 (initialStateHard input)

And then before multiplying our top 2 values, we use fmap fromIntegral to convert them to Integer values, because the product will go beyond the Word limit.

findHardSolution :: (MonadLogger m) => HardSolutionType -> m (Maybe Integer)
findHardSolution finalOccMap = do
  let results = fmap fromIntegral . take 2 . reverse . sort $ M.elems finalOccMap
  return $ Just $ product results

And now we can combine our pieces!

solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  result <- processInputEasy input
  findEasySolution result

solveHard :: FilePath -> IO (Maybe Integer)
solveHard fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  result <- processInputHard input
  findHardSolution result

Perhaps it was just the result of doing this late at night, but this problem was a definite marathon for me, and there are still 14 days left! So plenty of time for problems to get even harder. At some point next year I'll come back to this problem and clean up the abstraction.

Video

YouTube Link