Advent of Code 2022 - Day 23Unstable Diffusion

| Problem statement | Source code | Tags: Cellular automata

Part 1

Not much to say about this one; it's a straightforward simulation. Like any other cellular automata problem, due to the potentially infinite grid, I represent the map as a Set (Int, Int).

I let the elves each propose a move. If it has no neighbors, it doesn't move. Otherwise, it uses the first valid direction in the current round's order.

canMove :: Set (Int, Int) -> (Int, Int) -> (Int, Int) -> Bool
canMove elves (r, c) (dr, dc) = not $ any (`Set.member` elves) positions
  where
    positions = case (dr, dc) of
      (-1, 0) -> [(r - 1, c - 1), (r - 1, c), (r - 1, c + 1)]
      (1, 0) -> [(r + 1, c - 1), (r + 1, c), (r + 1, c + 1)]
      (0, -1) -> [(r - 1, c - 1), (r, c - 1), (r + 1, c - 1)]
      (0, 1) -> [(r - 1, c + 1), (r, c + 1), (r + 1, c + 1)]
      _ -> error "Invalid direction"

proposeMove :: Set (Int, Int) -> [(Int, Int)] -> (Int, Int) -> (Int, Int)
proposeMove elves directions (r, c) =
  if not hasNeighbor then (r, c) else (r + dr, c + dc)
  where
    hasNeighbor =
      any
        (`Set.member` elves)
        [ (r + dr, c + dc) | dr <- [-1 .. 1], dc <- [-1 .. 1], (dr, dc) /= (0, 0)
        ]
    (dr, dc) = fromMaybe (0, 0) $ find (canMove elves (r, c)) directions

Then, I count the proposed moves and only execute those that are unique (moveCounts is 1), and finally rotate the directions.

moveElves :: (Set (Int, Int), [(Int, Int)]) -> (Set (Int, Int), [(Int, Int)])
moveElves (elves, directions) = (Set.fromList elves', directions')
  where
    proposals = [(pos, proposeMove elves directions pos) | pos <- Set.toList elves]
    moveCounts = foldr (\(_, pos') acc -> Map.insertWith (+) pos' 1 acc) Map.empty proposals
    elves' =
      map
        (\(pos, pos') -> if Map.findWithDefault 0 pos' moveCounts > 1 then pos else pos')
        proposals
    directions' = tail directions ++ [head directions]

Now I just need to execute moveElves 10 times.

moveTimes :: Int -> (Set (Int, Int), [(Int, Int)]) -> (Set (Int, Int), [(Int, Int)])
moveTimes 0 st = st
moveTimes n st = moveTimes (n - 1) $ moveElves st

The easy way out is to just keep executing moveElves, each time comparing the new set of elves to the old one. This is a bit slow though, so I augmented moveElves to also return a boolean indicating whether any elves moved.

moveElves :: (Set (Int, Int), [(Int, Int)]) -> (Set (Int, Int), [(Int, Int)], Bool)
moveElves (elves, directions) = (Set.fromList elves', directions', hasMoved)
  where
    proposals = [(pos, proposeMove elves directions pos) | pos <- Set.toList elves]
    moveCounts = foldr (\(_, pos') acc -> Map.insertWith (+) pos' 1 acc) Map.empty proposals
    (hasMoved, elves') =
      mapAccumL
        ( \hasMoved (pos, pos') ->
            if Map.findWithDefault 0 pos' moveCounts > 1
              then (hasMoved, pos)
              else (hasMoved || pos /= pos', pos')
        )
        False
        proposals
    directions' = tail directions ++ [head directions]

Now I can execute until no elves move:

findStable :: (Set (Int, Int), [(Int, Int)]) -> Int
findStable = go 1
  where
    go n s =
      let (elves', directions', hasMoved) = moveElves s
       in if not hasMoved then n else go (n + 1) (elves', directions')