Day 21 wasn't too bad in theory, but a couple of annoying bugs made it took longer than it should. I thought I'd talk about both the solution and a quick look at debugging Haskell.

Part 1

The first question for me was how to represent a game state and a game as a whole. I considered using a State monad, but the part 1 puzzle was very similar to day 14 and day 17, in that an iterate over a step-update function would be enough to produce the answer. That suggested that a direct representation of the game would be enough for the moment. (I use a custom Show instance for compactness).

data Player = Player1 | Player2 deriving (Eq, Ord, Show)

data PlayerState = PlayerState 
  { position :: Int
  , score :: Int
  } deriving (Eq, Ord, Show)

data Game = Game 
  { players :: M.Map Player PlayerState
  , current :: Player
  , rolls :: Int
  } deriving (Eq, Ord)

instance Show Game where
  show game = "{" ++ (showPlayer Player1) ++ (showActive) ++ (showPlayer Player2) ++ "}"
    where showPlayer p = (show $ position $ (players game) ! p) ++ "," ++ (show $ score $ (players game) ! p) 
          showActive = if (current game) == Player1 then "<" else ">"

I guessed that part 2 of the problem would change the dice generation function, so I made the dice stream an input into the game simulation. That changed the iteration function from iterate to scanl'.

part1 game = scoreGame finalGame
  where finalGame = head $ dropWhile (not . finished 1000) $ scanl' gameStep game detDice
        detDice = map (\n -> sum ([d `mod1` 100 | d <- [n..(n+2)]]::[Int])) [1, 4..]

I also created a couple of utility functions. mod1 is like mod, but keeps a number in the range [1, n] rather than [0, n-1].

finished :: Int -> Game -> Bool
finished threshold game = any (>= threshold) $ map score $ M.elems (players game)

scoreGame :: Game -> Int
scoreGame game = (rolls game) * losingScore
  where losingScore = minimum $ map score $ M.elems (players game)

nextPlayer :: Player -> Player
nextPlayer Player1 = Player2
nextPlayer Player2 = Player1

mod1 :: Int -> Int -> Int
mod1 a b = ((a - 1) `mod` b) + 1

The gameStep function directly implements the rules of the game, as specified.

gameStep :: Game -> Int -> Game
gameStep game theseRolls = game'
  where activePlayer = (players game) ! (current game)
        pos = position activePlayer
        sc = score activePlayer
        pos' = (pos + theseRolls) `mod1` 10
        sc' = sc + pos'
        activePlayer' = PlayerState {position = pos', score = sc'}
        current' = nextPlayer (current game)
        players' = M.insert (current game) activePlayer' (players game)
        game' = Game { players = players'
                     , current = current'
                     , rolls = rolls game + 3
                     }

Part 2

For part 2, I had to count all the possible histories that led to every finishing move. I decided to do that by maintaining a multiset of games, where each element of the multiset counted the number of histories that led to it. For example, this generates the set of dice rolls.

type Games = MS.MultiSet Game
type Dice = MS.MultiSet Int
type Winners = MS.MultiSet Player

diracDice :: Dice
diracDice = MS.fromList [a + b + c | a <- [1..3], b <- [1..3], c <- [1..3]]

Imperatively, the simulation algorithm is:

For each ongoing game:
For each dice roll:
Update this game with this dice roll
Record the number of histories as (number of games) × (number of dice rolls)

In a more functional style, both these loops are folds: combining a collection of items (each game, each dice roll) into a single value (the new multiset of histories).  nonDetGameStep and nonDetGameStep1 represent the two loops above, while nonDetGameStep2 does the update within the inner loop. The new set of histories being built up is held in an accumulator, called acc. nonDetGameSimulation stops simulating when there are no longer any possible games, and also handles extracting the counts of winners.

nonDetGameSimulation :: Int -> Games -> Dice -> Winners -> Winners
nonDetGameSimulation winThreshold games0 dice winners0 
  | MS.null games0 = winners0
  | otherwise = nonDetGameSimulation winThreshold games dice winners
  where games' = nonDetGameStep games0 dice
        (winGames, games) = MS.partition (finished winThreshold) games'
        p1Wins = MS.size $ MS.filter (\g -> current g == Player2) winGames
        p2Wins = MS.size $ MS.filter (\g -> current g == Player1) winGames
        winners = MS.insertMany Player2 p2Wins $ MS.insertMany Player1 p1Wins winners0

nonDetGameStep :: Games -> Dice -> Games
nonDetGameStep games dice = MS.foldOccur (nonDetGameStep1 dice) MS.empty games

nonDetGameStep1 :: Dice -> Game -> MS.Occur -> Games -> Games
nonDetGameStep1 dice game gnum acc = MS.foldOccur (nonDetGameStep2 game gnum) acc dice

nonDetGameStep2 :: Game -> MS.Occur -> Int -> MS.Occur -> Games -> Games
nonDetGameStep2 game gnum roll dnum acc = MS.insertMany game' (gnum * dnum) acc
  where game' = gameStep game roll

This was the correct approach, but a couple of typos meant it didn't work at first, giving much lower values than in the problem description.

Debugging

A problem with debugging Haskell is getting access to all the current values in a running program. The usual imperative approach, of littering code with print statements, doesn't work when code is outside the IO monad.

The Debug.Trace.trace function provides much the same effect, and that was all I needed for this problem.

The first problem was threading the accumulator through the folds. My original version of nonDetGameStep1 read as:

nonDetGameStep1 dice game gnum acc = MS.foldOccur (nonDetGameStep2 game gnum) MS.empty dice

which meant that nonDetGameStep2 only ran once for each call of nonDetGameSimulation. That was because Haskell was bright enough to realise that only the last-visited member of games would contribute to the new history, as the accumulator was reset to MS.empty each previous step.

With that solved, I got a much better answer bit it was still too small. A comparison with another solution on the solutions megathread revealed that my code wasn't including the last generation of game histories. That was caused by a typo in nonDetGameSimulation:

nonDetGameSimulation :: Int -> Games -> Dice -> Winners -> Winners
nonDetGameSimulation winThreshold games0 dice winners0 
  
  | MS.null games = winners0         -- <<<< Typo here
  
  | otherwise = nonDetGameSimulation winThreshold games dice winners
  where games' = nonDetGameStep games0 dice
        (winGames, games) = MS.partition (finished winThreshold) games'
        p1Wins = MS.size $ MS.filter (\g -> current g == Player2) winGames
        p2Wins = MS.size $ MS.filter (\g -> current g == Player1) winGames
        winners = MS.insertMany Player2 p2Wins $ MS.insertMany Player1 p1Wins winners0

The typo terminated the simulation when the next generation had no more games.

Fixing both of those gave the correct solution!

Code

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