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.
Subscribe to Monday Morning Haskell!
Problem Overview
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 2The 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 2We 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 MoveParsing 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 Charvalues. - 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 CrateStacksTo 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 NothingNow 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 ' ') >> eolThen 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) prevThen 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 destIndexGetting 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 FoldTypeThe 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 : _) = cAnd 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 resultJust 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!
