Day 23 - Spreading Out the Elves
Subscribe to Monday Morning Haskell!
Problem Overview
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:
- The set of coordinates occupied by elves
- The current direction priority (rotates each round)
- 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:
- Get all proposed moves from the elves.
- Exclude proposed moves with more than 1 elf moving there.
- 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.