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:

  1. Parse the crate lines as a list of Maybe Char values.
  2. Parse the column numbers line and ignore it.
  3. 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

Previous
Previous

Day 6 - Parsing Unique Characters

Next
Next

Day 4 - Overlapping Ranges