Flashing Octopuses and BFS

Oct 10

Today we continue our new series on Advent of Code solutions from 2021. Last time we solved the seven-segment logic puzzle. Today, we'll look at the Day 11 problem which focuses a bit more on traditional coding structures and algorithms.

This will be another in-depth coding write-up. For the next week or so after this I'll switch to doing video reviews so you can compare the styles. I haven't been too exhaustive with listing imports in these examples though, so if you're curious about those you can take a look at the full solution here on GitHub. So now, let's get started!

Problem Statement

For this problem, we're dealing with a set of Octopuses, (Advent of Code had an aquatic theme last year) and these octopuses apparently have an "energy level" and eventually "flash" when they reach their maximum energy level. They sit nicely in a 2D grid for us, and the puzzle input is just a grid of single-digit integers for their initial "energy level". Here's an example.

Now, as time goes by, their energy levels increase. With each step, all energy levels go up by one. So after a single step, the energy grid looks like this:

However, when an octopus reaches level 10, it flashes. This has two results for the next step. First, its own energy level always reverts to 0. Second, it increments the energy level of all neighbors as well. This, of course, can make things more complicated, because we can end up with a cascading series of flashes. Even an octopus that has a very low energy level at the start of a step can end up flashing. Here's an example.

The 1 in the center still ends up flashing. It has four neighbors as 9 which all flash. The surrounding 8's then flash because each has two 9 neighbors. As a result, the 1 has 8 neighbors flashing. Combining with its own increment, it becomes as 10, so it also flashes.

The good news is that all flashing octopuses revert to 0. They don't start counting again from other adjacent flashes so we can't get an infinite loop of flashing and we don't have to worry about the "order" of flashing.

For the first part of the problem, we have to find the total number of flashes after a certain number of steps. For the second part, we have to find the first step when all of the octopuses flash.

Solution Approach

There's nothing too difficult about the solution approach here. Incrementing the grid and finding the initial flashes are easy problems. The only tricky part is cascading the flashes. For this, we need a Breadth-First-Search where each item in the queue is a flash to resolve. As long as we're careful in our accounting and in the update step, we should be able to answer the questions fairly easily.

Utilities

As with last time, we'll start the coding portion with a few utilities that will (hopefully) end up being useful for other problems. The first of these is a simple one. We'll use a type synonym Coord2 to represent a 2D integer coordinate.

type Coord2 = (Int, Int)

Next, we'll want another general parsing function. Last time, we covered parseLinesFromFile, which took a general parser and applied it to every line of an input file. But we also might want to incorporate the "line-by-line" behavior into our general parser, so we'll add a function to parse the whole file given a single ParsecT expression. The structure is much the same, it just does even less work than our prior example.

parseFile :: (MonadIO m) => ParsecT Void Text m a -> FilePath -> m a
parseFile parser filepath = do
  input <- pack <$> liftIO (readFile filepath)
  result <- runParserT parser "Utils.hs" input
  case result of
    Left e -> error $ "Failed to parse: " ++ show e
    Right x -> return x

Last of all, this problem deals with 2D grids and spreading out the "effect" of one square over all eight of its neighbors. So let's write a function to get all the adjacent coordinates of a tile. We'll call this neighbors8, and it will be very similar to a function getting neighbors in 4 directions that I used in this Dijkstra's algorithm implementation.

getNeighbors8 :: HashMap Coord2 a -> Coord2 -> [Coord2]
getNeighbors8 grid (row, col) = catMaybes
  [maybeUp, maybeUpRight, maybeRight, maybeDownRight, maybeDown, maybeDownLeft, maybeLeft, maybeUpLeft]
  where
    (maxRow, maxCol) = maximum $ HM.keys grid
    maybeUp = if row > 0 then Just (row - 1, col) else Nothing
    maybeUpRight = if row > 0 && col < maxCol then Just (row - 1, col + 1) else Nothing
    maybeRight = if col < maxCol then Just (row, col + 1) else Nothing
    maybeDownRight = if row < maxRow && col < maxCol then Just (row + 1, col + 1) else Nothing
    maybeDown = if row < maxRow then Just (row + 1, col) else Nothing
    maybeDownLeft = if row < maxRow && col > 0 then Just (row + 1, col - 1) else Nothing
    maybeLeft = if col > 0 then Just (row, col - 1) else Nothing
    maybeUpLeft = if row > 0 && col > 0 then Just (row - 1, col - 1) else Nothing

This function could also apply to an Array instead of a Hash Map. In fact, it might be even more appropriate there. But below we'll get into the reasons for using a Hash Map.

Parsing the Input

Now, let's get to the first step of the problem itself, which is to parse the input. In this case, the input is simply a 2D array of single-digit integers, so this is a fairly straightforward process. In fact, I figured this whole function could be re-used as well, so it could also be considered a utility.

The first step is to parse a line of integers. Since there are no spaces and no separators, this is very simple using some.

import Data.Char (digitToInt)
import Text.Megaparsec (some)

parseDigitLine :: ParsecT Void Text m [Int]
parseDigitLine = fmap digitToInt <$> some digitChar

Now getting a repeated set of these "integer lists" over a series of lines uses the same trick we saw last time. We use sepEndBy1 combined with the eol parser for end-of-line.

parse2DDigits :: (Monad m) => ParsecT Void Text m [[Int]]
parse2DDigits = sepEndBy1 parseDigitLine eol

However, we want to go one step further. A list-of-lists-of-ints is a cumbersome data structure. We can't really update it efficiently. Nor, in fact, can we even access 2D indices quickly. There are two good structures for us to use, depending on the problem. We can either use a 2D array, or a HashMap where the keys are 2D coordinates.

Because we'll be updating the structure itself, we want a Hash Map in this case. Haskell's Array structure has no good way to update its values without a full copy. If the structure were read only though, Array would be the better choice. For our current problem, the mutable array pattern would also be an option. But for now I'll keep things simpler.

So we need a function to convert nested integer lists into a Hash Map with coordinates. The first step in this process is to match each list of integers with a row number, and each integer within the list with its column number. Infinite lists, ranges and zip are excellent tools here!

hashMapFromNestedLists :: [[Int]] -> HashMap Coord2 Int
hashMapFromNestedLists inputs = ...
  where
    x = zip [0,1..] (map (zip [0,1..]) inputs)

Now in most languages, we would use a nested for-loop. The outer structure would cover the rows, the inner structure would cover the columns. In Haskell, we'll instead do a 2-level fold. The outer layer (the function f) will cover the rows. The inner layer (function g) will cover the columns. Each step updates the Hash Map appropriately.

hashMapFromNestedLists :: [[Int]] -> HashMap Coord2 Int
hashMapFromNestedLists inputs = foldl f HM.empty x
  where
    x = zip [0,1..] (map (zip [0,1..]) inputs)

    f :: HashMap Coord2 Int -> (Int, [(Int, Int)]) -> HashMap Coord2 Int
    f prevMap (row, pairs) = foldl (g row) prevMap pairs

    g :: Int -> HashMap Coord2 Int -> Coord2 -> HashMap Coord2 Int
    g row prevMap (col, val) = HM.insert (row, col) val prevMap

And now we can pull it all together and parse our input!

solveDay11Easy :: String -> IO (Maybe Int)
solveDay11Easy fp = do
  initialState <- parseFile parse2DDigitHashMap fp
  ...

solveDay11Hard :: String -> IO (Maybe Int)
solveDay11Hard fp = do
  initialState <- parseFile parse2DDigitHashMap fp
  ...

Basic Step Running

Now let's get to the core of the algorithm. The function we really need to get right here is a function to update a single step of the process. This will take our grid as an input and produce the new grid as an output, as well as some extra information. Let's start by making another type synonym for OGrid as the "Octopus grid".

type OGrid = HashMap Coord2 Int

Now a simple version of this function would have a type signature like this:

runStep :: (MonadLogger m) => OGrid -> m OGrid

(As mentioned last time, I'm defaulting to using MonadLogger for most implementation details).

However, we'll include two extra outputs for this function. First, we want an Int for the number of flashes that occurred on this step. This will help us with the first part of the problem, where we are summing the number of flashes given a certain number of steps.

Second, we want a Bool indicating that all of them have flashed. This is easy to derive from the number of flashes and will be our terminal condition flag for the second part of the problem.

runStep :: (MonadLogger m) => OGrid -> m (OGrid, Int, Bool)

Now the first thing we can do while stepping is to increment everything. Once we've done that, it is easy to pick out the coordinates that ought be our "initial flashes" - all the items where the value is at least 10.

runStep :: (MonadLogger m) => OGrid -> m (OGrid, Int, Bool)
runStep = ...
  where
  -- Start by incrementing everything
    incrementedGrid = (+1) <$> inputGrid
    initialFlashes = fst <$> filter (\(_, x) -> x >= 10) (HM.toList incrementedGrid)

Now what do we do with our initial flashes to propagate them? Let's defer this to a helper function, processFlashes. This will be where we perform the BFS step recursively. Using BFS requires a queue and a visited set, so we'll want these as arguments to our processing function. Its result will be the final grid, updated with all the incrementing done by the flashes, as well as the final set of all flashes, including the original ones.

processFlashes :: (MonadLogger m) =>
  HashSet Coord2 -> Seq Coord2 -> OGrid -> m (HashSet Coord2, OGrid)

In calling this from our runStep function, we'll prepopulate the visited set and the queue with the initial group of flashes, as well as passing the "incremented" grid.

runStep :: (MonadLogger m) => OGrid -> m (OGrid, Int, Bool)
runStep = do
  (allFlashes, newGrid) <- processFlashes (HS.fromList initialFlashes) (Seq.fromList initialFlashes) incrementedGrid
  ...
  where
  -- Start by incrementing everything
    incrementedGrid = (+1) <$> inputGrid
    initialFlashes = fst <$> filter (\(_, x) -> x >= 10) (HM.toList incrementedGrid)

Now the last thing we need to do is count the total number of flashes and reset all flashes coordinates to 0 before returning. We can also compare the number of flashes to the size of the hash map to see if they all flashed.

runStep :: (MonadLogger m) => OGrid -> m (OGrid, Int, Bool)
runStep inputGrid = do
  (allFlashes, newGrid) <- processFlashes (HS.fromList initialFlashes) (Seq.fromList initialFlashes) incrementedGrid
  let numFlashes = HS.size allFlashes
  let finalGrid = foldl (\g c -> HM.insert c 0 g) newGrid allFlashes
  return (finalGrid, numFlashes, numFlashes == HM.size inputGrid)
  where
  -- Start by incrementing everything
    incrementedGrid = (+1) <$> inputGrid
    initialFlashes = fst <$> filter (\(_, x) -> x >= 10) (HM.toList incrementedGrid)

Processing Flashes

So now we need to do this flash processing! To re-iterate, this is a BFS problem. We have a queue of coordinates that are flashing. In order to process a single flash, we increment its neighbors and, if incrementing puts its energy over 9, add it to the back of the queue to be processed.

So our inputs are the sequence of coordinates to flash, the current grid, and a set of coordinates we've already visited (since we want to avoid "re-flashing" anything).

processFlashes :: (MonadLogger m) =>
  HashSet Coord2 -> Seq Coord2 -> OGrid -> m (HashSet Coord2, OGrid)

We'll start with a base case. If the queue is empty, we'll return the input grid and the current visited set.

import qualified Data.Sequence as Seq
import qualified Data.HashSet as HS
import qualified Data.HashMap.Strict as HM

processFlashes :: (MonadLogger m) =>
  HashSet Coord2 -> Seq Coord2 -> OGrid -> m (HashSet Coord2, OGrid)
processFlashes visited queue grid = case Seq.viewl queue of
  Seq.EmptyL -> return (visited, grid)
  ...

Now suppose we have a non-empty queue and we can pull off the top element. We'll start by getting all 8 neighboring coordinates in the grid and incrementing their values. There's no harm in re-incrementing coordinates that have flashed already, because we'll just reset everything

processFlashes :: (MonadLogger m) =>
  HashSet Coord2 -> Seq Coord2 -> OGrid -> m (HashSet Coord2, OGrid)
processFlashes visited queue grid = case Seq.viewl queue of
  Seq.EmptyL -> return (visited, grid)
  top Seq.:< rest -> do
    -- Get the 8 adjacent coordinates in the 2D grid
    let allNeighbors = getNeighbors8 grid top
        -- Increment the value of all neighbors
        newGrid = foldl (\g c -> HM.insert c ((g HM.! c) + 1) g) grid allNeighbors
        ...

Then we want to filter this neighbors list down to the neighbors we'll add to the queue. So we'll make a predicate shouldAdd that tells us if a neighboring coordinate is a.) at least energy level 9 (so incrementing it causes a flash) and b.) that it is not yet visited. This lets us construct our new visited set and the final queue.

processFlashes :: (MonadLogger m) =>
  HashSet Coord2 -> Seq Coord2 -> OGrid -> m (HashSet Coord2, OGrid)
processFlashes visited queue grid = case Seq.viewl queue of
  Seq.EmptyL -> return (visited, grid)
  top Seq.:< rest -> do
    let allNeighbors = getNeighbors8 grid top
        newGrid = foldl (\g c -> HM.insert c ((g HM.! c) + 1) g) grid allNeighbors
        neighborsToAdd = filter shouldAdd allNeighbors
        newVisited = foldl (flip HS.insert) visited neighborsToAdd
        newQueue = foldl (Seq.|>) rest neighborsToAdd
    ...
  where
    shouldAdd :: Coord2 -> Bool
    shouldAdd coord = grid HM.! coord >= 9 && not (HS.member coord visited)

And, the cherry on top, we just have to make our recursive call with the new values.

processFlashes :: (MonadLogger m) =>
  HashSet Coord2 -> Seq Coord2 -> OGrid -> m (HashSet Coord2, OGrid)
processFlashes visited queue grid = case Seq.viewl queue of
  Seq.EmptyL -> return (visited, grid)
  top Seq.:< rest -> do
    let allNeighbors = getNeighbors8 grid top
        newGrid = foldl (\g c -> HM.insert c ((g HM.! c) + 1) g) grid allNeighbors
        neighborsToAdd = filter shouldAdd allNeighbors
        newVisited = foldl (flip HS.insert) visited neighborsToAdd
        newQueue = foldl (Seq.|>) rest neighborsToAdd
    processFlashes newVisited newQueue newGrid
  where
    shouldAdd :: Coord2 -> Bool
    shouldAdd coord = grid HM.! coord >= 9 && not (HS.member coord visited)

With processing done, we have completed our function for running a sinigle step.

Easy Solution

Now that we can run a single step, all that's left is to answer the questions! For the first (easy) part, we just want to count the number of flashes that occur over 100 steps. This will follow a basic recursion pattern, where one of the arguments tells us how many steps are left. The stateful values that we're recursing on are the grid itself, which updates each step, and the sum of the number of flashes.

runStepCount :: (MonadLogger m) => Int -> (OGrid, Int) -> (OGrid, Int)

Let's start with a base case. When we have 0 steps left, we return the inputs as the result.

runStepCount :: (MonadLogger m) => Int -> (OGrid, Int) -> m (OGrid, Int)
runStepCount 0 results = return results
...

The recursive case is also quite easy. We invoke runStep to get the updated grid and the number of flashses, and then recurse with a reduced step count, adding the new flashes to our previous sum.

runStepCount :: (MonadLogger m) => Int -> (OGrid, Int) -> m (OGrid, Int)
runStepCount 0 results = return results
runStepCount i (grid, prevFlashes) = do
  (newGrid, flashCount, _) <- runStep grid
  runStepCount (i - 1) (newGrid, flashCount + prevFlashes)

And then we can call this from our "easy" entrypoint:

solveDay11Easy :: String -> IO (Maybe Int)
solveDay11Easy fp = do
  initialState <- parseFile parse2DDigitHashMap fp
  (_, numFlashes) <- runStdoutLoggingT $ runStepCount 100 (initialState, 0)
  return $ Just numFlashes

Hard Solution

For the second part of the problem, we want to find the first step where *all octopuses flash**. Obviously once they synchronize the first time, they'll remain synchronized forever after that. So we'll write a slightly different recursive function, this time counting up instead of down.

runTillAllFlash :: (MonadLogger m) => OGrid -> Int -> m Int
runTillAllFlash inputGrid thisStep = ...

Each time we run this function, we'll call runStep. The terminal condition is when the Bool flag we get from runStep becomes true. In this case, we return the current step value.

runTillAllFlash :: (MonadLogger m) => OGrid -> Int -> m Int
runTillAllFlash inputGrid thisStep = do
  (newGrid, _, allFlashed) <- runStep inputGrid
  if allFlashed
    then return thisStep
    ...

Otherwise, we just going to recurse, except with an incremented step count.

runTillAllFlash :: (MonadLogger m) => OGrid -> Int -> m Int
runTillAllFlash inputGrid thisStep = do
  (newGrid, _, allFlashed) <- runStep inputGrid
  if allFlashed
    then return thisStep
    else runTillAllFlash newGrid (thisStep + 1)

And once again, we wrap up by calling this function from our "hard" entrypoint.

solveDay11Hard :: String -> IO (Maybe Int)
solveDay11Hard fp = do
  initialState <- parseFile parse2DDigitHashMap fp
  firstAllFlash <- runStdoutLoggingT $ runTillAllFlash initialState 1
  return $ Just firstAllFlash

And now we're done! Our program should be able to solve both parts of the problem!

Conclusion

For the next couple articles, I'll be walking through these same problems, except in video format! So stay tuned for that, and make sure you're subscribed to the YouTube channel so you get notifications about it!

And if you're interested in staying up to date with all the latest news on Monday Morning Haskell, make sure to subscribe to our mailing list. This will get you our monthly newsletter, access to our resources page, and you'll also get special offers on all of our video courses!

In Depth

James Bowen