James Bowen 12/8/22 James Bowen 12/8/22

Day 8 - Scenic Tree Visibility

All 2022 Problems

Problem Overview

Today is our first 2D grid problem of the year. We're looking at a forest, and each number in the grid is the height of a particular tree. We want to answer two different questions about the grid. First, how many trees are "visible" from the outside of the grid? We'll imagine we walk around the grid from all four sides and look at each row and column until we hit a tree that is too tall to see any other trees behind.

For the second part, we'll consider each individual location inside the grid and determine how many trees are visible from that location.

Solution Approach and Insights

There's nothing too clever about my solution. Our scale is still small enough that we can more or less do brute force explorations as long as we're using an array.

Parsing the Input

So today's input is a 2D array of single-digit integers.

From last year, I had a utility for this exact case: parse2DDigitArray.

type Coord2 = (Int, Int)
type Grid2 a = Array Coord2 a

-- Only single digit numbers
parse2DDigitArray :: (Monad m) => ParsecT Void Text m (Grid2 Int)
parse2DDigitArray = digitsToArray <$> sepEndBy1 parseDigitLine eol

digitsToArray :: [[Int]] -> Grid2 Int
digitsToArray inputs = A.listArray ((0, 0), (length inputs - 1, length (head inputs) - 1)) (concat inputs)

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

So we can pull it into our solution like so:

type InputType = Grid2 Int

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = parse2DDigitArray

Getting the Solution

For part 1, we need to consider each column from two directions and each row from two directions, and count the number of visible trees going down the line. Let's start with a function to do this in the vertical direction.

Instead of returning a raw count, we'll write this function to be used with a fold. It will take a Set of visible coordinates and return a modified set. This will prevent us from counting the same location twice from different directions. It will have two preliminary arguments - the grid and the list of row indices.

countVisibleVertical :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleVertical treeGrid rows prev col  = ...

Within this function, we'll fold through the row indices. However, in addition to using the Set within our folding type, we'll also keep track of the highest tree we've seen so far. If the next tree height is larger than the highest tree we've seen so far, we insert this new item into the visited set and update the height. Otherwise, neither changes.

countVisibleVertical :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleVertical treeGrid rows prev col  = ...
  where
    assessRow :: (S.Set Coord2, Int) -> Int -> (S.Set Coord2, Int)
    assessRow (prevSet, highestSeen) row =
      let nextHeight = treeGrid A.! (row, col)
      in  if nextHeight > highestSeen then (S.insert (row, col) prevSet, nextHeight) else (prevSet, highestSeen)

And now we complete the function by performing the fold (we start with our initial set and a minimum height of -1) and then only return the set.

countVisibleVertical :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleVertical treeGrid rows prev col = return $ fst $ foldl assessRow (prev, -1) rows
  where
    assessRow :: (S.Set Coord2, Int) -> Int -> (S.Set Coord2, Int)
    assessRow (prevSet, highestSeen) row =
      let nextHeight = treeGrid A.! (row, col)
      in  if nextHeight > highestSeen then (S.insert (row, col) prevSet, nextHeight) else (prevSet, highestSeen)

We can do the same thing in the horizontal direction. This function looks very similar, just reversing rows and columns.

countVisibleHorizontal :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleHorizontal treeGrid columns prev row = return $ fst $ foldl assessColumn (prev, -1) columns
  where
    assessColumn :: (S.Set Coord2, Int) -> Int -> (S.Set Coord2, Int)
    assessColumn (prevSet, highestSeen) col =
      let nextHeight = treeGrid A.! (row, col)
      in  if nextHeight > highestSeen then (S.insert (row, col) prevSet, nextHeight) else (prevSet, highestSeen)

Now we just have to run these functions in turn. Twice with horizontal, twice with vertical, and passing the resulting set each time.

type EasySolutionType = Int

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy treeGrid = do
  let rows = [0..(fst . snd . A.bounds $ treeGrid)]
  let cols = [0..(snd . snd . A.bounds $ treeGrid)]
  s1 <- foldM (countVisibleHorizontal treeGrid cols) S.empty rows
  s2 <- foldM (countVisibleHorizontal treeGrid (reverse cols)) s1 rows
  s3 <- foldM (countVisibleVertical treeGrid rows) s2 cols
  S.size <$> foldM (countVisibleVertical treeGrid (reverse rows)) s3 cols

Part 2

In part 2, we just have to loop through each possible index in our grid. Then we'll apply a function to assess the scenic score at that location. We just have to look in each direction.

assessScenicScore :: (MonadLogger m) => Grid2 Int -> Coord2 -> m HardSolutionType
assessScenicScore treeGrid (row, col) = return $ lookUp * lookLeft * lookDown * lookRight
    heightHere = treeGrid A.! (row, col)
    (maxRow, maxCol) = snd (A.bounds treeGrid)
    lookUp = ...
    lookLeft = ...
    lookDown = ...
    lookRight = ...

Within each case, we have to have a special case of 0 when we're at the edge. Then we'll use takeWhile to find the number of indices that are smaller than our present height. After that, there's one more edge case if we count all the trees in that direction. Here's the "up" case:

assessScenicScore :: (MonadLogger m) => Grid2 Int -> Coord2 -> m HardSolutionType
assessScenicScore treeGrid (row, col) = return $ lookUp * lookLeft * lookDown * lookRight
    heightHere = treeGrid A.! (row, col)
    (maxRow, maxCol) = snd (A.bounds treeGrid)
    lookUp = if row == 0 then 0
      else
        let smallerTrees = length $ takeWhile (\r -> treeGrid A.! (r, col) < heightHere) [(row - 1),(row - 2)..0]
        in  if smallerTrees == row then smallerTrees else smallerTrees + 1
    lookLeft = ...
    lookDown = ...
    lookRight = ...

And here's the full function:

type HardSolutionType = EasySolutionType

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard treeGrid = maximum <$> mapM (assessScenicScore treeGrid) (A.indices treeGrid)

assessScenicScore :: (MonadLogger m) => Grid2 Int -> Coord2 -> m HardSolutionType
assessScenicScore treeGrid (row, col) = return $ lookUp * lookLeft * lookDown * lookRight
  where
    heightHere = treeGrid A.! (row, col)
    (maxRow, maxCol) = snd (A.bounds treeGrid)
    lookUp = if row == 0 then 0
      else
        let smallerTrees = length $ takeWhile (\r -> treeGrid A.! (r, col) < heightHere) [(row - 1),(row - 2)..0]
        in  if smallerTrees == row then smallerTrees else smallerTrees + 1
    lookLeft = if col == 0 then 0
      else
        let smallerTrees = length $ takeWhile (\c -> treeGrid A.! (row, c) < heightHere) [(col - 1),(col-2)..0]
        in  if smallerTrees == col then smallerTrees else smallerTrees + 1
    lookDown = if row == maxRow then 0
      else
        let smallerTrees = length $ takeWhile (\r -> treeGrid A.! (r, col) < heightHere) [(row + 1)..maxRow]
        in  if smallerTrees + row == maxRow then smallerTrees else smallerTrees + 1
    lookRight = if col == maxCol then 0
      else
        let smallerTrees = length $ takeWhile (\c -> treeGrid A.! (row, c) < heightHere) [(col + 1)..maxCol]
        in  if smallerTrees + col == maxCol then smallerTrees else smallerTrees + 1

And doing the full processing is easy! Just map this function over all the indices:

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard treeGrid = maximum <$> mapM (assessScenicScore treeGrid) (A.indices treeGrid)

Answering the Question

There's no additional processing for this problem. We just have the two steps.

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

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

So this gives us our complete solution!

Video

YouTube Link

James Bowen 12/7/22 James Bowen 12/7/22

Day 7 - File System Shaving

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Our input is a series of file system commands that list the directories and files (with their sizes) on a computer. In the first part, we'll find every directory whose size is less than 100000 bytes and add their sizes. In the second part, we'll determine the smallest directory we need to delete to free up enough space to perform an update.

Solution Approach and Insights

As we loop through the different commands and outputs that are run, we want to track the current directory as a list of sub-directories. Then we can add each file's size to all directories along that tree. But we need to make sure our representation for each directory incorporates its full path as a list, and not just the top level.

Relevant Utilities

Once again, we're using OccMap, but this time it will be the OccMapBig alias that uses an unbounded Integer instead of Word, just because the sum of file sizes might get a bit large.

Parsing the Input

Here's a sample input:

$ cd /
$ ls
dir a
14848514 b.txt
8504156 c.dat
dir d
$ cd a
$ ls
dir e
29116 f
2557 g
62596 h.lst
$ cd e
$ ls
584 i
$ cd ..
$ cd ..
$ cd d
$ ls
4060174 j
8033020 d.log
5626152 d.ext
7214296 k

It contains four kinds of lines:

Change Directory commands (cd)
List directory commands (ls)
A directory listed by ls (stars with dir)
A file listed by ls (starts with a file size)

We treat each line as its own kind of "command" (even the outputs, which aren't technically commands). We'll make this data type to represent the idea:

type InputType = [LineType]
type LineType = Command
data Command =
  ChangeDirectoryCommand String |
  ListDirectoryCommand |
  ListedDirectory String |
  ListedFile Integer String
  deriving (Show)

The parsing code isn't too hard. The main thing is we want an alternative parser for each command type.

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = parseCD <|> parseLS <|> parseDir <|> parseFile
  where
    parseCD = ...
    parseLS = ...
    parseDir = ...
    parseFile = ...

Within these parsers, we'll also have some other alternatives, but nothing it too tricky. For instance, the cd parser has to account for cd .., cd / and then using a normal directory name.

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = parseCD <|> parseLS <|> parseDir <|> parseFile
  where
    parseCD = do
      string "$ cd "
      dir <- (unpack <$> string "..") <|> (unpack <$> string "/") <|> some letterChar
      return $ ChangeDirectoryCommand dir
    parseLS = ...
    parseDir = ...
    parseFile = ...

Here's the complete parser, which we apply line-by-line.

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eol

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = parseCD <|> parseLS <|> parseDir <|> parseFile
  where
    parseCD = do
      string "$ cd "
      dir <- (unpack <$> string "..") <|> (unpack <$> string "/") <|> some letterChar
      return $ ChangeDirectoryCommand dir
    parseLS = string "$ ls" >> return ListDirectoryCommand
    parseDir = do
      string "dir "
      dir <- some letterChar
      return $ ListedDirectory dir
    parseFile = do
      fileSize <- fromIntegral <$> parsePositiveNumber
      char ' '
      fileName <- some (letterChar <|> char '.')
      return $ ListedFile fileSize fileName

Getting the Solution

As we loop through different commands, we need to track the current directory we're in, as well as the sizes for each directory based on the files we've seen so far. Note we have to use the full path as the key. There are some duplicately named sub-directories, so we can't just use the relative name in our map!

data FSState = FSState
  { currentDirectory :: [String]
  , directoryMap :: OccMapBig [String]
  } deriving (Show)

So let's set up a fold to go through each line. Ultimately the directoryMap is the only item we need to solve the problem.

type EasySolutionType = OccMapBig [String]

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = directoryMap <$> solveFold inputs

solveFold :: (MonadLogger m) => [LineType] -> m FSState
solveFold = foldM foldLine initialFoldV

initialFoldV :: FSState
initialFoldV = FSState [] M.empty

foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine = ...

Now we have to determine how each command modifies the state. However, only two commands actually change the state. Changing the directory will obviously modify our current directory, and reading a file with its size will modify our map. But reading the list command and reading a new directory name that is listed don't actually modify our state. So we can set up this template.

foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine prevState command = case command of
  ChangeDirectoryCommand dir -> ...
  ListedFile size _ -> ...
  _ -> return prevState

Changing directory has three cases. If we change to "..", we remove a level from our hierarchy with tail. If we change to "/", we reset the hierarchy to just have this root element. Otherwise, we append the new directory to the front of the hierarchy.

foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine prevState command = case command of
  ChangeDirectoryCommand dir -> if dir == ".."
    then return $ prevState { currentDirectory = tail (currentDirectory prevState)}
    else if dir == "/"
      then return $ prevState { currentDirectory = ["/"]}
      else return $ prevState { currentDirectory = dir : currentDirectory prevState}
  ListedFile size _ -> ...
  _ -> return prevState

When we list a file, we have to go through all the subdirectories and add its size to their stored value. But remember, each subdirectory contains the full list. So we need the tails function in order to properly enumerate these. Here's a quick example of tails:

tails [1, 2, 3] = [[1, 2, 3], [2, 3], [3], []]

Then we need init on that result to exclude the empty list from tails. We fold through these options and use addKey with our occupancy map.

Here is the complete function:

foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine prevState command = case command of
  ChangeDirectoryCommand dir -> if dir == ".."
    then return $ prevState { currentDirectory = tail (currentDirectory prevState)}
    else if dir == "/"
      then return $ prevState { currentDirectory = ["/"]}
      else return $ prevState { currentDirectory = dir : currentDirectory prevState}
  ListedFile size _ -> do
    let allDirs = currentDirectory prevState
    let newDirMap = foldl (\mp d -> addKey mp d size) (directoryMap prevState) (init $ tails allDirs)
    return $ prevState { directoryMap = newDirMap}
  _ -> return prevState

Now we'll have the mapping from directory paths to sizes, so we can start answering the questions!

Answering the Question

For the first part, we filter the directory sizes by only looking for those under 100000 bytes. Then we take the sum of these.

findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe Integer)
findEasySolution dirMap = do
  let largePairs = filter (<= 100000) (M.elems dirMap)
  return $ Just $ sum largePairs

For the second part, we sort the directory sizes and find the first one that will give us the desired unused space.

findHardSolution :: (MonadLogger m) => HardSolutionType -> m (Maybe Integer)
findHardSolution dirMap = do
  let allDirSizes = sort (M.elems dirMap)
  let usedSpace = last allDirSizes
  let currentUnusedSpace = 70000000 - usedSpace
  return $ find (\i -> currentUnusedSpace + i >= 30000000) allDirSizes

Observe how we use the last element for the total "used" size. The largest size in our map should always be the root element, which contains all files! We don't want to sum the values in this list since otherwise we'd be double-counting files!

Now we just combine our functions and get our answers!

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

solveHard :: FilePath -> IO (Maybe Integer)
solveHard fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  result <- processInputEasy input
  findHardSolution result

And we're done!

Video

YouTube Link

James Bowen 12/6/22 James Bowen 12/6/22

Day 6 - Parsing Unique Characters

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

With today's problem, we're looping through a string and searching for the first sequence of a certain length with unique characters. For part 1, we have to find the index where our 4 most recent characters are all unique. For part 2, this number gets bumped to 14.

Relevant Utilities

This will be the first time we use an Occurrence Map (OccMap) this year. A lot of problems rely on counting the occurrences of particular values. So I added a few wrappers and helpers to make this easy. So by using incKey, we can bump up the stored value up by 1.

type OccMap a = OccMapI a Word
type OccMapI a i = Map a i

emptyOcc :: OccMap a
emptyOcc = M.empty

incKey :: (Ord a, Integral i) => OccMapI a i -> a -> OccMapI a i
incKey prevMap key = addKey prevMap key 1

decKey :: (Ord a, Integral i) => OccMapI a i -> a -> OccMapI a i
decKey prevMap key = case M.lookup key prevMap of
  Nothing -> prevMap
  Just 0 -> M.delete key prevMap
  Just 1 -> M.delete key prevMap
  Just x -> M.insert key (x - 1) prevMap

addKey :: (Ord a, Integral i) => OccMapI a i -> a -> i -> OccMapI a i
addKey prevMap key count = case M.lookup key prevMap of
    Nothing -> M.insert key count prevMap
    Just x -> M.insert key (x + count) prevMap

In this solution, we'll also use decKey. Note that we delete the key if the count gets down to 0. This will be important in our problem!

Solution Approach and Insights

When I initially approached this problem, I made a custom data type and stored the different characters as individual elements. This worked fine for 3 characters, but it was cumbersome for 14. So I rewrote the solution more generically. We track the most recent characters we've seen in two different structures simultaneously.

First, we use a sequence to track the order we received them, so that with each iteration, we'll drop one character from the front and add a new one to the back.

We'll also use an occurrence map to track the counts for each character type in the last 4 (or 14). We'll increment a character's key when it is added, and decrement when it is removed from the front. If at any point we have 14 keys in our occurrence map, we're done!

Parsing the Input

Today we're only parsing a string:

mjqjpqmgbljsphdztnvjfqwrcgsmlb

So the parser is trivial:

type InputType = String

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = some letterChar

Getting the Solution

To solve our problem, we're going to need one primary function to process the characters. We'll parameterize this by the number of characters we need for a unique code. If we don't have enough characters to reach the unique number, we'll log an error and return the max integer.

processChars :: (MonadLogger m) => Int -> [Char] -> m Int
processChars numCharsNeeded input = if length input < numCharsNeeded
  then logErrorN "Not enough chars!" >> return maxBound
  else ...

Now we need to initialize our structures. We'll split the input string into its first part (up to the number of unique characters) and the rest. The first characters will go into a sequence as well as our occurrence map.

processChars :: (MonadLogger m) => Int -> [Char] -> m Int
processChars numCharsNeeded input = if length input < numCharsNeeded
  then logErrorN "Not enough chars!" >> return maxBound
  else do
    let (firstChars, rest) = splitAt (numCharsNeeded - 1) input
        seq = Seq.fromList firstChars
        occ = foldl incKey emptyOcc firstChars
    ...

Now we need our recursive helper. This function will also be parameterized by the number of characters needed. The "state" for the helper will have an Int for the current index we're at in the string. We'll also have the current queue of characters, as well as the occurrence map for the counts of each character.

Now for implementation, starting with the "base" case. This function should never reach the end of the input. If it does, we'll handle this error case in the same way as above.

processTail :: (MonadLogger m) => Int -> (Int, Seq.Seq Char, OccMap Char) -> [Char] -> m Int
processTail _ _ [] = logErrorN "No remaining chars!" >> return maxBound
processTail numCharsNeeded (count, seq, occ) (c : cs) = ...

Now break off the first piece of the sequence using Seq.viewl so that we'll be able to modify the sequence later. We have another error case that should never be tripped.

processTail numCharsNeeded (count, seq, occ) (c : cs) = case Seq.viewl seq of
  Seq.EmptyL -> logErrorN "Sequence is empty!" >> return maxBound
  (first Seq.:< rest) -> do
    ...

Here's where we do the calculation. First, increment the value for our new character c. At this point, we can check the size of our occurrence map. If it equals the number of characters we need, we're done! We can return the current count value.

Otherwise we'll recurse. We add the new character to the end of the queue and we decrement the occurrence map for the character we removed.

processTail :: (MonadLogger m) => Int -> (Int, Seq.Seq Char, OccMap Char) -> [Char] -> m Int
processTail _ _ [] = logErrorN "No remaining chars!" >> return maxBound
processTail numCharsNeeded (count, seq, occ) (c : cs) = case Seq.viewl seq of
  Seq.EmptyL -> logErrorN "Sequence is empty!" >> return maxBound
  (first Seq.:< rest) -> do
    let occ' = incKey occ c
    if M.size occ' == numCharsNeeded
      then return count
      else processTail numCharsNeeded (count + 1, rest Seq.|> c, decKey occ' first) cs

And now we just plug in the call to this helper into our original function!

processChars :: (MonadLogger m) => Int -> [Char] -> m Int
processChars numCharsNeeded input = if length input < numCharsNeeded
  then logErrorN "Not enough chars!" >> return maxBound
  else do
    let (firstChars, rest) = splitAt (numCharsNeeded - 1) input
        seq = Seq.fromList firstChars
        occ = foldl incKey emptyOcc firstChars
    processTail numCharsNeeded (numCharsNeeded, seq, occ) rest

Answering the Question

Now answering the questions is quite easy. We parameterize the calls with the different length values.

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy = processChars 4

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard = processChars 14

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

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

And we're done!

Video

YouTube Link

James Bowen 12/5/22 James Bowen 12/5/22

Day 5 - Crate Stacks

Today could be considered the first intermediate puzzle of the year so far. At the very least, the input parsing is quite a bit more complicated than previous days. The algorithm portion is still pretty easy once you wrap your head around it.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

In today's problem, we are tracking the movement of crates being shifted around by a crane. It's easiest to explain just by looking at the input:

[D]    
[N] [C]    
[Z] [M] [P]
 1   2   3 

move 1 from 2 to 1
move 3 from 1 to 3
move 2 from 2 to 1
move 1 from 1 to 2

The first portion shows the initial state of the crates. Each crate has a lettered identifier, and they sit in stacks. Then below we see a series of commands telling us to move a certain number of crates from one stack to another.

In part 1 of the problem, the crane only moves one crate at a time. So the top crate from a stack gets moved, and then the next one is placed on top of it.

In part 2, the crane can carry many crates at once. So the crates appear in the destination stack in the same order, rather than the reverse order.

In both cases, our final output is a string formed from the top crate in each stack.

Solution Approach and Insights

After a trickier parsing phase to get our initial state, this is still essentially a folding problem, looping through the moves and modifying our stack each time. This will be our first problem this year with a post-processing step to get the string from the final crate stack.

Relevant Utilities

Once again, we'll use parsePositiveNumber from our utilities.

Parsing the Input

Let's recall the sample input:

[D]    
[N] [C]    
[Z] [M] [P]
 1   2   3 

move 1 from 2 to 1
move 3 from 1 to 3
move 2 from 2 to 1
move 1 from 1 to 2

We have two phases: the initial stack of crates and then the list of moves. We can represent these phases with two type definitions:

type CrateStacks = HashMap Int [Char]
data Move = Move
  { numCrates :: Int
  , sourceStack :: Int
  , destStack :: Int
  } deriving (Show)

type InputType = (CrateStacks, [Move])

Let's write this code from the top-down. First, our primary function breaks the parsing into these two parts:

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  crateStack <- parseCrateStack
  eol
  moves <- sepEndBy1 parseMove eol
  return (crateStack, moves)

parseCrateStack :: (MonadLogger m) => ParsecT Void Text m CrateStacks

parseMove :: (MonadLogger m) => ParsecT Void Text m Move

Parsing the Crate Stack

Parsing the crate stack is a bit tricky because we don't know the number of columns before-hand. The small sample has 3, the larger sample has 9. Also, we have to factor in empty spaces on stacks. We'll make it so that we parse each crate as a Maybe value, so that we're always getting the same number of items for each line of input.

So at a high level, we have three steps:

Parse the crate lines as a list of Maybe Char values.
Parse the column numbers line and ignore it.
Build our initial mapping of crate stacks based on the nested list of crate identifiers.

Continuing our top-down approach, we make the following definitions for this 3-step process:

parseCrateStack :: (MonadLogger m) => ParsecT Void Text m CrateStacks
parseCrateStack = do
  crateLines <- sepEndBy1 parseCrateLine eol
  parseCrateNumbers
  lift $ buildCrateStack (reverse crateLines)

parseCrateLine :: (MonadLogger m) => ParsecT Void Text m [Maybe Char]

buildCrateStack :: (MonadLogger m) => [[Maybe Char]] -> m CrateStacks

To parse the crate lines, we first write a parser for the Maybe Char. Either we have the character within brackets or we have three blank spaces.

parseCrateChar :: (MonadLogger m) => ParsecT Void Text m (Maybe Char)
parseCrateChar = crate <|> noCrate
  where
    crate = do
      char '['
      c <- letterChar
      char ']'
      return $ Just c
    noCrate = string "   " >> return Nothing

Now we parse a full line with sepEndBy1, only using a blank space as our separator instead of eol like we often do with this helper.

parseCrateLine :: (MonadLogger m) => ParsecT Void Text m [Maybe Char]
parseCrateLine = sepEndBy1 parseCrateChar (char ' ')

Next, we parse the column numbers line. We don't actually need the numbers, so this is easy:

parseCrateNumbers :: (MonadLogger m) => ParsecT Void Text m ()
parseCrateNumbers = void $ some (digitChar <|> char ' ') >> eol

Then building our initial CrateStacks hash map is done with nested folds. The inner fold adds a single crate to a single stack. If it's Nothing, of course we return the original.

addCrate :: CrateStacks -> (Int, Maybe Char) -> CrateStacks
addCrate prev (_, Nothing) = prev
addCrate prev (i, Just c) =
  let prevStackI = fromMaybe [] (HM.lookup i prev)
  in  HM.insert i (c : prevStackI) prev

Then here's how we do the nested looping. Notice the enumeration with zip [1,2..] to assign indices to each crate value for the stack number.

buildCrateStack :: (MonadLogger m) => [[Maybe Char]] -> m CrateStacks
buildCrateStack crateLines = return $ foldl addCrateLine HM.empty crateLines
  where
    addCrateLine :: CrateStacks -> [Maybe Char] -> CrateStacks
    addCrateLine prevStacks lineChars = foldl addCrate prevStacks (zip [1,2..] lineChars)

And now we've filled in all the gaps for parsing the stack itself. But we still have to parse the numbers!

Parsing Moves

There's nothing too hard with parsing each Move line. Just a combination of strings and numbers:

parseMove :: (MonadLogger m) => ParsecT Void Text m Move
parseMove = do
  string "move "
  numCrates <- parsePositiveNumber
  string " from "
  sourceIndex <- parsePositiveNumber
  string " to "
  destIndex <- parsePositiveNumber
  return $ Move numCrates sourceIndex destIndex

Getting the Solution

We can still follow the general folding solution approach that worked for the first few problems. Only now instead of tracking an accumulated value, we're tracking the state of our CrateStacks.

type EasySolutionType = CrateStacks

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (stacks, moves) = solveFold stacks moves

solveFold :: (MonadLogger m) => CrateStacks -> [Move] -> m EasySolutionType
solveFold = foldM foldLine

type FoldType = CrateStacks

foldLine :: (MonadLogger m) => FoldType -> Move -> m FoldType

The foldLine function will perform the move, shifting crates from one stack to another. To start this process, we need the current state of the "source" and "destination" stacks. If the source stack is empty, we'll log an error, but return the previous state.

foldLine :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldLine crateStacks (Move num src dst) = do
  let sourceStack = fromMaybe [] (HM.lookup src crateStacks)
      destStack = fromMaybe [] (HM.lookup dst crateStacks)
  if null sourceStack
    then logErrorN ("Tried to pull from empty stack: " <> (pack . show $ src)) >> return crateStacks
    else ...

Assuming we actually have crates to pull, all we have to do is perform nested updates to our hash map. We get the new value in the "source" stack by using drop num. Then to update the destination stack, we take num from the source, reverse them, and append to the front of the existing destination stack.

foldLine :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldLine crateStacks (Move num src dst) = do
  let sourceStack = fromMaybe [] (HM.lookup src crateStacks)
      destStack = fromMaybe [] (HM.lookup dst crateStacks)
  if null sourceStack
    then logErrorN ("Tried to pull from empty stack: " <> (pack . show $ src)) >> return crateStacks
    else do
      return $ HM.insert dst (reverse (take num sourceStack) ++ destStack) (HM.insert src (drop num sourceStack) crateStacks)

Applying this function over all our moves will give us our final stack state!

Part 2

Part 2 is identical, except that we do not reverse the crates at the final step.

foldLineHard :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldLineHard crateStacks (Move num s d) = do
  let sourceStack = fromMaybe [] (HM.lookup s crateStacks)
      destStack = fromMaybe [] (HM.lookup d crateStacks)
  if null sourceStack
    then logErrorN ("Tried to pull from empty stack: " <> (pack . show $ s)) >> return crateStacks
    else do
      {- Do not reverse the stack! -}
      return $ HM.insert d (take num sourceStack ++ destStack) (HM.insert s (drop num sourceStack) crateStacks)

Answering the Question

We have to do some post-processing once we've applied the moves. We need to find the top character in each stack. This isn't too bad. First we get the items out of our hash map and sort them by the index.

type EasySolutionType = CrateStacks

findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe String)
findEasySolution crateStacks = do
  let sortedResults = sort (HM.toList crateStacks)
  return $ Just $ map safeHead (snd <$> sortedResults)

We want to get the top character, but it's good to define a "safe" function to return an empty character in case we end up with an empty list. Then we can just take the "head" from every stack!

findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe String)
findEasySolution crateStacks = do
  let sortedResults = sort (HM.toList crateStacks)
  return $ Just $ map safeHead (snd <$> sortedResults)

safeHead :: [Char] -> Char
safeHead [] = ' '
safeHead (c : _) = c

And now to tie everything together, our top-level solve functions use 3-steps instead of 2 for the first time.

solveEasy :: FilePath -> IO (Maybe String)
solveEasy fp = runStdoutLoggingT $ do
  -- 1. Parse Input
  input <- parseFile parseInput fp
  -- 2. Process input to get final stack state
  result <- processInputEasy input
  -- 3. Get "answer" from final stack state
  findEasySolution result

solveHard :: FilePath -> IO (Maybe String)
solveHard fp = runStdoutLoggingT $ do
  -- 1. Parse Input
  input <- parseFile parseInput fp
  -- 2. Process input to get final stack state
  result <- processInputHard input
  -- 3. Get "answer" from final stack state
  findEasySolution result

Just note that we can use the same findEasySolution for part 2. And that's all the code we need! Definitely a heftier solution than days 1-4. So we'll see how the challenges keep developing!

Video

YouTube Link

James Bowen 12/4/22 James Bowen 12/4/22

Day 4 - Overlapping Ranges

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

For today's problem, our elf friends are dividing into pairs and cleaning sections of the campsite. Each individual elf is then assigned a range of sections of the campsite to clean. Our goal is to figure out redundant work.

In part 1, we want to calculate the number of pairs where one range is fully contained within the other. In part 2, we'll figure out how many pairs of ranges have any overlap.

Relevant Utilities

We'll be parsing a lot of numbers for this puzzle, so we'll need a handy function for that. Here's parsePositiveNumber:

parsePositiveNumber :: (Monad m) => ParsecT Void Text m Int
parsePositiveNumber = read <$> some digitChar

Parsing the Input

Now let's look at the sample input:

2-4,6-8
2-3,4-5
5-7,7-9
2-8,3-7
6-6,4-6
2-6,4-8

Again, we parse this line-by-line. And each line just consists of a few numbers interspersed with other characters.

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput =
  sepEndBy1 parseLine eol

type InputType = [LineType]
type LineType = ((Int, Int), (Int, Int))

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
  a1 <- parsePositiveNumber
  char '-'
  a2 <- parsePositiveNumber
  char ','
  b1 <- parsePositiveNumber
  char '-'
  b2 <- parsePositiveNumber
  return ((a1, a2), (b1, b2))

Getting the Solution

In part 1, we count the number of lines where one range fully contains another. In the example above, these two lines satisfy this condition:

2-8,3-7
6-6,4-6

So we start with a function to evaluate this:

rangeFullyContained :: ((Int, Int), (Int, Int)) -> Bool
rangeFullyContained ((a1, a2), (b1, b2)) =
  a1 <= b1 && a2 >= b2 ||
  b1 <= a1 && a2 <= b2

And now we use the same folding pattern that's served us for the last couple days! If the condition is satisfied, we add one to the previous score, otherwise no change.

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy = foldM foldLine initialFoldV

type FoldType = Int

initialFoldV :: FoldType
initialFoldV = 0

foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prev range = if rangeFullyContained range
  then return $ prev + 1
  else return prev

Part 2

Part 2 is virtually identical, only with a different condition. In the above example, here are the examples with any overlap in the ranges:

5-7,7-9
2-8,3-7
6-6,4-6
2-6,4-8

So here's our new condition:

rangePartiallyContained :: ((Int, Int), (Int, Int)) -> Bool
rangePartiallyContained ((a1, a2), (b1, b2)) = if a1 <= b1
  then b1 <= a2 
  else a1 <= b2

And the application of this condition is virtually identical to part 1.

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard = foldM foldPart2 0

findHardSolution :: (MonadLogger m) => HardSolutionType -> m (Maybe Int)
findHardSolution _ = return Nothing

foldPart2 :: (MonadLogger m) => Int -> LineType -> m Int
foldPart2 prev range = if rangePartiallyContained range
  then return $ prev + 1
  else return prev

Answering the Question

Nothing has changed from our previous examples in terms of post-processing.

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

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

And this means we're done!

Video

YouTube Link

James Bowen 12/3/22 James Bowen 12/3/22

Day 3 - Rucksacks and Badges

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Today's problem is essentially a deduplication problem. Each input line is a series of letters. For part 1, we're deduplicating within lines, finding one character that is in both sides of the word. For part 2, we're dividing the inputs into groups of 3, and then finding the only letter common to all three strings.

To "answer the question", we have to provide a "score" for each of the unique characters. The lowercase letters get the scores 1-26. Uppercase letters get the scores 27-52. Then we'll take the sum of the scores from each line or group.

Solution Approach and Insights

This is quite straightforward if you know your list library functions! We'll use filter, elem, chunksOf and nub!

Parsing the Input

Here's a sample input

vJrwpWtwJgWrhcsFMMfFFhFp
jqHRNqRjqzjGDLGLrsFMfFZSrLrFZsSL
PmmdzqPrVvPwwTWBwg
wMqvLMZHhHMvwLHjbvcjnnSBnvTQFn
ttgJtRGJQctTZtZT
CrZsJsPPZsGzwwsLwLmpwMDw
```:

Nothing tricky about the parsing code, since it's all just strings with only letters!

```haskell
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eol

type InputType = [LineType]
type LineType = String

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = some letterChar

Getting the Solution

We'll start with our scoring function. Of course, we'll use the ord function to turn each character into its ASCII number. By then we have to subtract the right amount so that lowercase 'a' (ASCII 97) gets a score of 1 and uppercase 'A' (ASCII 65) gets the score of 27:

scoreChar :: Char -> Int
scoreChar c = if isUpper c
  then ord c - 38
  else ord c - 96

The rest of the solution involves the same folding pattern from Day 2. As a reminder, here's the setup code (I'll omit this in future examples):

solveFold :: (MonadLogger m) => [LineType] -> m EasySolutionType
solveFold = foldM foldLine initialFoldV

type FoldType = Int

initialFoldV :: FoldType
initialFoldV = 0

foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine = ...

So the only challenge is filling out the folding function. First, we divide our word into the first half and the second half.

foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prevScore inputLine = ...
  where
    compartmentSize = length inputLine `quot` 2
    (firstHalf, secondHalf) = splitAt compartmentSize inputLine

Then we find the only character in both halves by filtering the first half based on being an elem of the second half. We also use nub to get rid of duplicates. We break this up with a case statement. If there's only one (as we expect), then we'll take its score and add it to the previous score. Otherwise we'll log an error message and return the previous score.

foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prevScore inputLine = do
  case charsInBoth of
    [c] -> return (prevScore + scoreChar c)
    cs -> logErrorN ("Invalid chars in both sides! " <> (pack . show $ cs)) >> return prevScore
  where
    compartmentSize = length inputLine `quot` 2
    (firstHalf, secondHalf) = splitAt compartmentSize inputLine
    charsInBoth = nub $ filter (`elem` secondHalf) firstHalf

And that's all for part 1!

Part 2

For part 2, we want to divide the input lines into groups of 3, and then find the common letter among them. Once again, we use a fold that starts with chunksOf to divide our input into groups of 3.

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard allLines = foldM foldHard 0 (chunksOf 3 allLines)

foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard = ...

With this function, we first make sure we have exactly 3 strings.

foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard prevScore [s1, s2, s3] = ...
foldHard prevScore inputs = logErrorN ("Invalid inputs (should be size 3) " <> (pack . show $ inputs)) >> return prevScore

Now for the primary case, we do the same thing as before, only we filter s1 based on s2. Then we filter that result with s3 and do the same nub trick.

foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard prevScore [s1, s2, s3] = ...
  where
    s1AndS2 = filter (`elem` s2) s1
    all3 = nub $ filter (`elem` s3) s1AndS2

And we conclude with the same process as before. Log an error if we don't get the right outputs, otherwise add the score for the character.

foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard prevScore [s1, s2, s3] = do
  case all3 of
    [c] -> logErrorN ("Found " <> (pack [c]) <> " with score " <> (pack . show $ scoreChar c)) >> return (prevScore + scoreChar c)
    cs -> logErrorN ("Invalid chars in all 3 ! " <> (pack . show $ cs)) >> return prevScore
  where
    s1AndS2 = filter (`elem` s2) s1
    all3 = nub $ filter (`elem` s3) s1AndS2

Answering the Question

As with the past couple days, we don't have any more work to do after processing the input:

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

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

And this gives us our answer!

Video

YouTube Link

James Bowen 12/2/22 James Bowen 12/2/22

Day 2 - Rock, Paper, Scissors

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

In today's problem, we're playing Rock-Paper-Scissors (RPS). Given a series of rounds of RPS play, we're supposed to evaluate the total "score" we get depending on what we've played. Inputs are line-by-line with two characters on each line:

A Y
B X
C Z

The first character always tells us what the opponent plays in that match - A = Rock, B = Paper, C = Scissors.

In the first part of the problem, the second character simply tells us what figure we should play (X = Rock, Y = Paper, Z = Scissors). In the second part of the problem, this character actually tells us the result we are trying to achieve - X = Loss, Y = Draw, Z = Win.

In both cases, our final solution is to calculate our total score over all the rounds, tabulated as follows:

6 points are given for a win, 3 for a draw, and 0 for a loss.
Then we get a certain number of points for the figure we played - 1 for Rock, 2 for Paper, and 3 for Scissors.

So for part 1, the simple 3-line inputs gives the following results:

Round 1: Play paper (2 points) against rock. Win (6 points)
Round 2: Play rock (1 point) against paper. Lose (0 points)
Round 3: Play scissors (3 points) against scissors. Draw (3 points)

Adding up all the points gives a total of 15.

For part 2, we get the following sequence by trying to match the results:

Round 1: Draw (3 points) against rock by playing rock (1 point)
Round 2: Lose (0 points) against paper by playing rock (1 point)
Round 3: Win (6 points) against scissors by playing rock (1 point)

This gives a total of 12 points.

Solution Approach and Insights

This problem follows the simple and common "fold line-by-line" solution approach. I have some pre-planned boilerplate in my solution template for this! The folding action is not hard here - we just have to evaluate the result of the match and score it appropriately.

Parsing the Input

So remember, our sample input looks like this:

A Y
B X
C Z

I started with an RPS type for the three possible figures we can playing:

data RPS = Rock | Paper | Scissors
  deriving (Show, Eq)

So we parse one of the figures using alternatives:

parseRPS :: ParsecT Void Text m RPS
parseRPS = parseRock <|> parsePaper <|> parseScissors
  where
    parseRock = (char 'A' <|> char 'X') >> return Rock
    parsePaper = (char 'B' <|> char 'Y') >> return Paper
    parseScissors = (char 'C' <|> char 'Z') >> return Scissors

So we can parse a single line by taking two of these figures with a space between. In my template, I have a generic LineType alias to use both while parsing and folding over lines. In our case, each line is two of these RPS values.

type LineType = (RPS, RPS)

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
  first <- parseRPS
  char ' '
  second <- parseRPS
  return (first, second)

Then our final input uses the very common sepEndBy1 ... eol pattern. We use another alias for InputType here.

type InputType = [LineType]

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eol

As a final wrinkle, we'll make a separate type for part 2, because the letters represent something semantically different. We won't change the parser. We'll just write a translation function to use later.

data ExpectedResult = Loss | Draw | Win
  deriving (Show, Eq)

rpsToResult :: RPS -> ExpectedResult
rpsToResult Rock = Loss
rpsToResult Paper = Draw
rpsToResult Scissors = Win

translate :: (RPS, RPS) -> (RPS, ExpectedResult)
translate (first, second) = (first, rpsToResult second)

Getting the Easy Solution

As I mentioned above, this problem fits a common pattern: fold our inputs line-by-line and accumulate a solution. I'll use some more generic types and values to outline this approach.

solveFold :: (MonadLogger m) => [LineType] -> m EasySolutionType
solveFold = foldM foldLine initialFoldV

type FoldType = Int

initialFoldV :: FoldType
initialFoldV = 0

foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine = ...

We're tracking a score, so the FoldType that we're modifying with each step is just an Int, and we give the initial value of 0. Solving the problem is as simple as applying foldM with a proper folding function and the initial value. The only challenge is filling in foldLine. For this, we need two scoring functions, one for the figure we choose (scoreRps) and another for the outcome of the match, which just requires looking at each case:

scoreRps :: RPS -> Int
scoreRps Rock = 1
scoreRps Paper = 2
scoreRps Scissors = 3

evalMatch :: (RPS, RPS) -> Int
evalMatch (Rock, Rock) = 3
evalMatch (Rock, Paper) = 6
evalMatch (Rock, Scissors) = 0
evalMatch (Paper, Rock) = 0
evalMatch (Paper, Paper) = 3
evalMatch (Paper, Scissors) = 6
evalMatch (Scissors, Rock) = 6
evalMatch (Scissors, Paper) = 0
evalMatch (Scissors, Scissors) = 3

And our fold simply applies both these to the input and adds to the previous result!

foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prevScore (first, second) = return $ prevScore + (evalMatch (first, second) + scoreRps second)

Getting the "Hard" Solution

For part 2, all we really need is to translate each input pair so it has an ExpectedResult, and then use a different evaluation function. Here's how we evaluate each pair:

evalMatchHard :: (RPS, ExpectedResult) -> Int
evalMatchHard (Rock, Win) = 8      -- Play Paper (2 + 6)
evalMatchHard (Rock, Draw) = 4     -- Play Rock (1 + 3)
evalMatchHard (Rock, Loss) = 3     -- Play Scissors (3 + 0)
evalMatchHard (Paper, Win) = 9     -- Play Scissors (3 + 6)
evalMatchHard (Paper, Draw) = 5    -- Play Paper (2 + 3)
evalMatchHard (Paper, Loss) = 1    -- Play Rock (1 + 0)
evalMatchHard (Scissors, Win) = 7  -- Play Rock (1 + 6)
evalMatchHard (Scissors, Draw) = 6 -- Play Scissors (3 + 3)
evalMatchHard (Scissors, Loss) = 2 -- Play Paper (2 + 0)

And we fold over the inputs like so:

type HardSolutionType = EasySolutionType -- < Int

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = foldM foldExpResult initialFoldV (map translate inputs)

foldExpResult :: (MonadLogger m) => Int -> (RPS, ExpectedResult) -> m Int
foldExpResult prevScore (oppPlay, result) = return $ prevScore + evalMatchHard (oppPlay, result)

Answering the Question

No further work is needed beyond passing our inputs to our functions and taking the result:

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

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

-- Note: These functions are the same, since nothing extra was required in processing!
processInputEasy = solveFold

Now we're done!

Video

Link to YouTube

James Bowen 12/1/22 James Bowen 12/1/22

Day 1 - Intro Problem

As a reminder, these writeups won't be super detailed, since I have to do one every day. I'll try to focus on the key ideas though, and I'll always link to my code!

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

This year we're dealing with elves. Each elf is carrying some snack items with a certain number of calories. Our input has one calorie count per line, and an empty line denotes that we have reached the end of one elf's snack collection and started another.

For the first part, we just want to find the elf with the most calories. This is the 4th elf, with a total of 24000 calories (7000+8000+9000).

For the second part, we want the sum of calories from the three elves with the most. So we take the 24000 from the elf with the most, and add the 3rd elf (11000 calories) and the 5th elf (10000 calories). This gives a total of 45000.

Full Description

Solution Approach and Insights

Nothing complicated here. Once we parse into list-of-lists-of-ints, we just use map sum and either take the maximum or the sum of the top 3.

Relevant Utilities

Function parseFile

Parsing the Input

Here's our parsing code. One nuance...I needed to add an extra empty line to the given inputs in order to make this parse work. Dealing with empty line separators is a little tricky with megaparsec (or at least I haven't mastered the right pattern yet), because the "chunk separator" is the same as the "line separator" within each chunk (eol parser).

parseInput :: (MonadLogger m) => ParsecT Void Text m [[Int]]
parseInput =
  sepEndBy1 parseIntLines eol
  where
    parseIntLines = some parseIntLine
    parseIntLine = do
      i <- parsePositiveNumber
      eol
      return i

Getting the Solution

As above, nothing complicated here. Use map sum and take the maximum.

processInputEasy :: (MonadLogger m) => [[Int]] -> m Int
processInputEasy intLists = return $ maximum (map sum intLists)

With the hard part, we sort, reverse, take 3, and then take another sum.

processInputHard :: (MonadLogger m) => [[Int]] -> m Int
processInputHard intLists = return $ sum $ take 3 $ reverse $ sort (map sum intLists)

Answering the Question

And no additional processing is needed - we have our answer! (My standard template has the answer always wrapped in Maybe to account for failure cases).

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

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

Video

YouTube Link

James Bowen 11/30/22 James Bowen 11/30/22

Advent of Code 2022!

Tomorrow is December 1st, which means that tonight (midnight Eastern American time, 9pm Pacific) is the start of Advent of Code! This is an informal, annual coding contest where you can solve one programming puzzle each day from December 1st up through Christmas on December 25th. The problems generally get more challenging as the month goes on, as you'll start needing to use more advanced data structures and solution techniques.

Last year I did Advent of Code for the first time, writing up all my solutions in Haskell (of course). This year I will be doing the contest again, and this time I plan to create more blog content as I go, rather than doing writeups way after the fact. Of course, I might not be able to do everything every day, but I'll try to keep up!

Here are all the ways I'll be trying to put my solutions out there for you to learn from (and critique!).

Code

I will push all my code to my GitHub repository, on the aoc-2022 branch. So once my solutions are done you'll be able to see them for yourself!

Writeups

I will also attempt to do daily write-ups on the blog, giving a rough descriptive outline of each solution. These won't be as detailed as the write-ups I did in the last month or so, but all the code will be there and I'll describe all the key insights and general solution approach.

Videos

I'll also be recording myself as I solve the problems so you can watch my solution process in real time. I'll post these videos to my YouTube channel. These videos will generally be unedited since I won't have time to go back through everything every day. I also won't be able to do these as much when it gets closer to Christmas as I'll be traveling and away from my recording setup. Some of these videos might have more commentary, some might have less. I haven't decided yet and it will vary from day-to-day.

Streaming

I will not have a regular streaming schedule. As much as possible, I plan to attempt to solve problems as soon as they come out, and the contest rules request that people do not stream solutions until the leaderboard (for the fastest solutions) is filled for that particular problem. This is in order to prevent someone from copying the solution and getting on the leaderboard without effort. (For what it's worth, I doubt I'll actually be fast enough to get on the leaderboard).

If I get behind on my solutions, then it's very possible I'll do some streaming sessions while I catch up. You can follow me on Twitter or on my Twitch stream to know when I'm going live!

Conclusion

I'll try to keep up and solve the problem every day and keep up with content, but life gets busy, so I can't make any guarantees! But hopefully I'll have all the solutions published by the end of the year!

I encourage you to try out the Advent of Code problems for yourself! It's a great tool for learning a new programming language (especially Haskell!).

I'll also be doing a couple newsletter updates over the course of this month, so make sure to subscribe to our mailing list to get those and stay up to date!

James Bowen 11/28/22 James Bowen 11/28/22

Black Friday Sale Ends Today!

Today is Cyber Monday, which marks the last day of our Black Friday Thanksgiving sale! This is your last chance to get the biggest deals of the year on all of our online courses here at Monday Morning Haskell!

For the rest of the day, you can get 20% off any of our courses by using the code BLACKFRIDAY22 at checkout. And you can get an extra discount (up to 30% off) if you subscribe to our monthly newsletter!

Here's one final review of our different courses.

Haskell From Scratch

This is our full-length beginners course. It will give you a full introduction to Haskell's syntax and core concepts. You'll also get the chance to start developing your Haskell problem solving skills. It's the best option if you've never written a full Haskell project before!

Course Description

Making Sense of Monads

This shorter course focuses strictly on monads and other functional structures. If monads have been a tricky subject for you in the past, hopefully this course can help you finally conquer them! The course includes two mini-projects for you to hone your skills!

Course Description

Effectful Haskell

Effectful Haskell goes a step beyond our introductory monads course. You'll learn some practical applications for advanced monadic ideas - like how to use monad classes and free monads to organize effects in your program. Effectful Haskell also includes some basic practice in deploying an application to Heroku.

Course Description

Practical Haskell

Practical Haskell is our second full-length course. Over the course of five modules, you'll build out the different layers of a full-stack application. You'll learn how to interact with a database, build a web server and develop a web frontend with Elm!

Course Description

Haskell Brain

Haskell Brain is our machine-learning course. It will teach you how to use TensorFlow in conjunction with Haskell, as well as a couple other related libraries and techniques!

Course Description

Conclusion

So don't miss out on these offers! Remember the code BLACKFRIDAY22 at checkout for 20% off, and you can subscribe to our mailing list for an ever better offer!

Later this week, we'll be back with the start of Advent of Code, so there will be a ton of new content in the next month!

James Bowen 11/26/22 James Bowen 11/26/22

Black Friday Spotlight: Haskell Brain!

Machine learning is one of the most important skills in software today. The field has typically been dominated by languages like Python (through TensorFlow and PyTorch) and R. So it's a bit frustrating for Haskell fans who want to use this awesome language as widely as possible but struggle to apply it to this critical domain.

However, there are a few tools out there that allow us to use Haskell for machine learning! Chief among these are the Haskell Tensorflow bindings. They aren't easy to use though, and there aren't many tutorials either!

The Haskell Brain seeks to fill this gap. This course will walk you through all the important questions about getting started with Haskell and TensorFlow.

What system setup is required?
How are tensors represented in Haskell?
How can I train a machine learning model with tensors?

If you're ready to start answering these questions, head to the course sales page!

For more details about what's included in the course, including FAQ, head over to our course description page.

The best part of it is that for the next few days, you can get 20% off this course through our Black Friday sale! Just use the code BLACKFRIDAY22 and checkout. If you want an even better deal of 30% off, you can subscribe to our mailing list! You'll get a special code when you sign up. So don't miss out!

James Bowen 11/25/22 James Bowen 11/25/22

Black Friday Spotlight: Practical Haskell

How do you actually do something in Haskell? A programming language is only helpful if we can use it to solve real problems. Perhaps you've written up some neat and tidy solutions to small problems with Haskell. But does the language actually have the libraries and tools to build useful programs?

The answer to this question is a resounding Yes! Not only does Haskell have useful libraries for practical problems, but the "Haskell Approach" to these problems often has clear advantages! For instance, in Haskell you can:

Write database queries that are type-safe, interoperating seamlessly with well-defined Haskell types.
Define a web server where the API is clearly laid out and defined in terms of Haskell types.
Link your Haskell types to frontend types that will populate your Web UI
Organize "effects" within your system so that the capabilities of different functions are explicitly defined and known to your program at compile-time.
Use monads to describe a test case in plan language.

These ideas can supercharge your Haskell abilities! But they aren't necessarily easy to pick up. It takes a fair amount of commitment to learn them well enough to use in your own projects.

Luckily, Monday Morning Haskell has a great tool for you to learn these skills! Our Practical Haskell Course will teach you how to build a functional application that integrates systems like databases, web servers, frontend web pages, and behavioral tests.

If this sounds like exactly what you've been looking for to rapidly improve your Haskell, head to the course page to get started!

If you're curious for more details, head to our course description page to learn about what you can expect in the course.

Don't forget, you've got a couple more days to take advantage of our Black Friday Sale! You can use the code BlackFriday22 to get 20% off any of our courses, including Practical Haskell. If you subscribe to our mailing list, you can get an even better code for 30% off! So don't miss out on those savings!

James Bowen 11/24/22 James Bowen 11/24/22

Black Friday Spotlight: Effectful Haskell!

Monads are a tricky subject. So tricky in fact, that most of the material out there about them is either a.) focused on surface level questions like "what is a monad" or b.) aimed at really abstract details like "how do monads relate to category theory". But there's not nearly as much content about how to use monads in a larger project context.

It's one thing to know what a monad is and how to write basic monadic code. But this will only give you a small amount of the power of monads! As you build more complex Haskell programs, monads can make your life a lot easier...if you know how to use them!

So how does one learn these techniques?

The answer of course, is with hands on practice. And Monday Morning Haskell has just the tool you need for that! Effectful Haskell is our short course aimed at teaching you the techniques to use monads to organize all the various effects in your system. You'll learn:

How to construct a monad that encapsulates all the various effects in your system.
How to use monad classes to perform IO actions while limiting the scope of your different functions.
How free monads can make it outrageously simple to configure and modify the behavior of your program, like changing your underlying database layer, or adding mock test effects.
And as an extra bonus, you'll also get a primer on how to deploy a Haskell application to the web using Heroku!

If this checks all the boxes for what you'd like to learn, head over to the course page to get started!

To learn more details, including FAQ, you can head to our course description page.

Since our Black Friday sale is going on, don't forget you can use the code BlackFriday22 to get 20% off all courses! This offer ends next Monday, so don't miss out!

James Bowen 11/23/22 James Bowen 11/23/22

Black Friday Spotlight: Making Sense of Monads!

There are probably a thousand blog posts, articles, and videos out there trying to teach what monads are. Some are too simple to really tell you what's going on ("A monad is like a burrito!"). Some are too complicated for anyone who isn't already well versed in abstract math ("A monad is a monoid is the category of endofunctors!").

All of them try to pass on some of the fundamental knowledge. But virtually none of them provide you with the tools you really need to use monads in your own code. For that, you need practical experience that involves writing the code yourself.

Our Making Sense of Monads course is designed to provide just that. In this course, you'll learn:

Fundamental knowledge about simpler abstract structures that will help you understand monads
How to understand monadic syntax in Haskell
How to use all of the most common monads in Haskell

And best of all, you'll get a chance to practice your skills with programming exercises, and some project-based code.

If you think this sounds like the tool you need to finally understand monads, head to the course page to get started!

If you'd like to learn more about what you can expect from the course, you can read about the course outline on this page!

And don't forget about our Black Friday sale! You can get 20% off all our courses by using the code BLACKFRIDAY22! If you subscribe to our mailing list, you'll get an even better code for 30% off, so don't miss out!

James Bowen 11/22/22 James Bowen 11/22/22

Black Friday Spotlight: Haskell From Scratch!

If you're on this site, you've probably read quite a bit about Haskell. But perhaps you've never written any of it yourself. Or maybe you tried some tutorial, and got a few lines to work. But you don't know how you would actually build a project in Haskell.

If you think it's time to change that, keep reading!

Our Haskell From Scratch Course is an awesome tool for newcomers to Haskell, focusing on all the questions you'll have when you're just starting out:

How do I build and run Haskell code?
How does Haskell's type system work?
What is a monad?
How is problem solving different in Haskell?

You'll learn about all of this and more in Haskell From Scratch. If this sounds like what you're looking for, head to the course sales page now!

If you want to know more about the course, head to this page for a more in depth outline!

Just remember, we're currently having our Black Friday sale! So you can get 20% off any of our courses by using the code BLACKFRIDAY22 when you check out. Even better, you can extend that savings to 30% when you subscribe to our mailing list! So don't miss out!

James Bowen 11/21/22 James Bowen 11/21/22

Black Friday Course Sale!

This whole blog is dedicated to helping you to learn Haskell. And learning any programming language is hard, most of all one that doesn't fit most of the conventions in other languages! While there are hours and hours of content for you to read on Monday Morning Haskell, reading alone unfortunately won't make you the best programmer you can be.

So what's actually the best way to get better at programming?

Improving at any technical skill requires commitment and hands-on experience. You have to make a purposeful investment - setting aside time and energy to this task. And you have to spend that time actually doing it, rather than simply reading about it.

And this is why Monday Morning Haskell has a diverse array of online courses to give you hands-on experience learning new Haskell concepts and writing your own code. Every course consists of video lectures paired with detailed programming exercises, usually including unit tests. Certain courses also include screencasts where you can observe certain steps of the coding process before trying them for yourself. A couple courses also have a project component where you can add your own code to something with a practical use!

These courses are great tools to take your Haskell skills to the next level, whether you're still a beginner or a more advanced Haskeller. And today is the best time to do it, because today is the start of our Black Friday Sale. All courses are available for 20% off their normal price with the code BLACKFRIDAY22. Plus, if you subscribe to our monthly mailing list, you can get an even better discount for 30% off.

Head to our courses page to take a look at our options! Over the next week, we'll spotlight each of the different courses here on the blog!

What's New?

Now perhaps you've taken one of our courses in the past and you're curious if anything's changed. And, in fact, we've made a few updates to improve your student experience!

GHC 9.0.2

All courses are now updated to use GHC 9.0.2 (generally with Stack resolver 19.24). This means they are more up to date with the latest Haskell libraries. It also is significant for students with newer MacOS hardware. Older GHC versions often can't compile on new Macs without some odd hacks. All of our courses should now work out of the box on these machines.

Zip File Delivery

Previously, our courses would always require students to get added as collaborators on a private GitHub repository before they could start coding. All course code is now also available through .zip files so you can get started right away!

Answers Branches

A common request in the past was to have reference answers available for students who got stuck. We started incorporating this for newer courses, and have now retroactively applied it to older courses as well. At the end of every module, you should be able to find a .zip file with our recommended answers in case you get stuck.

Exercise Revisions

Finally, exercise descriptions have been revised for clarity!

Conclusion

As a last note, all our courses are lifetime access and come with a 30-day refund guarantee. So don't miss out! Subscribe to the mailing list to get the maximum discount! (Or just use BLACKFRIDAY22 to get 20% off any of our courses)

James Bowen 11/17/22 James Bowen 11/17/22

Dijkstra Token Puzzle - Video Walkthrough

Today’s our final video walkthrough from Advent of Code 2021. We’re going back over the Day 23 puzzle that involved finding the optimal token path. Here’s the writeup, and here’s the code. And of course, here’s the video!

Make sure to subscribe if you’ve enjoyed these videos! We’ll have a major offer next week that’s specifically for subscribers!

Once we hit December 1st, I’ll be trying to do daily videos for this year’s Advent of Code, so stay tuned for those as well!

James Bowen 11/14/22 James Bowen 11/14/22

An Unusual Application for Dijkstra

Today will be the final write-up for a 2021 Advent of Code problem. It will also serve as a capstone for the work on Dijkstra's algorithm I did back in the summer! This problem uses Dijkstra's algorithm, but in a more unusual way! We'll be working on Day 23 from last year. And for my part, I'll say that days 21-24 were all extremely challenging, so this is one of the "final boss" puzzles!

Like our previous write-ups, this is an In-Depth walkthrough, and it's a long one! So get ready for some details! The code is available on GitHub as always so you can follow along.

Problem Statement

For this puzzle, we start with a set of tokens divided into 4 rooms with a hallway allowing them to move around.

#############
#...........#
###B#C#B#D###
  #A#D#C#A#
  #########

Our goal is to rearrange the tokens so that the A tokens are both in the first room, the B tokens are in the second room, the C tokens are in the third room, and the D tokens are in the fourth room.

#############
#...........#
###A#B#C#D###
  #A#B#C#D#
  #########

However, there are a lot of restrictions on the possible moves. First, token's can't move past each other in the hall (or rooms). If D comes out of the fourth room first, we cannot then move the A in that room anywhere to the left. It could only go to a space on the right.

#############
#.......D...#
###B#C#B#.###
  #A#D#C#A#
  #########

Next, each token can only make two moves total. It can move into the hallway once, and then into its appropriate room. It can't take a side journey into a different room to make space for other tokens to pass.

On top of this, each token spends a certain amount of "power" (or "energy") to move per space. The different tokens spend a different amount of energy:

A = 1
B = 10
C = 100
D = 1000

So from the start position, we could spend 2000 energy to move D up to the right, and then only 9 energy to move A all the way to the left side.

#############
#.A.......D.#
###B#C#B#.###
  #A#D#C#.#
  #########

Our goal is to get the desired configuration with the least amount of energy expended.

For the "harder" version of this problem, not much changes. We just have 4 tokens per room, so more maneuvering steps are required.

#############
#...........#
###B#C#B#D###
  #D#C#B#A#
  #D#B#A#C#
  #A#D#C#A#
  #########

Solution Approach

The surprising solution approach (at least I was surprised when I realized it could work), is to treat this like a graph problem. Each "state" of the puzzle represents a node in the graph. Any given state has "edges" representing transitions to future states of the puzzle. The edges are weighted by how much energy is required in the transition.

Once we view the problem in this way, the solution is simple. We apply a "shortest path" algorithm (like Dijkstra's) using the "end" state of the puzzle as the destination. We'll get the series of moves that uses the least total energy.

For example, the first starting solution would represent one node. It would have an edge to this following puzzle state, with a weight of 2000, since a D is moving two spaces.

#############
#.........D.#
###B#C#B#.###
  #A#D#C#A#
  #########

There are some potential questions about the scale of this problem. If the potential number of nodes is too high, even Dijkstra's algorithm could take too long. And if the tokens could be placed arbitrarily anywhere in the puzzle space, our upper bound might be a factorial number like 23-P-16. This would be too large.

However, as a practical matter, the solution space is much smaller than this because of the many restrictions on how tokens can actually move. So we'll end up with a solution space that is still large but not intractable.

Solution Outline

As we start to outline our solution, we need to start by considering which Dijkstra library function we'll use. In order to allow monadic actions in our functions (such as logging), we'll use dijkstraM, which has the following type signature:

dijkstraM ::
  (Monad m, Foldable f, Num cost, Ord cost, Ord state) =>
  (state -> m (f state)) ->
  (state -> state -> m cost) ->
  (state -> m bool) ->
  state ->
  m (Maybe (cost, [state]))

To make this work, we need to pick the types we'll use for state and cost. For the cost, we can rely on a simple Int. For the state, we'll create a custom GraphState type that will represent the state of the solution at a particular point in time.

data GraphState = ...

We'll expand more on exactly what information goes into this type as we go along. But now that we've defined our type, we can define the three functions that we'll use as inputs to dijkstraM:

getNeighbors :: (MonadLogger m) => GraphState -> m [GraphState]
getCost :: (MonadLogger m) => GraphState -> GraphState -> m Int
isComplete :: (MonadLogger m) => GraphState -> m Bool

We can (and will) add at least one more argument to partially apply, but still, this lets us outline what a full invocation of the function might look like:

solution :: (MonadLogger m) => GraphState -> m (Maybe (Int, [GraphState])
solution initialState = dijkstraM getNeighbors getCost isComplete initialState

Completeness Check

So now let's start filling in these functions. We'll start with the completeness check, since that's the easiest. Because this check is run fairly often, we want to make it as quick as possible. So instead of doing a full completeness check on the state each time we call it, we'll store a specific field in the graph state called roomsFull.

data GraphState = GraphState
  { roomsFull :: Int -- Initially 0, increments when we finish a room
  ...
  }

This field will be 0 when we initialize the state, and whenever we "complete" a room in our search path, we'll bump the number up. Checking for completeness then is as simple as checking that we've completed all 4 rooms.

isComplete :: (MonadLogger m) => GraphState -> m Bool
isComplete gs = return (roomsFull gs == 4)

Cost

It would be more convenient to combine the cost with the neighbors function, like in dijkstraAssoc. But we don't have this option if we want to use a monad. Calculating the cost between two raw graph states would be a little tricky, since we'd have to go through a lot of cases to see what has actually changed.

However, it gets easier if we include the "last move" as part of the GraphState type. So let's start defining what a Move looks like. To start, we'll include a NoMove constructor for the initial position, and we'll make a note that the GraphState will include this field.

data Move =
  NoMove |
  ...

data GraphState = GraphState
  { lastMove :: Move
  , roomsFull :: Int
  ...
  }

So how do we describe a move? Because the rules are so constrained, we can be sure every move has the following:

A particular token that is moving.
A particular "hall space" that it is moving to or from.
A particular "room" that it is moving to or from.

Each of these concepts is easily enumerated, so let's make some Enum types that are also indexable (we'll see why soon):

data Token = A | B | C | D
  deriving (Show, Eq, Ord, Enum, Ix)

data Room = RA | RB | RC | RD
  deriving (Show, Eq, Ord, Enum, Ix)

-- Can never occupy spaces above the room like H3, H5, H7, H9
data HallSpace = H1 | H2 | H4 | H6 | H8 | H10 | H11
  deriving (Show, Eq, Ord, Enum, Ix)

Now we can describe the Move constructor with these three items, as well as two more pieces of data. First, an Int paired with the room describing the "slot" of the room involved. For example, the top "slot" of a room would be 1, the space below it would be 2, and so on. Finally, we'll include a Bool telling us if the move is leaving the room (True) or entering the room (False). This won't be necessarily for calculations, but it helps with debugging.

data Move =
  NoMove |
  Move Token HallSpace (Room, Int) Bool
  deriving (Show, Eq, Ord)

So what is the cost of a move? We have to calculate the distance, and we have to know the power multiplier. So let's make two constant arrays that we'll reference. First, let's match each token to its multiplier:

tokenPower :: A.Array Token Int
tokenPower = A.array (A, D) [(A, 1), (B, 10), (C, 100), (D, 1000)]

Now we want to match each pair of "hall space" and "room" with a distance measurement. This tells us how many moves it takes to get from the hall space to the space above the room. For example, the first hall space requires 2 moves to get to room A and 4 to get to room B, while the second space only requires 1 and 3 moves, respectively:

hallRoomDistance :: A.Array (HallSpace, Room) Int
hallRoomDistance = A.array ((H1, RA), (H11, RD))
  [ ((H1, RA), 2), ((H1, RB), 4), ((H1, RC), 6), ((H1, RD), 8)
  , ((H2, RA), 1), ((H2, RB), 3), ((H2, RC), 5), ((H2, RD), 7)
  ...
  ]

Here's what the complete array looks like:

hallRoomDistance :: A.Array (HallSpace, Room) Int
hallRoomDistance = A.array ((H1, RA), (H11, RD))
  [ ((H1, RA), 2), ((H1, RB), 4), ((H1, RC), 6), ((H1, RD), 8)
  , ((H2, RA), 1), ((H2, RB), 3), ((H2, RC), 5), ((H2, RD), 7)
  , ((H4, RA), 1), ((H4, RB), 1), ((H4, RC), 3), ((H4, RD), 5)
  , ((H6, RA), 3), ((H6, RB), 1), ((H6, RC), 1), ((H6, RD), 3)
  , ((H8, RA), 5), ((H8, RB), 3), ((H8, RC), 1), ((H8, RD), 1)
  , ((H10, RA), 7), ((H10, RB), 5), ((H10, RC), 3), ((H10, RD), 1)
  , ((H11, RA), 8), ((H11, RB), 6), ((H11, RC), 4), ((H11, RD), 2)
  ]

Now calculating the cost is fairly straightforward. We get the distance to the room, add the slot within the room, and then multiply this by the power multiplier.

getCost :: (MonadLogger m) => GraphState -> GraphState -> m Int
getCost _ gs = if lastMove gs == NoMove
  then return 0
  else do
    let (Move token hs (rm, slot) _) = lastMove gs
    let mult = tokenPower A.! token
    let distance = slot + hallRoomDistance A.! (hs, rm)
    return $ mult * distance

Finishing the Graph State

Our solution is starting to take on a bit more shape, but we need to complete our GraphState type before we can make further progress. But now armed with the notion of a Token, we can fill in the remaining fields that describe it. Each room has a list of tokens that are currently residing there. And then each hall space either has a token there or not, so we have Maybe Token fields for them.

data GraphState = GraphState
  { lastMove :: Move
  , roomsFull :: Int
  , roomA :: [Token]
  , roomB :: [Token]
  , roomC :: [Token]
  , roomD :: [Token]
  , hall1 :: Maybe Token
  , hall2 :: Maybe Token
  , hall4 :: Maybe Token
  , hall6 :: Maybe Token
  , hall8 :: Maybe Token
  , hall10 :: Maybe Token
  , hall11 :: Maybe Token
  }
  deriving (Show, Eq, Ord)

Sometimes it will be useful for us to access parts of the state in a general way. We might want a function to access "one of the rooms" or "one of the hall spaces". Some day, I might revise my solution to use proper Haskell "Lenses", which would be ideal for this problem. But for now we'll define a couple simple type aliases for a RoomLens to access the tokens in a general room, and a HallLens for looking at a general hall space.

type RoomLens = GraphState -> [Token]
type HallLens = GraphState -> Maybe Token

One last piece of boilerplate we'll want will be to have "split lists" for each room. Each of these is a tuple of two lists. The first list is the hall spaces to the "left" of that room, and the second has the hall spaces to the "right" of the room.

These lists will help us answer questions like, "how many empty hall spaces can we move to from this room moving left?", or "what is the first token to the right of this room?" For these to be useful, each hall space should also include the "lens" into the GraphState, so we can examine what token lives there.

For example, room A has H2 and H1 to its left (in that order), and then H4, H6, H8, H10 and H11 to its right. We'll match each HallSpace with its HallLens, so H1 combines with the hall1 field from GraphState, and so on.

aSplits :: ([(HallLens, HallSpace)], [(HallLens, HallSpace)])
aSplits =
  ( [(hall2, H2), (hall1, H1)]
  , [(hall4, H4), (hall6, H6), (hall8, H8), (hall10, H10), (hall11, H11)]
  )

Here's what the rest of those look like:

bSplits :: ([(HallLens, HallSpace)], [(HallLens, HallSpace)])
bSplits =
  ( [(hall4, H4), (hall2, H2), (hall1, H1)]
  , [(hall6, H6), (hall8, H8), (hall10, H10), (hall11, H11)]
  )

cSplits :: ([(HallLens, HallSpace)], [(HallLens, HallSpace)])
cSplits =
  ( [(hall6, H6), (hall4, H4), (hall2, H2), (hall1, H1)]
  , [(hall8, H8), (hall10, H10), (hall11, H11)]
  )

dSplits :: ([(HallLens, HallSpace)], [(HallLens, HallSpace)])
dSplits =
  ( [(hall8, H8), (hall6, H6), (hall4, H4), (hall2, H2), (hall1, H1)]
  , [(hall10, H10), (hall11, H11)]
  )

It would be easy enough to use a common function with splitAt to describe all of these. But once again, we'll reference these many times throughout the solution, so using constants instead of requiring function logic could help make our code faster.

Moves from a Particular Room

Now it's time for the third and largest piece of the puzzle: calculating the "next" states, or the "neighboring" states of a particular graph state. This means determining what moves are possible from a particular position. This is a complex problem that we'll have to keep breaking down into smaller and smaller parts.

We can first observe that every move involves one room and the hallway - there are no moves from room to room. So we can divide the work by considering all the moves concerning one particular room. Then there are three cases for each room:

The room is complete; it is full of the appropriate token.
The room is empty or partially full of the appropriate token.
The room has mismatched tokens inside.

In case 1, we'll propose no moves involving this room. In case 2, we will try to find the appropriate token in the hall and bring it into the room (from either direction). In case 3, we will consider all the ways to move a token out of the room.

We'll do all this in a general function roomMoves. This function needs to know the room size, the appropriate token for the room, the appropriate lens for accessing the room, and finally, the split list corresponding to the room. This leads to a long type signature, but each parameter has its role:

roomMoves ::
  (MonadLogger m) =>
  Int ->
  Token ->
  Room ->
  RoomLens ->
  ([(HallLens, HallSpace)], [(HallLens, HallSpace)]) ->
  GraphState ->
  m [GraphState]
roomMoves rs tok rm roomLens splits gs = ...

For getNeighbors, all we have to do is invoke this function once for each room and combine the results.

getNeighbors :: (MonadLogger m) => Int -> GraphState -> m [GraphState]
getNeighbors rs gs = do
  arm <- roomMoves rs A RA roomA aSplits gs
  brm <- roomMoves rs B RB roomB bSplits gs
  crm <- roomMoves rs C RC roomC cSplits gs
  drm <- roomMoves rs D RD roomD dSplits gs
  return $ arm <> brm <> crm <> drm

Now back to roomMoves. Let's start by defining the three cases mentioned above. The first case is easy to complete.

roomMoves rs tok rm roomLens splits gs 
  | roomLens gs == replicate rs tok = return []
  | all (== tok) (roomLens gs) = ...
  | otherwise = ...

Now let's consider the second case. We want to search each direction from this room to try to find a hall space containing the matching token. We can do this with a recursive helper function. In the base case, we're out of hall spaces to search, so we return Nothing:

findX :: Token -> GraphState -> [(HallLens, HallSpace)] -> Maybe HallSpace
findX _ _ [] = Nothing
findX tok gs ((lens, space) : rest) = ...

Then there are three simple cases for what to do with the next space. If we have an instance of the token, return the space. If we have a different token, the answer is Nothing (we are blocked). If there is no token there, we continue the search recursively.

findX :: Token -> GraphState -> [(HallLens, HallSpace)] -> Maybe HallSpace
findX _ _ [] = Nothing
findX tok gs ((lens, space) : rest)
  | lens gs == Just tok = Just space
  | isJust (lens gs) = Nothing
  | otherwise = findX tok gs rest

Using our split lists, we can find the potential spaces on the left and the right by applying our findX helper.

roomMoves rs tok rm roomLens splits gs 
  | roomLens gs == replicate rs tok = return []
  | all (== tok) (roomLens gs) = do
    let maybeLeft = findX tok gs (fst splits)
        maybeRight = findX tok gs (snd splits)
        halls = catMaybes [maybeLeft, maybeRight]
        ...
  | otherwise = ...

For right now, let's just worry about constructing the Move object. Later on, we'll fill out a function to apply this move:

applyHallMove :: Int -> Token -> RoomLens -> GraphState -> Move -> GraphState

So to finish the case, we get the "slot" number to move to by considering the length of the room currently. Then we construct the Move, and apply it against our two possible outcomes.

roomMoves rs tok rm roomLens splits gs 
  | roomLens gs == replicate rs tok = return []
  | all (== tok) (roomLens gs) = do
    let maybeLeft = findX tok gs (fst splits)
        maybeRight = findX tok gs (snd splits)
        halls = catMaybes [maybeLeft, maybeRight]
        slot = rs - length (roomLens gs)
        moves = map (\h -> Move tok h (rm, slot) False) halls
    return $ map (applyHallMove rs tok roomLens gs) moves
  | otherwise = ...

Moves Out of the Room

Now let's consider the third case - moving a token out of a room. This requires finding as many consecutive "empty" hall spaces in each direction as we can. This will be another recursive helper like findX:

findEmptyHalls :: GraphState -> [(HallLens, HallSpace)] -> [HallSpace] -> [HallSpace]
findEmptyHalls _ [] accum = accum
findEmptyHalls gs ((lens, space) : rest) accum = ...

Once we hit a Just token value in the graph state, we can return our accumulated list. But otherwise we keep recursing.

findEmptyHalls :: GraphState -> [(HallLens, HallSpace)] -> [HallSpace] -> [HallSpace]
findEmptyHalls _ [] accum = accum
findEmptyHalls gs ((lens, space) : rest) accum = if isJust (lens gs) then accum
  else findEmptyHalls gs rest (space : accum)

Now we can apply this back in our roomMoves function with both sides of the splits.

roomMoves rs tok rm roomLens splits gs 
  | roomLens gs == replicate rs tok = return []
  | all (== tok) (roomLens gs) = ...
  | otherwise = do
    let (topRoom : restRoom) = roomLens gs
        halls = findEmptyHalls gs (fst splits) [] <> findEmptyHalls gs (snd splits) []
        ...

Once again then, we calculate the "slot" value and construct the new move using each of the hall spaces. Notice that the slot calculation is different. We want to subtract the length of the "rest" of the room from the room size, since this gives the appropriate slot value.

roomMoves rs tok rm roomLens splits gs 
  | roomLens gs == replicate rs tok = return []
  | all (== tok) (roomLens gs) = ...
  | otherwise = do
    let (topRoom : restRoom) = roomLens gs
        halls = findEmptyHalls gs (fst splits) [] <> findEmptyHalls gs (snd splits) []
        slot = rs - length restRoom
        moves = map (\h -> Move topRoom h (rm, slot) True) halls
    ...

Then, as before, we'll assume we have a helper to "apply" the move, and return the new graph states. Notice this time, we set the move flag as True, since the move is coming out of the room.

applyRoomMove :: GraphState -> Token -> Move -> GraphState
applyRoomMove = ...

roomMoves rs tok rm roomLens splits gs 
  | roomLens gs == replicate rs tok = return []
  | all (== tok) (roomLens gs) = ...
| otherwise = do
    let (topRoom : restRoom) = roomLens gs
        halls = findEmptyHalls gs (fst splits) [] <> findEmptyHalls gs (snd splits) []
        slot = rs - length restRoom
        moves = map (\h -> Move topRoom h (rm, slot) True) halls
    return $ map (applyRoomMove gs tok) moves

Now let's work on these two "apply" helpers. Each will take the current state and the Move and construct the new GraphState.

Applying moves

We'll start by applying the move from the room. Of course, for the NoMove case, we return the original state.

applyRoomMove :: GraphState -> Move -> GraphState
applyRoomMove gs NoMove = gs
applyRoomMove gs m@(Move token h (rm, slot) _) = ...

Now with all our new information, we'll update the GraphState in two stages, because this will require two case statements. First, we'll update the hall space to contain the moved token. We'll also place the move m into the lastMove spot.

applyRoomMove :: GraphState -> Move -> GraphState
applyRoomMove gs NoMove = gs
applyRoomMove gs m@(Move token h (rm, slot) _) =
  let gs2 = case h of
        H1 -> gs {hall1 = Just token, lastMove = m}
        H2 -> gs {hall2 = Just token, lastMove = m}
        H4 -> gs {hall4 = Just token, lastMove = m}
        H6 -> gs {hall6 = Just token, lastMove = m}
        H8 -> gs {hall8 = Just token, lastMove = m}
        H10 -> gs {hall10 = Just token, lastMove = m}
        H11 -> gs {hall11 = Just token, lastMove = m}
  in  ...

Now we need to modify the room to drop the top token. Unfortunately, we can't actually use a RoomLens argument in conjunction with record syntax updating, so this needs to be a case statement as well. With proper lenses, we could probably simplify this.

applyRoomMove :: GraphState -> Token -> Move -> GraphState
applyRoomMove gs roomToken NoMove = gs
applyRoomMove gs roomToken m@(Move token h (rm, slot) _) =
  let gs2 = case h of
        H1 -> gs {hall1 = Just token, lastMove = m}
        H2 -> gs {hall2 = Just token, lastMove = m}
        H4 -> gs {hall4 = Just token, lastMove = m}
        H6 -> gs {hall6 = Just token, lastMove = m}
        H8 -> gs {hall8 = Just token, lastMove = m}
        H10 -> gs {hall10 = Just token, lastMove = m}
        H11 -> gs {hall11 = Just token, lastMove = m}
  in  case rm of
    RA -> gs2 { roomA = tail (roomA gs)}
    RB -> gs2 { roomB = tail (roomB gs)}
    RC -> gs2 { roomC = tail (roomC gs)}
    RD -> gs2 { roomD = tail (roomD gs)}

That's all for applying a move from the room. Applying a move from the hall into the room is similar. But we have the extra task of determining if the destination room is now complete. So in this case we actually can make use of the RoomLens.

applyHallMove :: Int -> RoomLens -> GraphState -> Move -> GraphState
applyHallMove rs roomLens gs NoMove = gs
applyHallMove rs roomLens gs m@(Move token h (rm, slot) _) = ...

As before, we start by updating the hall space (now it's Nothing) and the lastMove field. We'll also update the finishedCount on this update step.

applyHallMove :: Int -> RoomLens -> GraphState -> Move -> GraphState
applyHallMove rs roomLens gs NoMove = gs
applyHallMove rs roomLens gs m@(Move token h (rm, slot) _) =
  let gs2 = case h of
        H1 -> gs {hall1 = Nothing, lastMove = m, roomsFull = finishedCount}
        H2 -> gs {hall2 = Nothing, lastMove = m, roomsFull = finishedCount}
        H4 -> gs {hall4 = Nothing, lastMove = m, roomsFull = finishedCount}
        H6 -> gs {hall6 = Nothing, lastMove = m, roomsFull = finishedCount}
        H8 -> gs {hall8 = Nothing, lastMove = m, roomsFull = finishedCount}
        H10 -> gs {hall10 = Nothing, lastMove = m, roomsFull = finishedCount}
        H11 -> gs {hall11 = Nothing, lastMove = m, roomsFull = finishedCount}
  in  ...
  where
    finishedCount = ...

How do we implement the finishedCount? It's not too difficult. We can easily assess if it's finished by checking the roomLens on the original state and seeing if it's equal to "Room Size minus 1". Then the finished count increments if this is true.

applyHallMove :: Int -> RoomLens -> GraphState -> Move -> GraphState
applyHallMove rs roomLens gs NoMove = gs
applyHallMove rs roomLens gs m@(Move token h (rm, slot) _) =
  let gs2 = case h of
        H1 -> gs {hall1 = Nothing, lastMove = m, roomsFull = finishedCount}
        H2 -> gs {hall2 = Nothing, lastMove = m, roomsFull = finishedCount}
        H4 -> gs {hall4 = Nothing, lastMove = m, roomsFull = finishedCount}
        H6 -> gs {hall6 = Nothing, lastMove = m, roomsFull = finishedCount}
        H8 -> gs {hall8 = Nothing, lastMove = m, roomsFull = finishedCount}
        H10 -> gs {hall10 = Nothing, lastMove = m, roomsFull = finishedCount}
        H11 -> gs {hall11 = Nothing, lastMove = m, roomsFull = finishedCount}
  in  ...
  where
    finished = length (roomLens gs) == rs - 1
    finishedCount = if finished then roomsFull gs + 1 else roomsFull gs

Now we do the same concluding step as the room move, except this time we're adding the token to the room instead of removing it.

applyHallMove :: Int -> RoomLens -> GraphState -> Move -> GraphState
applyHallMove rs roomLens gs NoMove = gs
applyHallMove rs roomLens gs m@(Move token h (rm, slot) _) =
  let gs2 = case h of
        H1 -> gs {hall1 = Nothing, lastMove = m, roomsFull = finishedCount}
        H2 -> gs {hall2 = Nothing, lastMove = m, roomsFull = finishedCount}
        H4 -> gs {hall4 = Nothing, lastMove = m, roomsFull = finishedCount}
        H6 -> gs {hall6 = Nothing, lastMove = m, roomsFull = finishedCount}
        H8 -> gs {hall8 = Nothing, lastMove = m, roomsFull = finishedCount}
        H10 -> gs {hall10 = Nothing, lastMove = m, roomsFull = finishedCount}
        H11 -> gs {hall11 = Nothing, lastMove = m, roomsFull = finishedCount}
  in case rm of
    RA -> gs2 {roomA = A : roomA gs}
    RB -> gs2 {roomB = B : roomB gs}
    RC -> gs2 {roomC = C : roomC gs}
    RD -> gs2 {roomD = D : roomD gs}
  where
    finished = length (roomLens gs) == rs - 1
    finishedCount = if finished then roomsFull gs + 1 else roomsFull gs

Making the Initial State

That's the conclusion of the algorithm functions; now we just need some glue, such as the initial states and pulling it all together. For the first time with our Advent of Code problems, we don't actually need to parse an input file. We could go through this process, but the "hard" input is still basically the same size, so we can just define these initial states in code.

Let's recall that our basic case looks like this:

#############
#...........#
###B#C#B#D###
  #A#D#C#A#
  #########

We'll translate it into an initial state as:

initialState1 :: GraphState
initialState1 = GraphState
  NoMove 0 [B, A] [C, D] [B, C] [D, A]
  Nothing Nothing Nothing Nothing Nothing Nothing Nothing

Our slightly harder version has the same structure, just with letters in more unusual places.

{-
#############
#...........#
###C#A#D#D###
  #B#A#B#C#
  #########
-}

initialState2 :: GraphState
initialState2 = GraphState
  NoMove 0 [C, B] [A, A] [D, B] [D, C]
  Nothing Nothing Nothing Nothing Nothing Nothing Nothing

Now for the "hard" part of the problem, we increase the room size to 4, and insert additional characters into each room. This is what those states look like.

initialState3 :: GraphState
initialState3 = GraphState
  NoMove 0 [B, D, D, A] [C, C, B, D] [B, B, A, C] [D, A, C, A]
  Nothing Nothing Nothing Nothing Nothing Nothing Nothing

initialState4 :: GraphState
initialState4 = GraphState
  NoMove 0 [C, D, D, B] [A, C, B, A] [D, B, A, B] [D, A, C, C]
  Nothing Nothing Nothing Nothing Nothing Nothing Nothing

Solving the Problem

Now we can "solve" each of the problems. Our solution code is essentially the same for each side. The "hard" part just passes 4 as the room size.

solveDay23Easy :: GraphState -> IO (Maybe Int)
solveDay23Easy gs = runStdoutLoggingT $ do
   result <- dijkstraM (getNeighbors 2) getCost isComplete gs
   case result of
    Nothing -> return Nothing
    Just (d, path) -> return $ Just d

solveDay23Hard :: GraphState -> IO (Maybe Int)
solveDay23Hard gs = runStdoutLoggingT $ do
   result <- dijkstraM (getNeighbors 4) getCost isComplete gs
   case result of
    Nothing -> return Nothing
    Just (d, path) -> return $ Just d

And now our code is complete! We can run it and the total distance. It actually turns out to require less energy for the second case in each group:

First  Size-2: 12521
Second Size-2: 10526
First  Size-4: 44169
Second Size-4: 41284

It's also possible, if we want, to print out the "path" we took by considering the moves in each state!

solveDay23Easy :: GraphState -> IO (Maybe Int)
solveDay23Easy gs = runStdoutLoggingT $ do
   result <- dijkstraM (getNeighbors 2) getCost isComplete gs
   case result of
    Nothing -> return Nothing
    Just (d, path) -> do
      forM_ path $ \gs' -> logDebugN (pack . show $ lastMove gs')
      return $ Just d

Here's the path we take for this simple version! Remember that True moves come from the room into the hall, and False moves go from the hall back into the room.

[Debug] Move D H10 (RD,1) True
[Debug] Move A H2 (RD,2) True
[Debug] Move B H4 (RC,1) True
[Debug] Move C H6 (RB,1) True
[Debug] Move C H6 (RC,1) False
[Debug] Move D H8 (RB,2) True
[Debug] Move D H8 (RD,2) False
[Debug] Move D H10 (RD,1) False
[Debug] Move B H4 (RB,2) False
[Debug] Move B H4 (RA,1) True
[Debug] Move B H4 (RB,1) False
[Debug] Move A H2 (RA,1) False

As a final note, the scale of the search is fairly large but by no means intractable. My solution doesn't give an instant answer, but it returns within a minute or so.

Conclusion

That is all for our review of Advent of Code 2021! We'll have the video walkthrough later in the week. And then in a couple weeks, we'll be ready to start Advent of Code 2022, so stay tuned for that!

If you've enjoyed these tutorials, make sure to subscribe to our mailing list! We've got a big offer coming up next week that you won't want to miss!

James Bowen 11/10/22 James Bowen 11/10/22

Zoom/Enhance Video Walkthrough

Here’s our penultimate video walkthrough from Advent of Code 2021. Earlier this week was the in-depth code writeup for your perusal. The video is here on YouTube, and here’s the code on GitHub!

If you’re enjoying this content, make sure to subscribe to our monthly newsletter! Later this month you’ll also get access to some special offers on course content!

James Bowen 11/7/22 James Bowen 11/7/22

Zoom! Enhance!

Today we'll be tackling the Day 20 problem from Advent of Code 2021. This problem is a fun take on the Zoom and Enhance cliche from TV dramas where cops and spies can always seem to get unrealistic details from grainy camera footage by "enhancing" it. We'll have a binary image and we'll need to keep applying a decoding key to expand the image.

As always, you can see all the nitty gritty details of the code at once by going to the GitHub repository I've made for these problems. If you're enjoying these in-depth walkthroughs, make sure to subscribe so you can stay up to date with the latest news.

Problem Statement

Our problem input consists of a couple sections that have "binary" data, where the . character represents 0 and the # character represents 1.

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

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

The first part (which actually would appear all on one line) is a 512 character decoding key. Why length 512? Well 512 = 2^9, and we'll see in a second why the ninth power is significant.

The second part of the input is a 2D "image", represented in binary. Our goal is to "enhance" the image using the decoding key. How do we enhance it?

To get the new value at a coordinate (x, y), we have to consider the value at that coordinate together with all 8 of its neighbors.

# . . # .
#[. . .].
#[# . .]#
.[. # .].
. . # # #

The brackets show every pixel that is involved in getting the new value at the "center" of our grid. The way we get the value is to line up these pixels in binary: ...#...#. = 000100010. Then we get the decimal value (34 in this case). This tells us new value comes from the 34th character in the decoder key, which is #. So this middle pixel will be "on" after the first expansion. Since each pixel expansion factors in 9 pixels, there are 2^9 = 512 possible values, hence the length of the decoding key.

All transformations happen simultaneously. What is noteworthy is that for "fringe" pixels we must account for the boundary outside the initial image. And in fact, our image then expands into this new region! The enhanced version of our first 5x5 image actually becomes size 7x7.

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

For the easy part, we'll do this expansion twice. For the hard part, we'll do it 50 times. Our puzzle answer is the number of pixels that are lit in the final iteration.

Solution Approach

At first glance, this problem is pretty straightforward. It's another "state evolution" problem where we take the problem in an initial state and write a function to evolve that state to the next step. Evolving a single step involves looking at the individual pixels, and applying a fairly simple algorithm to get the resulting pixel.

The ever-expanding range of coordinates is a little tricky. But if we use a structure that allows "negative" indices (and Haskell makes this easy!), it's not too bad.

But there's one BIG nuance though with how the "infinite" image works. We still have to implicitly imagine that the enhancement algorithm is applying to all the other pixels in "infinite space". You would hope that, since all those pixels are surrounded by other "off" pixels, they remain "off".

However, my "hard" puzzle input got a decoding key with # in the 0 position, meaning that "off" pixels surrounded by other "off" pixels all turn on! Luckily, the decoder also has . in the final position, meaning that these pixels turn "off" again on the next step. However, we need to account for this on/off pattern of all these "outside pixels" since they'll affect the pixels on the fringe of our solution.

To that end, we'll need to keep track of the value of outer pixels throughout our algorithm - I'll refer to this as the "outside bit". This will impact every layer of the solution!

So with that to look forward to, let's start coding!

Utilities

As always, a few utilities will benefit us. From last week's look at binary numbers, we'll use a couple helpers like the Bit type and a binary-to-decimal conversion function.

data Bit = Zero | One
  deriving (Eq, Ord)

bitsToDecimal64 :: [Bit] -> Word64

Another very useful idea is turning a nested list into a hash map. This helps simplify parsing a lot. We saw this function in the Day 11 Octopus Problem.

hashMapFromNestedLists :: [[a]] -> HashMap Coord2 a

Another idea from Day 11 was getting all 8 neighbors of a 2D coordinate. Originally, we did this with (0,0) as a hard lower bound. But we can expand this idea so that the grid bounds of the function are taken as inputs. So getNeighbors8Flex takes two additional coordinate parameters to help provide those bounds for us.

getNeighbors8Flex :: Coord2 -> Coord2 -> Coord2 -> [Coord2]
getNeighbors8Flex (minRow, minCol) (maxRow, maxCol) (row, col) = catMaybes
  [maybeUpLeft, maybeUp, maybeUpRight, maybeLeft, maybeRight, maybeDownLeft, maybeDown, maybeDownRight]
  where
    maybeUp = if row > minRow then Just (row - 1, col) else Nothing
    maybeUpRight = if row > minRow && 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 > minCol then Just (row + 1, col - 1) else Nothing
    maybeLeft = if col > minCol then Just (row, col - 1) else Nothing
    maybeUpLeft = if row > minRow && col > minCol then Just (row - 1, col - 1) else Nothing

Of particular note is the way we order the results. This ordering (top, then same row, then bottom), will allow us to easily decode our values for this problem.

Another detail for this problem is that we'll just want to use "no bounds" on the coordinates with the minimum and maximum integers as the bounds.

getNeighbors8Unbounded :: Coord2 -> [Coord2]
getNeighbors8Unbounded = getNeighbors8Flex (minBound, minBound) (maxBound, maxBound)

Last but not least, we'll also rely on this old standby, the countWhere function, to quickly get the occurrence of certain values in a list.

countWhere :: (a -> Bool) -> [a] -> Int

Inputs

Like all Advent of Code problems, we'll start with parsing our input. We need to get everything into bits, but instead of 0 and 1 characters, we're dealing with the character . for off, and # for 1. So we start with a choice parser to get a single pixel.

parsePixel :: (MonadLogger m) => ParsecT Void Text m Bit
parsePixel = choice [char '.' >> return Zero, char '#' >> return One]

Now we need a couple types to organize our values. The decoder map will tell us a particular bit for every index from 0-511. So we can use a hash map with Word64 as the key.

type DecoderMap = HashMap Word64 Bit

Furthermore, it's easy to see how we build this decoder from a list of bits with a simple zip:

buildDecoder :: [Bit] -> DecoderMap
buildDecoder input = HM.fromList (zip [0..] input)

For the image though, we have 2D data. So let's using a hash map over Coord2 for our ImageMap type:

type ImageMap = HashMap Coord2 Bit

We have enough tools to start writing our function now. We'll parse an initial series of pixels and build the decoder out of them, followed by a couple eol characters.

parseInput :: (MonadLogger m) => ParsecT Void Text m (DecoderMap, ImageMap)
parseInput = do
  decoderMap <- buildDecoder <$> some parsePixel
  eol >> eol
  ...

Now we'll get the 2D image. We'll start by getting a nested list structure using the sepEndBy1 ... eol trick we've seen so many times already.

parse2DImage :: (MonadLogger m) => ParsecT Void Text m [[Bit]]
parse2DImage = sepEndBy1 (some parsePixel) eol

Now to put it all together, we'll use our conversion function to get our map from the nested lists, and then we've got our two inputs: the DecoderMap and the initial ImageMap!

parseInput :: (MonadLogger m) => ParsecT Void Text m (DecoderMap, ImageMap)
parseInput = do
  decoderMap <- buildDecoder <$> some parsePixel
  eol >> eol
  image <- hashMapFromNestedLists <$> parse2DImage
  return (decoderMap, image)

Processing One Pixel

In terms of writing out the algorithm, we'll try a "bottom up" approach this time. We'll start by solving the smallest problem we can think of, which is this: For a single pixel, how do we calculate its new value in one step of expansion?

There are multiple ways to approach this piece, but the way I chose was to imagine this as a folding function. We'll start a new "enhanced" image as an empty map, and we'll insert the new pixels one-by-one using this folding function. So each iteration modifies a single Coord2 key of an ImageMap. We can fit this into a "fold" pattern if the end of this function's signature looks like this:

-- At some point we have HM.insert coord bit newImage
f :: ImageMap -> Coord2 -> m ImageMap
f newImage coord = ...

But we need some extra information in this function to solve the problem of which "bit" we're inserting. We'll need the original image of course, to find the pixels around this coordinate. We'll also need the decoding map once we convert these to a decimal index. Last of all, we need the "outside bit" discussed above in the solution approach. Here's a type signature to gather these together.

processPixel ::
  (MonadLogger m) =>
  DecoderMap ->
  ImageMap ->
  Bit ->
  ImageMap -> Coord2 -> m ImageMap
processPixel decoderMap initialImage bounds outsideBit newImage pixel = ...

Let's start with a helper function to get the original image's bit at a particular coordinate. Whenever we do a bit lookup outside our original image, its coordinates will not exist in the initialImage map. In this case we'll use the outside bit.

processPixel decoderMap initialImage outsideBit newImage pixel = do
  ...
  where
    getBit :: Coord2 -> Bit
    getBit coord = fromMaybe outsideBit (initialImage HM.!? coord)

Now we need to get all the neighboring coordinates of this pixel. We'll use our getNeighbors8Unbounded utility from above. We could restrict ourselves to the bounds of the original, augmented by 1, but there's no particular need. We get the bit at each location, and assert that we have indeed found all 8 neighbors.

processPixel decoderMap initialImage outsideBit newImage pixel = do
  let allNeighbors = getNeighbors8Unbounded pixel
      neighborBits = getBit <$> allNeighbors
  if length allNeighbors /= 8
    then error "Must have 8 neighbors!"
    ...
where
    getBit = ...

Now the "neighbors" function doesn't include the bit at the specific input pixel! So we have to split our neighbors and insert it into the middle like so:

processPixel decoderMap initialImage outsideBit newImage pixel = do
  let allNeighbors = getNeighbors8Unbounded pixel
      neighborBits = getBit <$> allNeighbors
  if length allNeighbors /= 8
    then error "Must have 8 neighbors!"
    else do
      let (first4, second4) = splitAt 4 neighborBits
          finalBits = first4 ++ (getBit pixel : second4)
     ...
where
    getBit = ...

Now that we have a list of 9 bits, we can decode those bits (using bitsToDecimal64 from last time). This gives us the index to look up in our decoder, which we insert into the new image!

processPixel decoderMap initialImage outsideBit newImage pixel = do
  let allNeighbors = getNeighbors8Unbounded pixel
      neighborBits = getBit <$> allNeighbors
  if length allNeighbors /= 8
    then error "Must have 8 neighbors!"
    else do
      let (first4, second4) = splitAt 4 neighborBits
          finalBits = first4 ++ (getBit pixel : second4)
          indexToDecode = bitsToDecimal64 finalBits
          bit = decoderMap HM.! indexToDecode
      return $ HM.insert pixel bit newImage
  where
    getBit :: Coord2 -> Bit
    getBit coord = fromMaybe outsideBit (initialImage HM.!? coord)

Expanding the Image

Now that we can populate the value for a single pixel, let's step back one layer of the problem and determine how to expand the full image. As mentioned above, we ultimately want to use our function above like a fold. So we need enough arguments to reduce it to:

ImageMap -> Coord2 -> m ImageMap

Then we can start with an empty image map, and loop through every coordinate. So let's make sure we include the decoder map, the original image, and the "outside bit" in our type signature to ensure we have all the processing arguments.

expandImage :: (MonadLogger m) => DecoderMap -> ImageMap -> Bit -> m ImageMap
expandImage decoderMap image outsideBit = ...

Our chief task is to determine the coordinates to loop through. We can't just use the coordinates from the original image though. We have to expand by 1 in each direction so that the outside pixels can come into play. After adding 1, we use Data.Ix.range to interpolate all the coordinates in between our minimum and maximum.

expandImage decoderMap image outsideBit = ...
  where
    (minRow, minCol) = minimum (HM.keys image)
    (maxRow, maxCol) = maximum (HM.keys image)
    newBounds = ((minRow - 1, minCol - 1), (maxRow + 1, maxCol + 1))
    allCoords = range newBounds

And now we have all the ingredients for our fold! We partially apply decoderMap, image, and outsideBit, and then use a fresh empty image and the coordinates.

expandImage decoderMap image outsideBit = foldM
  (processPixel decoderMap image outsideBit)
  HM.empty
  allCoords
  where
    (minRow, minCol) = minimum (HM.keys image)
    (maxRow, maxCol) = maximum (HM.keys image)
    newBounds = ((minRow - 1, minCol - 1), (maxRow + 1, maxCol + 1))
    allCoords = range newBounds

Running the Expansion

Now that we can expand the image once, we just have to zoom out one more layer, and run the expansion a certain number of times. We'll write a recursive function that uses the decoder map, the initial image, and an integer argument for our current step count. This will return the total number of pixels that are lit in the final image.

runExpand :: (MonadLogger m) => DecoderMap -> ImageMap -> Int -> m Int

The base case occurs when we have 0 steps remaining. We'll just count the number of elements that have the One bit in our current image.

runExpand _ image 0 = return $ countWhere (== One) (HM.elems image)

The only trick with the recursive case is that we have to determine the "outside bit". If the element corresponding to 0 in the decoder map is One, then all the outside bits will flip back and forth. So we need to check this bit, as well as the step count. For even step counts, we'll use Zero for the outside bits. And of course, if the decoder head is 0, then there's no flipping at all, so we always get Zero.

runExpand _ image 0 = return $ countWhere (== One) (HM.elems image)
runExpand decoderMap initialImage stepCount = do
  ...
  where
    outsideBit = if decoderMap HM.! 0 == Zero || even stepCount
      then Zero
      else One

Now we have all the arguments we need for our expandImage call! So let's get that new image and recurse using runExpand, with a reduced step count.

runExpand _ image 0 = return $ countWhere (== One) (HM.elems image)
runExpand decoderMap initialImage stepCount = do
  finalImage <- expandImage decoderMap initialImage outsideBit
  runExpand decoderMap finalImage (stepCount - 1)
  where
    outsideBit = if decoderMap HM.! 0 == Zero || even stepCount then Zero else One

Solving the Problem

Now we're well positioned to solve the problem. We'll parse the input into the decoder map and the first image with another old standby, parseFile. Then we'll run the expansion for 2 steps and return the number of lit pixels.

solveDay20Easy :: String -> IO (Maybe Int)
solveDay20Easy fp = runStdoutLoggingT $ do
  (decoderMap, initialImage) <- parseFile parseInput fp
  pixelsLit <- runExpand decoderMap initialImage 2
  return $ Just pixelsLit

The hard part is virtually identical, just increasing the number of steps up to 50.

solveDay20Hard :: String -> IO (Maybe Int)
solveDay20Hard fp = runStdoutLoggingT $ do
  (decoderMap, initialImage) <- parseFile parseInput fp
  pixelsLit <- runExpand decoderMap initialImage 50
  return $ Just pixelsLit

And we're done!

Conclusion

Later this week we'll have the video walkthrough! If you want to see the complete code in action, you can take a look on GitHub.

If you subscribe to our monthly newsletter, you'll get all the latest news and offers from Monday Morning Haskell, as well as access to our subscriber resources!