Day 21 was something we've not fully seen before this year: the evaluation of expressions. It also gave me an excuse to experiment with the index lens operations like at. I'm not sure they added much to this example.

Data structures

The data was a pretty direct translation from the problem: a monkey can Shout a number, or shout some combination of other monkeys' shouts. The group of monkeys is represented as a Map from monkey name to Shout.

Parsing the monkeys is long, to account for the nested structures and options.

data Shout = Literal Int | Operation Operator String String
  deriving (Show, Eq, Ord)

data Operator = Plus | Minus | Times | Divide 
  deriving (Show, Eq, Ord)

type Monkeys = M.Map String Shout

fromLiteral :: Shout -> Int
fromLiteral (Literal n) = n
fromLiteral _ = error "fromLiteral"

monkeysP = M.fromList <$> monkeyP `sepBy` endOfLine
monkeyP = (,) <$> (nameP <* ": ") <*> shoutP
shoutP = numberP <|> operationP
numberP = Literal <$> decimal
operationP = opify <$> nameP <*> operatorP <*> nameP
  where opify l o r = Operation o l r
nameP = many1 letter
operatorP = plusP <|> minusP <|> timesP <|> divideP
plusP = Plus   <$ " + "
minusP = Minus  <$ " - "
timesP = Times  <$ " * "
divideP = Divide <$ " / "

Evaluating monkeys

The basic idea is to split the monkeys into two groups: those that can shout a literal number, and those that need to work out what to say (called values and operations below).

splitMonkeys :: Monkeys -> (Monkeys, Monkeys)
splitMonkeys = M.partition f
  where f (Literal _) = True
        f (Operation _ _ _) = False

Then, I can go through all the monkeys with operations and, one by one, check if all the monkeys they need are ones with values. If this monkey can now shout a number, I add that monkey/number to the the values and remove it from the operations. If not, that monkey is added to a new set of pending operations.

evaluateMonkeys :: Monkeys -> Monkeys -> (Monkeys, Monkeys)
evaluateMonkeys values operations = M.foldlWithKey' f ((values, M.empty)) operations
  where f (valMs, opMs) name op = 
          case (evalShout valMs op) of
            Nothing -> (valMs, opMs & at name ?~ op)
            Just v -> (valMs & at name ?~ v, sans name opMs)

I use Applicatives to find the value of a Shout, returning Nothing if the monkey can't shout yet, or Just (Literal n) if it can shout a number.

evalShout :: Monkeys -> Shout -> Maybe Shout
evalShout _ (Literal n) = Just $ Literal n
evalShout values (Operation op l r) = apply <$> (Just op) <*> lval <*> rval
  where lval = M.lookup l values
        rval = M.lookup r values

apply :: Operator -> Shout -> Shout -> Shout
apply Plus (Literal l) (Literal r) = Literal (l + r)
apply Minus (Literal l) (Literal r) = Literal (l - r)
apply Times (Literal l) (Literal r) = Literal (l * r)
apply Divide (Literal l) (Literal r) = Literal (l `div` r)
apply _ _ _ = error "Illegal apply"

I find the value of "root" by repeating evaluateMonkeys until "root" has a value. (There may be a few monkeys that will never shout a value: I don't know, I didn't check.)

findRoot :: Monkeys -> Monkeys -> Shout
findRoot values operations 
  | "root" `M.member` values = values ! "root"
  | otherwise = findRoot values' operations'
  where (values', operations') = evaluateMonkeys values operations
  
part1 :: Monkeys -> Int
part1 monkeys = fromLiteral $ findRoot values operations
  where (values, operations) = splitMonkeys monkeys

Finding what to shout

For part 2, I changed the operation of "root" to be Minus. If the two operands were equal, "root" would shout zero. I then had to find a value to make that true, using non-zero values as clues.

A bit of poking around, using the trial function, showed that small values of "humn" gave large values of "root", and increasing the values of "humn" gave smaller values of "root". I hard-coded that behaviour into the search (meaning that my code doesn't work on the example).

trial :: Monkeys -> Monkeys -> Int -> Shout
trial values operations humn = findRoot (values & at "humn" ?~ (Literal humn)) operations

First was to find a range of values of "humn" to search. I started at 1 and kept doubling it until "root" changed from positive to negative.

findRange :: Monkeys -> Monkeys -> Int -> (Int, Int)
findRange values operations prev 
  | res > 0 = findRange values operations (prev * 2)
  | otherwise = (prev, prev * 2)
  where res = fromLiteral $ trial values operations (prev * 2)

Given a range of values where the value of "root" changed from positive to negative, I then used a binary search to find the value of "humn" that gave zero for "root".

part2 monkeys = binarySearch values operations l u
  where (Operation _ rootL rootR) = monkeys ! "root"
        monkeys' = monkeys & at "root" ?~ (Operation Minus rootL rootR)
        (values, operations) = splitMonkeys monkeys'
        (l, u) = findRange values operations 1

binarySearch :: Monkeys -> Monkeys -> Int -> Int -> Int
binarySearch values operations lower upper 
  | lower > upper = error "Failed search"
  | result == 0 = probe
  | result > 0 = binarySearch values operations (probe + 1) upper
  | result < 0 = binarySearch values operations lower probe
  where probe = ((upper - lower) `div` 2) + lower
        result = fromLiteral $ trial values operations probe

Code

You can get the code from my locally-hosted Git repo, or from Gitlab.