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

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:

1. 6 points are given for a win, 3 for a draw, and 0 for a loss.
2. 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

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.

1000
2000
3000

4000

5000
6000

7000
8000
9000

10000

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

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!

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!

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.

1. What system setup is required?
2. How are tensors represented in Haskell?
3. 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!

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:

1. Write database queries that are type-safe, interoperating seamlessly with well-defined Haskell types.
2. Define a web server where the API is clearly laid out and defined in terms of Haskell types.
3. Link your Haskell types to frontend types that will populate your Web UI
4. Organize "effects" within your system so that the capabilities of different functions are explicitly defined and known to your program at compile-time.
5. 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!

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:

1. How to construct a monad that encapsulates all the various effects in your system.
2. How to use monad classes to perform IO actions while limiting the scope of your different functions.
3. 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.
4. 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!

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:

1. Fundamental knowledge about simpler abstract structures that will help you understand monads
2. How to understand monadic syntax in Haskell
3. 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!

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:

1. How do I build and run Haskell code?
2. How does Haskell's type system work?
3. What is a monad?
4. 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!

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)

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!

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:

1. A particular token that is moving.
2. A particular "hall space" that it is moving to or from.
3. 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:

1. The room is complete; it is full of the appropriate token.
2. The room is empty or partially full of the appropriate token.
3. 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!

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!

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!

Binary Packet Video Walkthrough

Here’s our 4th video walkthrough of some problems from last year’s Advent of Code. We had an in-depth code writeup back on Monday that you can check out. The video is here on YouTube, and you can also take a look at the code on GitHub!

If you’re enjoying this content, make sure to subscribe to our monthly newsletter! We’ll have some special offers coming out this month that you won’t want to miss!

Binary Packet Parsing

Today we're back with a new problem walkthrough, this time from Day 16 of last year's Advent of Code. In some sense, the parsing section for this problem is very easy - there's not much data to read from the file. In another sense, it's actually rather hard! This problem is about parsing a binary format, similar in some sense to how network packets work. It's a good exercise in handling a few different kinds of recursive cases.

As with the previous parts of this series, you can take a look at the code on GitHub here. This problem also has quite a few utilities, so you can observe those as well. This article is a deep-dive code walkthrough, so having the code handy to look at might be a good idea!

Problem Description

For this problem, we're decoding a binary packet. The packet is initially given as a hexadecimal string.

A0016C880162017C3686B18A3D4780

But we'll turn it into binary and start working strictly with ones and zeros. However, the decoding process gets complicated because the packet is structured in a recursive way. But let's go over some of the rules.

Packet Header

Every packet has a six-bit header. The first three bits give a "version number" for the packet. The next three bits give a "type ID". That part's easy.

Then there are a series of rules about the rest of the information in the packet.

Literals

If the type ID is 4, the packet is a "literal". We then parse the remainder of the packet in 5-bit chunks. The first bit tells us if it is the last chunk of the packet (0 means yes, 1 means there are more chunks). The four other bits in the chunk are used to construct the binary number that forms the "value" of the literal. The more chunks, the higher the number can be.

Operator Sizes

Packets that aren't literals are operators. This means they contain a variable number of subpackets.

Operators have one bit (after the 6-bit header) giving a "length" type. A length type of "1" tells us that the following 11 bits give the number of subpackets. If the length bit is "0", then the next 15 bits give the length of all the subpackets in bits.

The Packet Structure

We'll see how these work out as we parse them. But with this structure in mind, one thing we can immediately do is come up with a recursive data type for a packet. I ended up calling this PacketNode since I thought of each as a node in a tree. It's pretty easy to see how to do this. We start with a base constructor for a Literal packet that only stores the version and the packet value. Then we just add an Operator constructor that will have a list of subpackets as well as a field for the operator type.

data PacketNode =
  Literal Word8 Word64 |
  Operator Word8 Word8 [PacketNode]
  deriving (Show)

Once we've parsed the packet, the "questions to answer" are, for the easy part, to take the sum of all the packet versions in our packet, and then to actually calculate the packet value recursively for the hard part. When we get to that part, we'll see how we use the operators to determine the value.

Solution Approach

The initial "parsing" part of this problem is actually quite easy. But we can observe that even after we have our binary values, it's still a parsing problem! We'll have an easy enough time answering the question once we've parsed our input into a PacketNode. So the core of the problem is parsing the ones and zeros into our PacketNode.

Since this is a parsing problem, we can actually use Megaparsec for the second part, instead of only for getting the input out of the file. Here's a possible signature for our core function:

-- More on this type later
data Bit = One | Zero

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m PacketNode

Whereas we normally use Text as the second type parameter to ParsecT, we can also use any list type, and the library will know what to do! With this function, we'll eventually be able to break our solution into its different parts. But first, we should start with some useful helpers for all our binary parsing.

Binary Utilities

Binary logic comes up fairly often in Advent of Code, and there are quite a few different utilities we would want to use with these ones and zeros. We start with a data type to represent a single bit. For maximum efficiency, we'd want to use a BitVector, but we aren't too worried about that. So we'll make a simple type with two constructors.

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

instance Show Bit where
  show Zero = "0"
  show One = "1"

Our first order of business is turning a hexadecimal character into a list of bits. Hexadecimal numbers encapsulate 4 bits. So, for example, 0 should be [Zero, Zero, Zero, Zero], 1 should be [Zero, Zero, Zero, One], and F should be [One, One, One, One]. This is a simple pattern match, but we'll also have a failure case.

parseHexChar :: (MonadLogger m) => Char -> MaybeT m [Bit]
parseHexChar '0' = return [Zero, Zero, Zero, Zero]
parseHexChar '1' = return [Zero, Zero, Zero, One]
parseHexChar '2' = return [Zero, Zero, One, Zero]
parseHexChar '3' = return [Zero, Zero, One, One]
parseHexChar '4' = return [Zero, One, Zero, Zero]
parseHexChar '5' = return [Zero, One, Zero, One]
parseHexChar '6' = return [Zero, One, One, Zero]
parseHexChar '7' = return [Zero, One, One, One]
parseHexChar '8' = return [One, Zero, Zero, Zero]
parseHexChar '9' = return [One, Zero, Zero, One]
parseHexChar 'A' = return [One, Zero, One, Zero]
parseHexChar 'B' = return [One, Zero, One, One]
parseHexChar 'C' = return [One, One, Zero, Zero]
parseHexChar 'D' = return [One, One, Zero, One]
parseHexChar 'E' = return [One, One, One, Zero]
parseHexChar 'F' = return [One, One, One, One]
parseHexChar c = logErrorN ("Invalid Hex Char: " <> pack [c]) >> mzero

If we wanted, we could also include lowercase, but this problem doesn't require it.

We also want to be able to turn a list of bits into a decimal number. We'll do this for a couple different sizes of numbers. For smaller numbers (8 bits or below), we might want to return a Word8. For larger numbers we can do Word64. Calculating the decimal number is a tail recursive process, where we track the accumulated sum and the current power of 2.

bitsToDecimal8 :: [Bit] -> Word8
bitsToDecimal8 bits = if length bits > 8
  then error ("Too long! Use bitsToDecimal64! " ++ show bits)
  else btd8 0 1 (reverse bits)
    where
      btd8 :: Word8 -> Word8 -> [Bit] -> Word8
      btd8 accum _ [] = accum
      btd8 accum mult (b : rest) = case b of
        Zero -> btd8 accum (mult * 2) rest
        One -> btd8 (accum + mult) (mult * 2) rest

bitsToDecimal64 :: [Bit] -> Word64
bitsToDecimal64 bits = if length bits > 64
  then error ("Too long! Use bitsToDecimalInteger! " ++ (show $ bits))
  else btd64 0 1 (reverse bits)
    where
      btd64 :: Word64 -> Word64 -> [Bit] -> Word64
      btd64 accum _ [] = accum
      btd64 accum mult (b : rest) = case b of
        Zero -> btd64 accum (mult * 2) rest
        One -> btd64 (accum + mult) (mult * 2) rest

Last of all, we should write a parser for reading a hexadecimal string from our file. This is easy, because Megaparsec already has a parser for a single hexadecimal character.

parseHexadecimal :: (MonadLogger m) => ParsecT Void Text m String
parseHexadecimal = some hexDigitChar

Basic Bit Parsing

With all these utilities in place, we can get started with parsing our list of bits. As mentioned above, we want a function that generally looks like this:

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m PacketNode

However, we need one extra nuance. Because we have one layer that will parse several consecutive packets based on the number of bits parsed, we should also return this number as part of our function. In this way, we'll be able to determine if we're done with the subpackets of an operator packet.

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m (PacketNode, Word64)

We'll also want a wrapper around this function so we can call it from a normal context with the list of bits as the input. This looks a lot like the existing utilities (e.g. for parsing a whole file). We use runParserT from Megaparsec and do a case-branch on the result.

parseBits :: (MonadLogger m) => [Bit] -> MaybeT m PacketNode
parseBits bits = do
  result <- runParserT parsePacketNode "Utils.hs" bits
  case result of
    Left e -> logErrorN ("Failed to parse: " <> (pack . show $ e)) >> mzero
    Right (packet, _) -> return packet

We ignore the "size" of the parsed packet in the primary case, but we'll use its result in the recursive calls to parsePacketNode!

Having done this, we can now start writing basic parser functions. To parse a single bit, we'll just wrap the anySingle combinator from Megaparsec.

parseBit :: ParsecT Void [Bit] m Bit
parseBit = anySingle

If we want to parse a certain number of bits, we'll want to use the monadic count combinator. Let's write a function that parses three bits and turns it into a Word8, since we'll need this for the packet version and type ID.

parse3Bit :: ParsecT Void [Bit] m Word8
parse3Bit = bitsToDecimal8 <$> count 3 parseBit

We can then immediately use this to start filling in our parsing function!

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m (PacketNode, Word64)
parsePacketNode = do
  packetVersion <- parse3Bit
  packetTypeId <- parse3Bit
  ...

Then the rest of the function will depend upon the different cases we might parse.

Parsing a Literal

We can start with the "literal" case. This parses the "value" contained within the packet. We need to track the number of bits we parse so we can use this result in our parent function!

parseLiteral :: ParsecT Void [Bit] m (Word64, Word64)

As explained above, we examine chunks 5 bits at a time, and we end the packet once we have a chunk that starts with 0. This is a "while" loop pattern, which suggests tail recursion as our solution!

We'll have two accumulator arguments. First, the series of bits that contribute to our literal value. Second, the number of bits we've parsed so far (which must include the signal bit).

parseLiteral :: ParsecT Void [Bit] m (Word64, Word64)
parseLiteral = parseLiteralTail [] 0
  where
    parseLiteralTail :: [Bit] -> Word64 -> ParsecT Void [Bit] m (Word64, Word64)
    parseLiteralTail accumBits numBits = do
      ...

First, we'll parse the leading bit, followed by the four bits in the chunk value. We append these to our previously accumulated bits, and add 5 to the number of bits parsed:

parseLiteral :: ParsecT Void [Bit] m (Word64, Word64)
parseLiteral = parseLiteralTail [] 0
  where
    parseLiteralTail :: [Bit] -> Word64 -> ParsecT Void [Bit] m (Word64, Word64)
    parseLiteralTail accumBits numBits = do
      leadingBit <- parseBit
      nextBits <- count 4 parseBit
      let accum' = accumBits ++ nextBits
      let numBits' = numBits + 5
      ...

If the leading bit is 0, we're done! We can return our value by converting our accumulated bits to decimal. Otherwise, we recurse with our new values.

parseLiteral :: ParsecT Void [Bit] m (Word64, Word64)
parseLiteral = parseLiteralTail [] 0
  where
    parseLiteralTail :: [Bit] -> Word64 -> ParsecT Void [Bit] m (Word64, Word64)
    parseLiteralTail accumBits numBits = do
      leadingBit <- parseBit
      nextBits <- count 4 parseBit
      let accum' = accumBits ++ nextBits
      let numBits' = numBits + 5
      if leadingBit == Zero
        then return (bitsToDecimal64 accum', numBits')
        else parseLiteralTail accum' numBits'

Then it's very easy to incorporate this into our primary function. We check the type ID, and if it's "4" (for a literal), we call this function, and return with the Literal packet constructor.

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m (PacketNode, Word64)
parsePacketNode = do
  packetVersion <- parse3Bit
  packetTypeId <- parse3Bit
  if packetTypeId == 4
    then do
      (literalValue, literalBits) <- parseLiteral
      return (Literal packetVersion literalValue, literalBits + 6)
    else
      ...

Now we need to consider the "operator" cases and their subpackets.

Parsing from Number of Packets

We'll start with the simpler of these two cases, which is when we are parsing a specific number of subpackets. The first step, of course, is to parse the length type bit.

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m (PacketNode, Word64)
parsePacketNode = do
  packetVersion <- parse3Bit
  packetTypeId <- parse3Bit
  if packetTypeId == 4
    then do
      (literalValue, literalBits) <- parseLiteral
      return (Literal packetVersion literalValue, literalBits + 6)
    else do
      lengthTypeId <- parseBit
      if lengthTypeId == One
        then do
        ...

First, we have to count out 11 bits and use that to determine the number of subpackets. Once we have this number, we just have to recursively call the parsePacketNode function the given number of times.

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m (PacketNode, Word64)
parsePacketNode = do
 ...
  if packetTypeId == 4
    then ...
    else do
      lengthTypeId <- parseBit
      if lengthTypeId == One
        then do
          numberOfSubpackets <- bitsToDecimal64 <$> count 11 parseBit
          subPacketsWithLengths <- replicateM (fromIntegral numberOfSubpackets) parsePacketNode
         ...

We'll unzip these results to get our list of packets and the lengths. To get our final packet length, we take the sum of the sizes, but we can't forget to add the header bits and the length type bit (7 bits), and the bits from the number of subpackets (11).

parsePacketNode :: (MonadLogger m) => ParsecT Void [Bit] m (PacketNode, Word64)
parsePacketNode = do
 ...
  if packetTypeId == 4
    then ...
    else do
      lengthTypeId <- parseBit
      if lengthTypeId == One
        then do
          numberOfSubpackets <- bitsToDecimal64 <$> count 11 parseBit
          subPacketsWithLengths <- replicateM (fromIntegral numberOfSubpackets) parsePacketNode
         let (subPackets, lengths) = unzip subPacketsWithLengths
          return (Operator packetVersion packetTypeId subPackets, sum lengths + 7 + 11)
        else

Parsing from Number of Bits

Parsing based on the number of bits in all the subpackets is a little more complicated, because we have more state to track. As we loop through the different subpackets, we need to keep track of how many bits we still have to parse. So we'll make a separate helper function.

parseForPacketLength :: (MonadLogger m) => Int -> Word64 -> [PacketNode] -> ParsecT Void [Bit] m ([PacketNode], Word64)
parseForPacketLength remainingBits accumBits prevPackets = ...

The base case comes when we have 0 bits remaining. Ideally, this occurs with exactly 0 bits. If it's a negative number, this is a problem. But if it's successful, we'll reverse the accumulated packets and return the number of bits we've accumulated.

parseForPacketLength :: (MonadLogger m) => Int -> Word64 -> [PacketNode] -> ParsecT Void [Bit] m ([PacketNode], Word64)
parseForPacketLength remainingBits accumBits prevPackets = if remainingBits <= 0
  then do
    if remainingBits < 0
      then error "Failing"
      else return (reverse prevPackets, accumBits)
  else ...

In the recursive case, we make one new call to parsePacketNode (the original function, not this helper). This gives us a new packet, and some more bits that we've parsed (this is why we've been tracking that number the whole time). So we can subtract the size from the remaining bits, and add it to the accumulated bits. And then we'll make the actual recursive call to this helper function.

parseForPacketLength :: (MonadLogger m) => Int -> Word64 -> [PacketNode] -> ParsecT Void [Bit] m ([PacketNode], Word64)
parseForPacketLength remainingBits accumBits prevPackets = if remainingBits <= 0
  then do
    if remainingBits < 0
      then error "Failing"
      else return (reverse prevPackets, accumBits)
  else do
    (newPacket, size) <- parsePacketNode
    parseForPacketLength (remainingBits - fromIntegral size) (accumBits + fromIntegral size) (newPacket : prevPackets)

And that's all! All our different pieces fit together now and we're able to parse our packet!

Solving the Problems

Now that we've parsed the packet into our structure, the rest of the problem is actually quite easy and fun! We've created a straightforward recursive structure, and so we can loop through it in a straightforward recursive way. We'll just always use the Literal as the base case, and then loop through the list of packets for the base case.

Let's start with summing the packet versions. This will return a Word64 since we could be adding a lot of package versions. With a Literal package, we just immediately return the version.

sumPacketVersions :: PacketNode -> Word64
sumPacketVersions (Literal v _) = fromIntegral v
...

Then with operator packets, we just map over the sub-packets, take the sum of their versions, and then add the original packet's version.

sumPacketVersions :: PacketNode -> Word64
sumPacketVersions (Literal v _) = fromIntegral v
sumPacketVersions (Operator v _ packets) = fromIntegral v +
  sum (map sumPacketVersions packets)

Now, for calculating the final packet value, we again start with the Literal case, since we'll just return its value. Note that we'll do this monadically, since we'll have some failure conditions in the later parts.

calculatePacketValue :: MonadLogger m => PacketNode -> MaybeT m Word64
calculatePacketValue (Literal _ x) = return x

Now, for the first time in the problem, we actually have to care what the operators mean! Here's a summary of the first few operators:

0 = Sum of all subpackets
1 = Product of all subpackets
2 = Minimum of all subpackets
3 = Maximum of all subpackets

There are three other operators following the same basic pattern. They expect exactly two subpackets and perform a binary, boolean operator. If it is true, the value is 1. If the operation is false, the packet value is 0.

5 = Greater than operator (<)
6 = Less than operator (>)
7 = Equals operator (==)

For the first set of operations, we can recursively calculate the value of the sub-packets, and take the appropriate aggregate function over the list.

calculatePacketValue :: MonadLogger m => PacketNode -> MaybeT m Word64
calculatePacketValue (Literal _ x) = return x
calculatePacketValue (Operator _ 0 packets) = sum <$> mapM calculatePacketValue packets
calculatePacketValue (Operator _ 1 packets) = product <$> mapM calculatePacketValue packets
calculatePacketValue (Operator _ 2 packets) = minimum <$> mapM calculatePacketValue packets
calculatePacketValue (Operator _ 3 packets) = maximum <$> mapM calculatePacketValue packets
...

For the binary operations, we first have to verify that there are only two packets.

calculatePacketValue :: MonadLogger m => PacketNode -> MaybeT m Word64
...
calculatePacketValue (Operator _ 5 packets) = do
  if length packets /= 2
    then logErrorN "> operator '5' must have two packets!" >> mzero
    else ...

Then we just de-structure the packets, calculate each value, compare them, and then return the appropriate value.

calculatePacketValue :: MonadLogger m => PacketNode -> MaybeT m Word64
...
calculatePacketValue (Operator _ 5 packets) = do
  if length packets /= 2
    then logErrorN "> operator '5' must have two packets!" >> mzero
    else do
      let [p1, p2] = packets
      v1 <- calculatePacketValue p1
      v2 <- calculatePacketValue p2
      return (if v1 > v2 then 1 else 0)
calculatePacketValue (Operator _ 6 packets) = do
  if length packets /= 2
    then logErrorN "< operator '6' must have two packets!" >> mzero
    else do
      let [p1, p2] = packets
      v1 <- calculatePacketValue p1
      v2 <- calculatePacketValue p2
      return (if v1 < v2 then 1 else 0)
calculatePacketValue (Operator _ 7 packets) = do
  if length packets /= 2
    then logErrorN "== operator '7' must have two packets!" >> mzero
    else do
      let [p1, p2] = packets
      v1 <- calculatePacketValue p1
      v2 <- calculatePacketValue p2
      return (if v1 == v2 then 1 else 0)
calculatePacketValue p = do
  logErrorN ("Invalid packet! " <> (pack . show $ p))
  mzero

Concluding Code

To tie everything together, we just follow the steps.

1. Parse the hexadecimal from the file
2. Transform the hexadecimal string into a list of bits
3. Parse the packet
4. Answer the question

For the first part, we use sumPacketVersions on the resulting packet.

solveDay16Easy :: String -> IO (Maybe Int)
solveDay16Easy fp = runStdoutLoggingT $ do
  hexLine <- parseFile parseHexadecimal fp
  result <- runMaybeT $ do
    bitLine <- concatMapM parseHexChar hexLine
    packet <- parseBits bitLine
    return $ sumPacketVersions packet
  return (fromIntegral <$> result)

And the "hard" solution is the same, except we use calculatePacketValue instead.

solveDay16Hard :: String -> IO (Maybe Int)
solveDay16Hard fp = runStdoutLoggingT $ do
  hexLine <- parseFile parseHexadecimal fp
  result <- runMaybeT $ do
    bitLine <- concatMapM parseHexChar hexLine
    packet <- parseBits bitLine
    calculatePacketValue packet
  return (fromIntegral <$> result)

And we're done!

Conclusion

That's all for this solution! As always, you can take a look at the code on GitHub. Later this week I'll have the video walkthrough as well. To keep up with all the latest news, make sure to subscribe to our monthly newsletter! Subscribing will give you access to our subscriber resources, like our Beginners Checklist and our Production Checklist.

Polymer Expansion Video Walkthrough

Earlier this week I did a write-up of the Day 14 Problem from Advent of Code 2021. Today, I’m releasing a video walkthrough that you can watch here on YouTube!

If you’re enjoying this content, make sure to subscribe to our monthly newsletter! This will give you access to our subscriber resources!

Polymer Expansion

Today we're back with another Advent of Code walkthrough. We're doing the problem from Day 14 of last year. Here are a couple previous walkthroughs:

1. Day 8 (Seven Segment Display)
2. Day 11 (Octopus Energy Levels)

If you want to see the code for today, you can find it here on GitHub!

If you're enjoying these problem overviews, make sure to subscribe to our monthly newsletter!

Problem Statement

The subject of today's problem is "polymer expansion". What this means in programming terms is that we'll be taking a string and inserting new characters into it based on side-by-side pairs.

The puzzle input looks like this:

NNCB

NN -> C
NC -> B
CB -> H
...

The top line of the input is our "starter string". It's our base for expansion. The lines that follow are codes that explain how to expand each pair of characters.

So in our original string of four characters (NNCB), there are three pairs: NN, NC, and CB. With the exception of the start and end characters, each character appears in two different pairs. So for each pair, we find the corresponding "insertion character" and construct a new string where all the insertion characters come between their parent pairs. The first pair gives us a C, the second pair gives us a new B, and the third pair gets us a new H.

So our string for the second step becomes: NCNBCHB. We'll then repeat the expansion a certain number of times.

For the first part, we'll run 10 steps of the expansion algorithm. For the second part, we'll do 40 steps. Each time, our final answer comes from taking the number of occurrences of the most common letter in the final string, and subtracting the occurrences of the least common letter.

Utilities

The main utility we'll end up using for this problem is an occurrence map. I decided to make this general idea for counting the number of occurrences of some item, since it's such a common pattern in these puzzles. The most generic alias we could have is a map where the key and value are parameterized, though the expectation is that i is an Integral type:

type OccMapI a i = Map a i

The most common usage is counting items up from 0. Since this is an unsigned, non-negative number, we would use Word.

type OccMap a = Map a Word

However, for today's problem, we're gonna be dealing with big numbers! So just to be safe, we'll use the unbounded Integer type, and make a separate type definition for that.

type OccMapBig a = Map a Integer

We can make a couple useful helper functions for this occurrence map. First, we can add a certain number value to a key.

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

We can add a specialization of this for "incrementing" a key, adding 1 to its value. We won't use this for today's solution, but it helps in a lot of cases.

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

Now with our utilities out of the way, let's start parsing our input!

Parsing the Input

First off, let's define the result types of our parsing process. The starter string comes on the first line, so that's a separate String. But then we need to create a mapping between character pairs and the resulting character. We'll eventually want these in a HashMap, so let's make a type alias for that.

type PairMap = HashMap (Char, Char) Char

Now for parsing, we need to parse the start string, an empty line, and then each line of the code mapping.

Since most of the input is in the code mapping lines, let's do that first. Each line consists of parsing three characters, just separated by the arrow. This is very straightforward with Megaparsec.

parsePairCode :: (MonadLogger m) => ParsecT Void Text m (Char, Char, Char)
parsePairCode = do
  input1 <- letterChar
  input2 <- letterChar
  string " -> "
  output <- letterChar
  return (input1, input2, output)

Now let's make a function to combine these character tuples into the map. This is a nice quick fold:

buildPairMap :: [(Char, Char, Char)] -> HashMap (Char, Char) Char
buildPairMap = foldl (\prevMap (c1, c2, c3) -> HM.insert (c1, c2) c3 prevMap) HM.empty

The rest of our parsing function then parses the starter string and a couple newline characters before we get our pair codes.

parseInput :: (MonadLogger m) => ParsecT Void Text m (String, PairMap)
parseInput = do
  starterCode <- some letterChar
  eol >> eol
  pairCodes <- sepEndBy1 parsePairCode eol
  return (starterCode, buildPairMap pairCodes)

Then it will be easy enough to use our parseFile function from previous days. Now let's figure out our solution approach.

A Naive Approach

Now at first, the polymer expansion seems like a fairly simple problem. The root of the issue is that we have to write a function to run one step of the expansion. In principle, this isn't a hard function. We loop through the original string, two letters at a time, and gradually construct the new string for the next step.

One way to handle this would be with a tail recursive helper function. We could accumulate the new string (in reverse) through an accumulator argument.

runExpand :: (MonadLogger m)
  => PairMap
  -> String -- Accumulator
  -> String -- Remaining String
  -> m String

The "base case" of this function is when we have only one character left. In this case, we append it to the accumulator and reverse it all.

runExpand :: (MonadLogger m) => PairMap -> String -> String -> m String
runExpand pairMap accum [lastChar] = return $ reverse (lastChar : accum)

For the recursive case, we imagine we have at least two characters remaining. We'll look these characters up in our map. Then we'll append the first character and the new character to our accumulator, and then recurse on the remainder (including the second character).

runExpand :: (MonadLogger m) => PairMap -> String -> String -> m String
runExpand _ accum [lastChar] = return $ reverse (lastChar : accum)
runExpand pairMap accum (firstChar: secondChar : rest) = do
  let insertChar = pairMap HM.! (nextChar, secondChar)
  runExpand pairMap (insertChar : firstChar : accum) (secondChar : rest)

There are some extra edge cases we could handle here, but this isn't going to be how we solve the problem. The approach works...in theory. In practice though, it only works for a small number of steps. Why? Well the problem description gives a hint: This polymer grows quickly. In fact, with each step, our string essentially doubles in size - exponential growth!

This sort of solution is good enough for the first part, running only 10 steps. However, as the string gets bigger and bigger, we'll run out of memory! So we need something more efficient.

A Better Approach

The key insight here is that we don't actually care about the order of the letters in the string at any given time. All we really need to think about is the number of each kind of pair that is present. How does this work?

Well recall some of our basic code pairs from the top:

NN -> C
NC -> B
CB -> H
BN -> B

With the starter string like NNCB, we have one NN pair, an NC pair, and CB pair. In the next step, the NN pair generates two new pairs. Because a C is inserted between the N, we lose the NN pair but gain a NC pair and a CN pair. So after expansion the number of resulting NC pairs is 1, and the number of CN pairs is 1.

However, this is true of every NN pair within our string! Suppose we instead start off this with:

NNCBNN

Now there are two NN pairs, meaning the resulting string will have two NC pairs and two CN pairs, as you can see by taking a closer look at the result: NCNBCHBBNCN.

So instead of keeping the complete string in memory, all we need to do is use the "occurrence map" utility to store the number of each pair for our current state. So we'll keep folding over an object of type OccMapBig (Char, Char).

The first step of our solution then is to construct our initial mapping from the starter code. We can do this by folding through the starter string in a similar way to the example code in the naive solution. We one or zero characters are left in our "remainder", that's a base case and we can return the map.

-- Same signature as naive approach
expandPolymerLong :: (MonadLogger m) => Int -> String -> PairMap -> m (Maybe Integer)
expandPolymerLong numSteps starterCode pairMap = do
  let starterMap = buildInitialMap M.empty starterCode
  ...
  where
    buildInitialMap :: OccMapBig (Char, Char) -> String -> OccMapBig (Char, Char)
    buildInitialMap prevMap "" = prevMap
    buildInitialMap prevMap [_] = prevMap
   ...

Now for the recursive case, we have at least two characters remaining, so we'll just increment the value for the key formed by these characters!

-- Same signature as naive approach
expandPolymerLong :: (MonadLogger m) => Int -> String -> PairMap -> m (Maybe Integer)
expandPolymerLong numSteps starterCode pairMap = do
  let starterMap = buildInitialMap M.empty starterCode
  ...
  where
    buildInitialMap :: OccMapBig (Char, Char) -> String -> OccMapBig (Char, Char)
    buildInitialMap prevMap "" = prevMap
    buildInitialMap prevMap [_] = prevMap
    buildInitialMap prevMap (firstChar : secondChar : rest) = buildInitialMap (incKey prevMap (firstChar, secondChar)) (secondChar : rest)

The key point, of course, is how to expand our map each step, so let's do this next!

A New Expansion

To run a single step in our naive solution, we could use a tail-recursive helper to gradually build up the new string (the "accumulator") from the old string (the "remainder" or "rest"). So our type signature looked like this:

runExpand :: (MonadLogger m)
  => PairMap
  -> String -- Accumulator
  -> String -- Remainder
  -> m String

For our new expansion step, we're instead taking one occurrence map and transforming it into a new occurrence map. For convenience, we'll include an integer argument keeping track of which step we're on, but we won't need to use it in the function. We'll do all this within expandPolymerLong so that we have access to the PairMap argument.

expandPolymerLong :: (MonadLogger m) => Int -> String -> PairMap -> m (Maybe Integer)
expandPolymerLong numSteps starterCode pairMap = do
  ...
  where
    runStep ::(MonadLogger m) => OccMapBig (Char, Char) -> Int -> m (OccMapBig (Char, Char))
    runStep = ...

The runStep function has a simple idea behind it though. We gradually reconstruct our occurrence map by folding through the pairs in the previous map. We'll make a new function runExpand to act as the folding function.

expandPolymerLong :: (MonadLogger m) => Int -> String -> PairMap -> m (Maybe Integer)
expandPolymerLong numSteps starterCode pairMap = do
  ...
  where
    runStep ::(MonadLogger m) => OccMapBig (Char, Char) -> Int -> m (OccMapBig (Char, Char))
    runStep prevMap _ = foldM runExpand M.empty (M.toList prevMap)

    runExpand :: (MonadLogger m) => OccMapBig (Char, Char) -> ((Char, Char), Integer) -> m (OccMapBig (Char, Char))
    runExpand = ...

For this function, we begin by looking up the two-character code in our map. If for whatever reason it doesn't exist, we'll move on, but it's worth logging an error message since this isn't supposed to happen.

runExpand :: (MonadLogger m) => OccMapBig (Char, Char) -> ((Char, Char), Integer) -> m (OccMapBig (Char, Char))
runExpand prevMap (code@(c1, c2), count) = case HM.lookup code pairMap of
  Nothing -> logErrorN ("Missing Code: " <> pack [c1, c2]) >> return prevMap
  Just newChar -> ...

Now once we've found the new character, we'll create our first new pair and our second new pair by inserting the new character with our previous characters.

runExpand :: (MonadLogger m) => OccMapBig (Char, Char) -> ((Char, Char), Integer) -> m (OccMapBig (Char, Char))
runExpand prevMap (code@(c1, c2), count) = case HM.lookup code pairMap of
  Nothing -> logErrorN ("Missing Code: " <> pack [c1, c2]) >> return prevMap
  Just newChar -> do
    let first = (c1, newChar)
        second = (newChar, c2)
  ...

And to wrap things up, we add the new count value for each of our new keys to the existing map! This is done with nested calls to addKey on our occurrence map.

runExpand :: (MonadLogger m) => OccMapBig (Char, Char) -> ((Char, Char), Integer) -> m (OccMapBig (Char, Char))
runExpand prevMap (code@(c1, c2), count) = case HM.lookup code pairMap of
  Nothing -> logErrorN ("Missing Code: " <> pack [c1, c2]) >> return prevMap
  Just newChar -> do
    let first = (c1, newChar)
        second = (newChar, c2)
  return $ addKey (addKey prevMap first count) second count

Rounding Up

Now we have our last task: finding the counts of the characters in the final string, and subtracting the minimum from the maximum. This requires us to first disassemble our mapping of pair counts into a mapping of individual character counts. This is another fold step. But just like before, we use nested calls to addKey on an occurrence map! See how countChars works below:

expandPolymerLong :: (MonadLogger m) => Int -> String -> PairMap -> m (Maybe Integer)
expandPolymerLong numSteps starterCode pairMap = do
  let starterMap = buildInitialMap M.empty starterCode
  finalOccMap <- foldM runStep starterMap [1..numSteps]
  let finalCharCountMap = foldl countChars M.empty (M.toList finalOccMap)
  ...
  where
    countChars :: OccMapBig Char -> ((Char, Char), Integer) -> OccMapBig Char
    countChars prevMap ((c1, c2), count) = addKey (addKey prevMap c1 count) c2 count

So we have a count of the characters in our final string...sort of. Recall that we added characters for each pair. Thus the number we're getting is basically doubled! So we want to divide each value by 2, with the exception of the first and last characters in the string. If these are the same, we have an edge case. We divide the number by 2 and then add an extra one. Otherwise, if a character has an odd value, it must be on the end, so we divide by two and round up. We sum up this logic with the quotRoundUp function, which we apply over our finalCharCountMap.

expandPolymerLong :: (MonadLogger m) => Int -> String -> PairMap -> m (Maybe Integer) expandPolymerLong numSteps starterCode pairMap = do let starterMap = buildInitialMap M.empty starterCode finalOccMap <- foldM runStep starterMap [1..numSteps] let finalCharCountMap = foldl countChars M.empty (M.toList finalOccMap) let finalCounts = map quotRoundUp (M.toList finalCharCountMap) ... where quotRoundUp :: (Char, Integer) -> Integer quotRoundUp (c, i) = if even i then quot i 2 + if head starterCode == c && last starterCode == c then 1 else 0 else quot i 2 + 1

And finally, we consider the list of outcomes and take the maximum minus the minimum!

```haskell
expandPolymerLong :: (MonadLogger m) => Int -> String -> PairMap -> m (Maybe Integer)
expandPolymerLong numSteps starterCode pairMap = do
  let starterMap = buildInitialMap M.empty starterCode
  finalOccMap <- foldM runStep starterMap [1..numSteps]
  let finalCharCountMap = foldl countChars M.empty (M.toList finalOccMap)
  let finalCounts = map quotRoundUp (M.toList finalCharCountMap)
  if null finalCounts
    then logErrorN "Final Occurrence Map is empty!" >> return Nothing
    else return $ Just $ fromIntegral (maximum finalCounts - minimum finalCounts)

  where
    buildInitialMap = ...
    runStep = ...
    runExpand = ...
    countChars = ...
    quotRoundUp = ...

Last of all, we combine input parsing with solving the problem. Our "easy" and "hard" solutions look the same, just with different numbers of steps.

solveDay14Easy :: String -> IO (Maybe Integer)
solveDay14Easy fp = runStdoutLoggingT $ do
  (starterCode, pairCodes) <- parseFile parseInput fp
  expandPolymerLong 10 starterCode pairCodes

solveDay14Hard :: String -> IO (Maybe Integer)
solveDay14Hard fp = runStdoutLoggingT $ do
  (starterCode, pairCodes) <- parseFile parseInput fp
  expandPolymerLong 40 starterCode pairCodes

Conclusion

Hopefully that solution makes sense to you! In case I left anything out of my solution, you can peruse the code on GitHub. Later this week, we'll have a video walkthrough of this solution!

If you're enjoying this content, make sure to subscribe to our monthly newsletter, which will also give you access to our Subscriber Resources!

Dijkstra Video Walkthrough

Today I’m taking a really quick break from Advent of Code videos to do a video walkthrough of Dijkstra’s algorithm! I did several written walkthroughs of this algorithm a couple months ago:

1. Basic Algorithm

2. Generalizing with a Typeclass

3. Generalizing with Type Families

4. Applying to a 2D Grid

5. Comparing to the Library Function

6. Using a Monad

However, I never did a video walkthrough on my YouTube channel, and a viewer specifically requested one, so here it is today!

If you enjoyed that video, make sure to subscribe to our monthly newsletter so you can stay up to date on our latest content! This will also give you access to our subscriber resources!