Day 23 was the first cellular automaton type puzzle of the year. Every time these come up, I consider implementing it as a Representable-powered Comonad of elements, and every year I decide that I've neither the time nor the brain capacity to build one. But one year I will!

Representation

My first decision was how to represent things and keep track of the simulation state. Some decisions were simple: the grove was represented sparsely, as a Set of Elfs. Each Elf knew its position and where it was moving to. The Grove overall knew about the elves, and also kept track of the current Directions for elf movement (an infinite, cycling list) and the simulation generation number.

type Position = V2 Int -- r, c

data Direction = North | South | West | East
  deriving (Show, Eq, Ord, Enum, Bounded)

data Elf = Elf { _current :: Position, _proposed :: Position}
  deriving (Eq, Ord)
makeLenses ''Elf  

instance Show Elf where
  show elf = "Elf {c= " ++ (show (elf ^. current)) 
                        ++ ", p= " ++ (show (elf ^. proposed)) 
                        ++ " -> " ++ (show (directionOfElf elf)) 
                        ++ "}"

data Grove = Grove { currentGrove :: S.Set Elf, proposalDirections :: [Direction], elapsedRounds :: Int}
  deriving (Eq)

(I used a custom Show for the Elf, so I could see the direction the elf was proposing to move in. It made checking my code much easier., and used the helper directionOfElf)

directionOfElf :: Elf -> Maybe Direction
directionOfElf elf
  | delta == V2 0 1 = Just North
  | delta == V2 0 -1 = Just South
  | delta == V2 1 0 = Just East
  | delta == V2 -1 0 = Just West
  | otherwise = Nothing
  where delta = (elf ^. proposed) ^-^ (elf ^. current)

I was in two minds as to whether to use a State monad, or just pass around a set of Elves. In the end, I went with the State monad.

type GroveState = State Grove

Simulation

That meant the simulation was clean and looked rather imperative. There are two functions for running the simulation: simulateToCompletion runs the simulation until no elf moves; simulateN simulates n rounds.

simulateToCompletion :: GroveState ()
simulateToCompletion =
  do oldGrove <- gets currentGrove
     simulateOnce
     newGrove <- gets currentGrove
     if oldGrove == newGrove
     then return ()
     else simulateToCompletion

simulateN :: Int -> GroveState ()
simulateN 0 = return ()
simulateN n = 
  do simulateOnce
     simulateN (n - 1)

Note that none of the simulations return a value. I extract what I want from the final state, and run the simulation with execState

part1, part2 :: Grove -> Int
part1 grove = countEmpty grove' bounds
  where grove' = currentGrove $ execState (simulateN 10) grove
        bounds = findBounds grove'

part2 grove = elapsedRounds grove'
  where grove' = execState simulateToCompletion grove

I split each simulation round into five stages:

  1. Each Elf proposes where it wants to move
  2. Elves moving to the same space withdraw their proposed moves
  3. All the elves move to their proposed spaces
  4. Update the movement-direction priority list
  5. Update the number of simulation rounds
simulateOnce =
  do proposeMoves
     removeClashes
     moveElves
     updateDirections
     updateCount

I'll describe the three interesting stages in turn.

Propose moves

The top-level is simple: get the grove (a.k.a. set of elves), get the direction priority list, then ask each elf in the grove to propose where they want to move to.

proposeMoves =
  do grove <- gets currentGrove
     proposalsInf <- gets proposalDirections
     let proposals = take 4 proposalsInf
     let grove' = S.map (makeProposal grove proposals) grove
     modify' (\g -> g { currentGrove = grove'})

makeProposal asks a specific Elf to propose where it will move next. If it's isolated, it stays still. Otherwise, it checks if it can move in any of the four directions, then there's a horrendous bit of plumbing to find the first viable move.

makeProposal :: S.Set Elf -> [Direction] -> Elf -> Elf
makeProposal grove directions elf 
  | isolated grove elf = elf
  | otherwise = fromMaybe elf $ getFirst $ mconcat $ fmap First $ fmap (proposedStep grove elf) directions

proposedStep :: S.Set Elf -> Elf -> Direction -> Maybe Elf
proposedStep grove elf direction
  | noElves grove interfering = Just $ elf & proposed .~ (here ^+^ (stepDelta direction))
  | otherwise = Nothing 
  where here = elf ^. current
        interfering = translateTo here $ directionNeighbour direction

(isolated and noElves are described below.)

proposedStep takes and elf and a direction, and returns a Maybe Elf if the elf could move in that direction (i.e. there are no elves in the "interfering" region).

The plumbing fromMaybe elf $ getFirst $ mconcat $ fmap First $ fmap (proposedStep localElves elf) directions makes use of the First class for monoids. Starting from the end, the fmap  turns the list of directions into a list of Maybe Elfs. The fmap First converts each of these Maybe Elf into a First (Maybe Elf), ready for the mconcat. That combines the elfs into one blob, and getFirst extracts the first non-Nothing element of that blob. If there are no viable moves, getFirst will return Nothing and fromMaybe will return the original Elf.

I hope all that makes sense!

Remove clashes

Removing "clashes" is less complex, but still fiddly. I define a "clash" as when two or more elves are trying to move into the same space.

The basic code is simple enough: find the elves about to clash, then ask them to stay still.

removeClashes =
  do grove <- gets currentGrove
     let clashes = findClashes grove
     stopClashingElves clashes

I find positions of clashes with a MultiSet. First, I put all the proposed next positions into the targets multiset, then create a new MultiSet from targets, keeping only the targets that appear more than once. (I have to use foldOccur to do this as there's no filterWithOccur or similar functions in the library.) Finally, I convert the contested targets into a Set

findClashes :: S.Set Elf -> S.Set Position
findClashes grove = MS.toSet $ MS.foldOccur ifMany MS.empty targets
  where targets = MS.map _proposed $ MS.fromSet grove
        ifMany t n s 
          | n == 1 = s
          | otherwise = MS.insert t s

Then I ask the elves no to clash. That's as a map over the elves, where each one is asked to notClash.

notClash checks if the elf's proposed move is in the set of clashes. If it is, the proposed is reset to current (meaning the elf doesn't move this round). If it's not a clash, the elf remains the same.

stopClashingElves :: S.Set Position -> GroveState ()
stopClashingElves clashes =
  do grove <- gets currentGrove
     let grove' = S.map (notClash clashes) grove
     modify' (\g -> g { currentGrove = grove'})

notClash :: S.Set Position -> Elf -> Elf
notClash clashes elf 
  | (elf ^. proposed) `S.member` clashes = elf & proposed .~ (elf ^. current)
  | otherwise = elf

Move elves

Finally, asking the elves to move is simple. I just update each elf's current position to be the same as its proposed position.

moveElves = 
  do grove <- gets currentGrove
     let grove' = S.map moveElf grove
     modify' (\g -> g { currentGrove = grove'})

moveElf :: Elf -> Elf
moveElf elf = elf & current .~ (elf ^. proposed)

Utility functions

There are quite a few utility functions to support all this.

First are a few direction-processing functions. anyNeighbour returns a set of the eight neighbouring positions of the origin. directionNeighbour does the same, but only the three positions in a certain direction. stepDelta is the position change in a particular direction.

anyNeighbour :: S.Set Position
anyNeighbour = S.fromList [ V2 dx dy 
                          | dx <- [-1, 0, 1]
                          , dy <- [-1, 0, 1]
                          , not ((dx == 0) && (dy == 0))
                          ]

directionNeighbour :: Direction -> S.Set Position
directionNeighbour North = S.filter (\d -> d ^. _y ==  1) anyNeighbour
directionNeighbour South = S.filter (\d -> d ^. _y == -1) anyNeighbour
directionNeighbour West  = S.filter (\d -> d ^. _x == -1) anyNeighbour
directionNeighbour East  = S.filter (\d -> d ^. _x ==  1) anyNeighbour

stepDelta ::Direction -> Position
stepDelta North = V2  0  1
stepDelta South = V2  0 -1
stepDelta West  = V2 -1  0
stepDelta East  = V2  1  0

Those three functions all generate relative positions. translateTo converts them to absolute positions, given a start point.

translateTo :: Position -> S.Set Position -> S.Set Position
translateTo here deltas = S.map (here ^+^) deltas

notElves is a predicate that returns True if there are no elves at any of the specified positions.

noElves :: S.Set Elf -> S.Set Position -> Bool
noElves elves tests = S.null $ S.intersection tests $ S.map _current elves

Profiling and optimisation

This all worked without too much trouble. Unfortunately, it took a very long time to execute, around 18 minutes on my machine to complete the 1000-odd rounds.

This prompted me to pull out the profiler for the first time this Advent of Code. It revealed that about 95% of the runtime was spent in noElves, which meant it was spending all the time performing the set intersection between the few positions and the many elves.

The fix was simple enough. In makeProposal, I cache the elves near the current elf, and use that small neighbourhood to check for the presence of elves.

makeProposal :: S.Set Elf -> [Direction] -> Elf -> Elf
makeProposal grove directions elf 
  | isolated localElves elf = elf
  | otherwise = fromMaybe elf $ getFirst $ mconcat $ fmap First $ fmap (proposedStep localElves elf) directions
  where localElves = nearby grove elf

nearby :: S.Set Elf -> Elf -> S.Set Elf
nearby elves elf = S.filter (\e -> (e ^. current) `S.member` nbrs) elves 
  where nbrs = translateTo (elf ^. current) $ anyNeighbou

That small change was enough to reduce the runtime by two thirds. A six minute runtime is pretty bad, but there weren't any other quick fixes I could see.

I also tried defining custom Eq and Ord implementations for Elf, so that only the current position was checked. That had just about no effect.

Code

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