Advent of Code 2022 day 23

    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!


    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


    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
         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

    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' = (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 = _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' = (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' = 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 = (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 $ _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.


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

    Neil Smith

    Read more posts by this author.