Day 23 - Spreading Out the Elves

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

In this problem, we've met back up with our elf friends, and they are trying to determine the optimal way to spread themselves out to plant some trees. They start out clustered up in a 2D grid. Each round, each elf considers moving in each of the 4 cardinal directions in turn. They won't move in a direction if another elf is anywhere near it (e.g. an elf won't move north if another elf is either north, northeast, or northwest of it). An elf also won't move if there are no elves around it.

The priority for their movement changes each round. In round 1, they'll consider moving north first, then south, then west, then east. In round 2, this order shifts so that south is considered first and north last, and so on in a rotating manner.

Finally, it is possible that two elfs propose moving into the same location from opposite directions. In this case, neither moves.

In part 1 of the problem, we run 10 rounds of the simulation and determine how much empty space is covered by the rectangle formed by the elves. In part 2, we see how many rounds it takes for the simulation to reach a stable state, with every elf having no more neighbors.

Solution Approach and Insights

This problem doesn't require any super deep insights, just careful accounting. One realization that makes the solution a bit easier is that if an elf moves from coordinate C, no other elf can possibly move into position C that round.

Relevant Utilities

This problem uses a couple utilities. First, we'll parse our input as a 2D Hashmap where each cell is just a Bool value. Then, we'll reuse our occurrence map idea that's come up a few times. This will track the number of elves moving into a certain coordinate.

Parsing the Input

Here's a sample input:

....#..
..###.#
#...#.#
.#...##
#.###..
##.#.##
.#..#..

As usual, . spaces are empty, and # spaces contain an elf. We'll parse this as a 2D Hashmap just to get the coordinates straight, and then we'll filter it down to a Hashset of just the occupied coordinates.

type InputType = HS.HashSet Coord2

-- Parse as 2D Hash Map of Bools.
-- Filter out to the coordinates that are occupied.
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  hashMap <- parse2DHashMap (some parseLoc)
  return $ HS.fromList $ fst <$> filter snd (HM.toList hashMap)
  where
    parseLoc = (char '.' >> return False) <|> (char '#' >> return True)

Getting the Solution

First, let's add a quick type for the 4 cardinal directions. This will help us track the priority order.

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

At its core, this is a state evolution problem. So we'll use the appropriate pattern. The state we're tracking for each round consists of 3 pieces:

1. The set of coordinates occupied by elves
2. The current direction priority (rotates each round)
3. Whether or not any elf moved this round.

So let's fill in the pattern like so:

type StateType = (HS.HashSet Coord2, [Direction], Bool)

-- Recursively run the state evolution n times.
solveStateN :: (MonadLogger m) => Int -> StateType -> m StateType
solveStateN 0 st = return st {- Base case: (n = 0) -}
solveStateN n st = do
  st' <- evolveState st
  solveStateN (n - 1) st' {- Recursive case: (n - 1) -}

evolveState :: (MonadLogger m) => StateType -> m StateType

Now all the magic happens in our evolveState function. This has 3 core steps:

1. Get all proposed moves from the elves.
2. Exclude proposed moves with more than 1 elf moving there.
3. Update the set of occupied squares

The first part is the most complicated. We'll fold over each of the existing elf coordinates and see if we can propose a new move for it. The fold state will track the number of times each move is proposed, as well as a mapping from destination coordinates back to source coordinates.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = ...

The first order of business here is checking if each direction is empty. We do this with list comprehensions.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = (prevMoves, destOcc) c@(row, col) = do
      let northEmpty = not $ or [HS.member c elfSet | c <- [(row - 1, col - 1), (row - 1, col), (row - 1, col + 1)]]
          southEmpty = not $ or [HS.member c elfSet | c <- [(row + 1, col - 1), (row + 1, col), (row + 1, col + 1)]]
          westEmpty = not $ or [HS.member c elfSet | c <- [(row + 1, col - 1), (row , col - 1), (row - 1, col - 1)]]
          eastEmpty = not $ or [HS.member c elfSet | c <- [(row + 1, col + 1), (row , col + 1), (row - 1, col + 1)]]
          stayStill = northEmpty && southEmpty && eastEmpty && westEmpty
      ...

Now we need some helpers to "try" each direction and return a move. These functions will each take the corresponding Empty boolean and return the appropriate coordinate for the direction if the boolean is True. Otherwise they'll give Nothing.

tryNorth :: Bool -> Coord2 -> Maybe Coord2
tryNorth b (row, col) = if b then Just (row - 1, col) else Nothing

trySouth :: Bool -> Coord2 -> Maybe Coord2
trySouth b (row, col) = if b then Just (row + 1, col) else Nothing

tryEast :: Bool -> Coord2 -> Maybe Coord2
tryEast b (row, col) = if b then Just (row, col + 1) else Nothing

tryWest :: Bool -> Coord2 -> Maybe Coord2
tryWest b (row, col) = if b then Just (row, col - 1) else Nothing

Now we need to try each move in order using these functions, our Empty booleans, and in particular the alternative operator <|>.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = (prevMoves, destOcc) c@(row, col) = do
      let northEmpty = ...
          southEmpty = ...
          westEmpty = ...
          eastEmpty = ...
          stayStill = northEmpty && southEmpty && eastEmpty && westEmpty
          trialMove = case head directions of
                        North -> tryNorth northEmpty c <|> trySouth southEmpty c <|> tryWest westEmpty c <|> tryEast eastEmpty c
                        South -> trySouth southEmpty c <|> tryWest westEmpty c <|> tryEast eastEmpty c <|> tryNorth northEmpty c
                        West -> tryWest westEmpty c <|> tryEast eastEmpty c <|> tryNorth northEmpty c <|> trySouth southEmpty c
                        East -> tryEast eastEmpty c <|> tryNorth northEmpty c <|> trySouth southEmpty c <|> tryWest westEmpty c
      ...

Finally, we'll update our fold values as long as the trialMove is a Just value AND we are not staying still. We increment the destination move in the occurrence map, and we add the destination->source mapping.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = (prevMoves, destOcc) c@(row, col) = do
      let northEmpty = ...
          southEmpty = ...
          westEmpty = ...
          eastEmpty = ...
          stayStill = northEmpty && southEmpty && eastEmpty && westEmpty
          trialMove = ...
      return $ if isJust trialMove && not stayStill 
            then (HM.insert (fromJust trialMove) c prevMoves, incKey destOcc (fromJust trialMove))
            else (prevMoves, destOcc)

In step 2, we filter the move proposals down to those that only have one elf moving there.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  let spacesWithOne = filter (\(_, occ) -> occ == 1) (Data.Map.toList occurrences)
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)

Now we just need to update the original elfSet with these values. The helper updateSetForMove will delete the original source from our set and add the new destination (this is why we need the destination->source mapping).

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  let spacesWithOne = filter (\(_, occ) -> occ == 1) (Data.Map.toList occurrences)
  let updatedSet = foldl (updateSetForMove proposedMoves) elfSet (fst <$> spacesWithOne)
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)

    updateSetForMove :: HM.HashMap Coord2 Coord2 -> HS.HashSet Coord2 -> Coord2 -> HS.HashSet Coord2
    updateSetForMove moveLookup prevSet newLoc = HS.insert newLoc (HS.delete (moveLookup HM.! newLoc) prevSet)

Finally, we rotate the directions so that first becomes last, and add a null check on spacesWithOne to see if any elves moved this turn.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  let spacesWithOne = filter (\(_, occ) -> occ == 1) (Data.Map.toList occurrences)
  let updatedSet = foldl (updateSetForMove proposedMoves) elfSet (fst <$> spacesWithOne)
  return (updatedSet, rotatedDirections, not (null spacesWithOne))
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)

    updateSetForMove :: HM.HashMap Coord2 Coord2 -> HS.HashSet Coord2 -> Coord2 -> HS.HashSet Coord2
    updateSetForMove moveLookup prevSet newLoc = HS.insert newLoc (HS.delete (moveLookup HM.! newLoc) prevSet)

    rotatedDirections = tail directions ++ [head directions]

We're almost done! Now we need to find the smallest axis-aligned bounding box for all the elves, and we have to find the number of unoccupied squares within that box. This is fairly straightforward. We unzip the coordinates to separate x's and y's, and we take the maximum and minimum in each direction. We subtract the total number of elves from the area of this rectangle.

findEasySolution :: (MonadLogger m, MonadIO m) => EasySolutionType -> m (Maybe Int)
findEasySolution occupiedSquares = do
  let (rows, cols) = unzip $ HS.toList occupiedSquares
  let r@(minRow, maxRow, minCol, maxCol) = (minimum rows, maximum rows, minimum cols, maximum cols)
  return $ Just $ (maxRow - minRow + 1) * (maxCol - minCol + 1) - HS.size occupiedSquares

And then we just add a little glue to complete part 1.

type EasySolutionType = HS.HashSet Coord2

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = do
  (result, _, _) <- solveStateN 10 (inputs, [North, South, West, East], True)
  return result

 :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  result <- processInputEasy input
  findEasySolution result

Part 2

Not a whole lot changes in Part 2! We just use a slightly different recursive function to call evolveState. Instead of counting down to 0 for its base case, we'll instead have our counter go upwards and return this count once the last part of our state type is False.

-- Evolve the state until no more elves move.
solveStateEnd :: (MonadLogger m) => Int -> StateType -> m Int
solveStateEnd n st@(_, _, False) = return n {- Base Case: No elves moved. -}
solveStateEnd n st = do
  st' <- evolveState st
  solveStateEnd (n + 1) st' {- Recursive Case: Add 1 to count -}

And some last bits of code to tie it together:

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = solveStateEnd 0 (inputs, [North, South, West, East], True)

solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  Just <$> processInputHard input

And now we're done! 2 more days to go!

Video

Coming eventually.