AoC 2022: The End!

I've completed the final two video walkthroughs of problems from Advent of Code 2022! You can view them on my YouTube Channel, or find links to all solutions on our summary page.

Day 24 is the final graph problem, one that involves a couple clever optimizations. See the video here, or you can read a written summary as well.

And last of all, Day 25 introduces us to the concept of balanced quinary. Quinary is a number system like binary or ternary, but in the balanced form, characters range for (-2) to 2 instead of 0 to 4. This final video is on YouTube here, or you can read the write-up.

I promise there will be more problem-solving related content later this year! If these videos and walkthroughs have helped you improve your skills, make sure to subscribe to our monthly newsletter so you stay up to date!

3 More Advent of Code Videos!

I'm almost done with the Advent of Code recap videos. This week you can now find the reviews for Days 21, 22, and 23 by going to my YouTube Channel. As a reminder, you can find links to all Advent of Code solutions on this page.

Day 21 featured a recursive variable tree problem. See the video here or read the write-up.

Day 22 started out as an innocuous 2D maze traversal problem, but ended up being waaay more complicated in part 2, which puts your geometry skills to the test and forces some very precise programming. Watch the recap or read about it.

Finally, Day 23 was the final state evolution problem. Our elf friends want to plant a grove of trees, so they would like to spread out in an optimal fashion. Here's the video, and here's the blog post.

If these recaps have helped you improve your Haskell problem solving skills, make sure the subscribe to our monthly newsletter! We'll have a lot more problem-solving content throughout the year, so stay tuned for that!

Advent of Code: Fetching Puzzle Input using the API

When solving Advent of Code problems, my first step is always to access the full puzzle input and copy it into a file on my local system. This doesn't actually take very long, but it's still fun to see how we can automate it! In today's article, we'll write some simple Haskell code to make a network request to find this data.

We'll write a function that can take a particular year and day (like 2022 Day 5), and save the puzzle input for that day to a file that the rest of our code can use.

As a note, there's a complete Advent of Code API that allows you to do much more than access the puzzle input. You can submit your input, view leaderboards, and all kinds of other things. There's an existing Haskell library for all this, written in 2019. But we'll just be writing a small amount of code from scratch in this article, rather than using this library.

Authentication

In order to get the puzzle input for a certain day, you must be authenticated with Advent of Code. This typically means logging in with GitHub or another service. This saves a session cookie in your browser that is sent with every request you make to the site.

Our code needs to access this cookie somehow. It's theoretically possible to do this in an automated way by accessing your browser's data. For this example though, I found it easier to just copy the session token manually and save it as an environment variable. The token doesn't change as long as you don't log out, so you can keep reusing it.

This GitHub issue gives a good explanation with images for how to access this token using a browser like Google Chrome. At a high level, these are the steps:

1. Log in to Advent of Code and access and puzzle input page (e.g. http://adventofcode.com/2022/day/1/input)
2. Right click the page and click "inspect"
3. Navigate to the "Network" tab
4. Click on any request, and go to the "Headers" tab
5. Search through the "Request Headers" for a header named cookie.
6. You should find one value that starts with session=, followed by a long string of hexadecimal characters. Copy the whole value, starting with session= and including all the hex characters until you hit a semicolon.
7. Save this value as an environment variable on your system using the name AOC_TOKEN.

The rest of the code will assume you have this session token (starting with the string session=) saved as the variable AOC_TOKEN in your environment. So for example, on my Windows Linux subsystem, I have a line like this in my .bashrc:

export AOC_TOKEN="session=12345abc..."

We're now ready to start writing some code!

Caching

Now before we jump into any shenanigans with network code, let's first write a caching function. All this will do is see if a specified file already exists and has data. We don't want to send unnecessary network requests (the puzzle input never changes), so once we have our data locally, we can short circuit our process.

So this function will take our FilePath and just return a boolean value. We first ensure the file exists.

checkFileExistsWithData :: FilePath -> IO Bool
checkFileExistsWithData fp = do
  exists <- doesFileExist fp
  if not exists
    then return False
    ...

As long as the file exists, we'll also ensure that it isn't empty.

checkFileExistsWithData :: FilePath -> IO Bool
checkFileExistsWithData fp = do
  exists <- doesFileExist fp
  if not exists
    then return False
    else do
      size <- getFileSize fp
      return $ size > 0

If there's any data there, we return True. Otherwise, we need to fetch the data from the API!

Setting Up the Function

Before we dive into the specifics of sending a network request, let's specify what our function will do. We'll take 3 inputs for this function:

1. The problem year (e.g. 2022)
2. The problem day (1-25)
3. The file path to store the data

Here's what that type signature looks like:

fetchInputToFile :: (MonadLogger m, MonadThrow m, MonadIO m)
  => Int -- Year
  -> Int -- Day
  -> FilePath -- Destination File
  -> m ()

We'll need MonadIO for reading and writing to files, as well as reading environment variables. Using a MonadLogger allows us to tell the user some helpful information about whether the process worked, and MonadThrow is needed by our network library when parsing the route.

Now let's kick this function off with some setup tasks. We'll first run our caching check, and we'll also look for the session token as an environment variable.

fetchInputToFile :: (MonadLogger m, MonadThrow m, MonadIO m) => Int -> Int -> FilePath -> m ()
fetchInputToFile year day filepath = do
  isCached <- liftIO $ checkFileExistsWithData filepath
  token' <- liftIO $ lookupEnv "AOC_TOKEN"
  case (isCached, token') of
    (True, _) -> logDebugN "Input is cached!"
    (False, Nothing) -> logErrorN "Not cached but didn't find session token!"
    (False, Just token) -> ...

If it's cached, we can just return immediately. The file should already contain our data. If it isn't cached and we don't have a token, we're still forced to "do nothing" but we'll log an error message for the user.

Now we can move on to the network specific tasks.

Making the Network Request

Now let's prepare to actually send our request. We'll do this using the Network.HTTP.Simple library. We'll use four of its functions to create, send, and parse our request.

parseRequest :: MonadThrow m => String -> m Request

addRequestHeader :: HeaderName -> ByteString -> Request -> Request

httpBS :: MonadIO m => Request -> m (Response ByteString)

getResponseBody :: Response a -> a

Here's what these do:

1. parseRequest generates a base request using the given route string (e.g. http://www.adventofcode.com)
2. addRequestHeader adds a header to the request. We'll use this for our session token.
3. httpBS sends the request and gives us a response containing a ByteString.
4. getResponseBody just pulls the main content out of the Response object.

When using this library for other tasks, you'd probably use httpJSON to translate the response to any object you can parse from JSON. However, the puzzle input pages are luckily just raw data we can write to a file, without having any HTML wrapping or anything like that.

So let's pick our fetchInput function back up where we left off, and start by creating our "base" request. We determine the proper "route" for the request using the year and the day. Then we use parseRequest to make this base request.

fetchInputToFile :: (MonadLogger m, MonadThrow m, MonadIO m) => Int -> Int -> FilePath -> m ()
fetchInputToFile year day filepath = do
  isCached <- liftIO $ checkFileExistsWithData filepath
  token' <- liftIO $ lookupEnv "AOC_TOKEN"
  case (isCached, token') of
    ...
    (False, Just token) -> do
      let route = "https://adventofcode.com/" <> show year <> "/day/" <> show day <> "/input"
      baseRequest <- parseRequest route
      ...

Now we need to modify the request to incorporate the token we fetched from the environment. We add it using the addRequestHeader function with the cookie field. Note we have to pack our token into a ByteString.

import Data.ByteString.Char8 (pack)

fetchInputToFile :: (MonadLogger m, MonadThrow m, MonadIO m) => Int -> Int -> FilePath -> m ()
fetchInputToFile year day filepath = do
  isCached <- liftIO $ checkFileExistsWithData filepath
  token' <- liftIO $ lookupEnv "AOC_TOKEN"
  case (isCached, token') of
    ...
    (False, Just token) -> do
      let route = "https://adventofcode.com/" <> show year <> "/day/" <> show day <> "/input"
      baseRequest <- parseRequest route
      {- Add Request Header -}
      let finalRequest = addRequestHeader "cookie" (pack token) baseRequest 
      ...

Finally, we send the request with httpBS to get its response. We unwrap the response with getResponseBody, and then write that output to a file.

fetchInputToFile :: (MonadLogger m, MonadThrow m, MonadIO m) => Int -> Int -> FilePath -> m ()
fetchInputToFile year day filepath = do
  isCached <- liftIO $ checkFileExistsWithData filepath
  token' <- liftIO $ lookupEnv "AOC_TOKEN"
  case (isCached, token') of
    (True, _) -> logDebugN "Input is cached!"
    (False, Nothing) -> logErrorN "Not cached but didn't find session token!"
    (False, Just token) -> do
      let route = "https://adventofcode.com/" <> show year <> "/day/" <> show day <> "/input"
      baseRequest <- parseRequest route
      let finalRequest = addRequestHeader "cookie" (pack token) baseRequest 
      {- Send request, retrieve body from response -}
      response <- getResponseBody <$> httpBS finalRequest
      {- Write body to the file -}
      liftIO $ Data.ByteString.writeFile filepath response

And now we're done! We can bring this function up in a GHCI session and run it a couple times!

>> import Control.Monad.Logger
>> runStdoutLoggingT (fetchInputToFile 2022 1 "day_1_test.txt")

This results in the puzzle input (for Day 1 of this past year) appearing in the `day_1_test.txt" file in our current directory! We can run the function again and we'll find that it is cached, so no network request is necessary:

>> runStdoutLoggingT (fetchInputToFile 2022 1 "day_1_test.txt")
[Debug] Retrieving input from cache!

Now we've got a neat little function we can use each day to get the input!

Conclusion

To see all this code online, you can read the file on GitHub. This will be the last Advent of Code article for a little while, though I'll be continuing with video walkthrough catch-up on Thursdays. I'm sure I'll come back to it before too long, since there's a lot of depth to explore, especially with the harder problems.

If you're enjoying this content, make sure to subscribe to Monday Morning Haskell! If you sign up for our mailing list, you'll get our monthly newsletter, as well as access to our Subscriber Resources!

Advent of Code: Days 19 & 20 Videos

You can now find two more Advent of Code videos on our YouTube channel! You can see a summary of all my work on the Advent of Code summary page!

Here is the video for Day 19, another difficult graph problem involving efficient use of resources! (The write-up can be found here).

And here's the Day 20 video, a tricky problem involving iterated sequences of numbers. You can also read about the problem in our writeup.

Reflections on Advent of Code 2022

Now that I've had a couple weeks off from Advent of Code, I wanted to reflect a bit on some of the lessons I learned after my second year of doing all the puzzles. In this article I'll list some of the things that worked really well for me in my preparation so that I could solve a lot of the problems quickly! Hopefully you can learn from these ideas if you're still new to using Haskell for problem solving.

Things that Worked

File Template and Tests

In 2021, my code got very disorganized because I kept reusing the same module, but eventually needed to pick an arbitrary point to start writing a new module. So this year I prepared my project by having a Template File with a lot of boilerplate already in place. Then I prepared separate modules for each day, as well as a test-harness to run the code. This simplified the process so that I could start each problem by just copying and pasting the inputs into pre-existing files and then run the code by running the test command. This helped me get started a lot faster each day.

Megaparsec

It took me a while to get fluent with the Megaparsec library. But once I got used to it, it turned out to be a substantial improvement over the previous year when I did most of the parsing by hand. Some of my favorite perks of using this library included easy handling of alternatives and recursive parsing. I highly recommend it.

Utilities

Throughout this year's contest, I relied a lot on a Utilities file that I wrote based on my experience from 2021. This included refactored code from that year for a lot of common use cases like 2D grid algorithms. It especially included some parsing functions for common cases like numbers and grids. Having these kinds of functions at my disposal meant I could focus a lot more on core algorithms instead of details.

List Library Functions

This year solidified my belief that the Data.List library is one of the most important tools for basic problem solving in Haskell. For many problems, the simplest solution for a certain part of the problem often involved chaining together a bunch of list functions, whether from that library or just list-related functions in Prelude. For just a couple examples, see my code for Day 1 and Day 11

Earlier in 2022 I did several articles on List functions and this was very useful practice for me. Still, there were times when I needed to consult the documentation, so I need more practice to get more fluent! It's best if you can recall these functions from memory so you can apply them quickly!

Data Structures

My series on Data Structures was also great practice. While I rarely had trouble selecting the right data structure back in 2021, I felt a lot more fluent this year applying data structure functions without needing to consult documentation. So I highly recommend reading my series and getting used to Haskell's data structure APIs! In particular, learning how to fold with your data structures will make your code a lot smoother.

Folds and For Loops

Speaking of folds, it's extremely important to become fluent with different ways of using folds in your solutions. In most languages, for-loops will be involved in a lot of complex tasks, and in Haskell folds are the most common replacement for for-loops. So get used to using them, including in a nested fashion!

In fact, the pattern of "loop through each line of input" is so common in Advent of Code that I had some lines in my file template for this solution pattern! (Incidentally, I also had a second solution pattern for "state evolution" which was also useful).

Graph Algorithms

Advent of Code always seems to have graph problems. The Algorithm.Search library helps make these a lot easier to work through. Learn how to use it! I first stumbled it on it while writing about Dijkstra's Algorithm last year.

The Logger Monad

I wrote last year about wanting to use the Logger monad to make it easier to debug my code. This led to almost all of my AoC code this year using it, even when it wasn't necessary. Overall, I think this was worth it! I was able to debug problem much faster this year when I ran into issues. I didn't get stuck needing to go back and add monads into pure code or trying to use the trace library.

Things I Missed

There were still some bumps in the road though! Here are a couple areas where I needed improvement.

Blank Lines in Input

Certain problems, like Day 1, Day 11, Day 13 and Day 19, incorporated blank lines in the input to delineate between different sections.

For whatever reason, it seems like 2021 didn't have this pattern, so I didn't have a utility for dealing with this pattern and spent an inordinate amount of time dealing with it, even though it's not actually too challenging.

Pruning Graph Algorithms

Probably the more important miss in my preparation was how I handled the graph problems. In last year's edition, there were only a couple graph problems, and I was able to get answers reasonably quickly simply by applying Dijkstra's algorithm.

This year, there were three problems (Day 16, Day 19 & Day 24) that relied heavily on graph algorithms. The first two of these were generally considered among the hardest problems this year.

For both of these, it was easy enough to frame them as graph problems and apply an algorithm like Dijkstra's or BFS. However, the scale of the problem proved to be too large to finish in a reasonable amount of time with these algorithms.

The key in all three problems was to apply pruning to the search. That is, you needed to be proactive in limiting the search space to avoid spending a lot of time on search states that can't produce the optimal answer.

Haskell's Algorithm.Search library I mentioned earlier actually provides a great tool for this! The pruning and pruningM functions allow you to modify your normal search function with an additional predicate to avoid unnecessary states.

I also learned more about the A-Star algorithm than I had known before. Previously, I'd vaguely thought of A-Star as "Dijkstra with a heuristic", which is kind of correct but not helpful in describing what the heuristic actually does.

I eventually came to the understanding that Dijkstra is comparable to Breadth-First-Search for a weighted graph. A-Star is closer to a Depth-First-Search on a weighted graph. While a normal DFS blindly goes down a path until it finds an end-state, A-Star uses the heuristic to attempt to make sure the first parts of the graph that we search are the most likely to lead us to the goal.

It was difficult to find a heuristic for Days 16 & 19, but I was able to apply A-Star on Day 24 to get a noticeable speed-up.

Conclusion

For the next few Thursdays I'm still going to be catching up on the video walkthroughs from Advent of Code. And then next Monday I'll have one more AoC-related article exploring how we can build an API to access our question inputs without even using the web browser!

Make sure to subscribe to our mailing list if you haven't already to get access to our Subscriber Resources!

Advent of Code: Days 17 & 18 Videos

You can now take a look at my latest videos recapping Advent of Code from last year! If you missed any of the write-ups or videos, you can head to the summary page!

Here’s the Day 17 video, another challenging problem where we had to essentially write a tetris simulator!

And here’s the Day 18 video. This one was much easier than days 16 & 17. The key component here was performing a breadth-first-search in 3D. Here’s the writeup if you missed it.

Advent of Code Video Catchup Begins!

If you were following my Advent of Code series from December, you may have noticed that I stopped publishing videos after Day 14 or so. Unfortunately, the problems got challenging, so I didn't have time for videos in addition to writeups. I also went on vacation for Christmas, so I was away from my recording setup for a while.

But now I'm hoping to catch up with those videos! I'll be releasing two each week on Wednesday and Thursday. So today, you can now go to my YouTube channel and see the videos for Day 15 and Day 16!

If you enjoy the Advent of Code series and all the writeups I did, make sure to subscribe to our monthly newsletter!

Day 15

Day 15 Writeup

Day 15 Video link

Day 16

Day 16 Writeup

Day 16 Video link

Note, the Day 16 writeup is combined with Day 17 and gives only a high-level overview.

Day 25 - Balanced Quinary

This is it - the last problem! I'll be taking a bit of a break after this, but the blog will be back in January! At some point I'll have some more detailed walkthroughs for Days 16 & 17, and I'll get to video walkthroughs for the second half of problems as well.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Today's problem only has 1 part. To get the second star for the problem, you need to have gotten all the other stars from prior problems. For the problem, we'll be decoding and encoding balanced quinary numbers. Normal quinary would be like binary except using the digits 0-4 instead of just 0 and 1. But in balanced quinary, we have the digits 0-2 and then we have the - character representing -1 and the = character representing -2. So the number 1= means "1 times 5 to the first power plus (-2) times 5 to the zero power". So the numeral 1= gives us the value 3 (5 - 2).

We'll take a series of numbers written in quinary, convert them to decimal, take their sum, and then convert the result back to quinary.

Parsing the Input

Here's a sample input:

1=-0-2
12111
2=0=
21
2=01
111
20012
112
1=-1=
1-12
12
1=
122

Each line has a series of 5 possible characters, so parsing this is pretty easy. We'll convert the characters directly into integers for convenience.

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

type InputType = [LineType]
type LineType = [Int]

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

parseSnafuNums :: (MonadLogger m) => ParsecT Void Text m Int
parseSnafuNums =
  (char '2' >> return 2) <|>
  (char '1' >> return 1) <|>
  (char '0' >> return 0) <|>
  (char '-' >> return (-1)) <|>
  (char '=' >> return (-2))

Decoding Numbers

Decoding is a simple process.

1. Reverse the string and zip the numbers with their indices (starting from 0)
2. Add them together with a fold. Each step will raise 5 to the index power and add it to the previous value.

translateSnafuNum :: [Int] -> Integer
translateSnafuNum nums = foldl addSnafu 0 (zip [0,1..] (reverse nums))
  where
    addSnafu prev (index, num) = fromIntegral (5 ^ index * num) + prev

This lets us "process" the input and return an Integer representing the sum of our inputs.

type EasySolutionType = Integer

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = do
  let decimalNums = map translateSnafuNum inputs
  return (sum decimalNums)

Encoding

Now we have to re-encode this sum. We'll do this by way of a tail recursive helper function. Well, almost tail recursive. One case technically isn't. But the function takes a few arguments.

1. The "remainder" of the number we are trying to encode
2. The current "power of 5" that is the next one greater than our remainder number
3. The accumulated digits we've placed so far.

So here's our type signature (though I flipped the first two arguments for whatever reason):

decimalToSnafuTail :: (MonadLogger m) => Integer -> Integer -> [Int] -> m [Int]
decimalToSnafuTail power5 remainder accum = ...

It took me a while to work out exactly what the cases are here. They're not completely intuitive. But here's my list.

1. Base case: absolute value of remainder is less than 3
2. Remainder is greater than half of the current power of 5.
3. Remainder is at least 2/5 of the power of 5.
4. Remainder is at least 1/5 of the power of 5.
5. Remainder is smaller than 1/5 of the power of 5.

Most of these cases appear to be easy. In the base case we add the digit itself onto our list and then reverse it. In cases 3-5, we place the digit 2,1 and 0, respectively, and then recurse on the remainder after subtracting the appropriate amount (based on the "next" smaller power of 5).

decimalToSnafuTail :: (MonadLogger m) => Integer -> Integer -> [Int] -> m [Int]
decimalToSnafuTail power5 remainder accum
  | abs remainder < 3 = return $ reverse (fromIntegral remainder : accum)
  | remainder > (power5 `quot` 2) = ...
  | remainder >= 2 * next5 = decimalToSnafuTail next5 (remainder - (2 * next5)) (2 : accum)
  | remainder >= power5 `quot` 5 = decimalToSnafuTail next5 (remainder - next5) (1 : accum)
  | otherwise = decimalToSnafuTail next5 remainder (0 : accum)
  where
    next5 = power5 `quot` 5

This leaves the case where our value is greater than half of the current power5. This case is the one that introduces negative values into the equation. And in fact, it means we actually have to "carry a one" back into the last accumulated value of the list. We'll have another "1" for the current power of 5, and then the remainder will start with a negative value.

What I realized for this case is that we can do the following:

1. Carry the 1 back into our previous accumulation
2. Subtract the current remainder from the current power of 5.
3. Derive the quinary representation of this value, and then invert it.

Fortunately, the "carry the 1" step can't cascade. If we've placed a 2 from case 3, the following step can't run into case 2. We can think of it this way. Case 3 means our remainder is 40-50% of the current 5 power. Once we subtract the 40%, the remaining 10% cannot be more than half of 20% of the current 5 power. It seems

Now case 2 actually isn't actually tail recursive! We'll make a separate recursive call with the smaller Integer values, but we'll pass an empty accumulator list. Then we'll flip the resulting integers, and add it back into our number. The extra post-processing of the recursive result is what makes it "not tail recursive".

decimalToSnafuTail :: (MonadLogger m) => Integer -> Integer -> [Int] -> m [Int]
decimalToSnafuTail power5 remainder accum
  | abs remainder < 3 = return $ reverse (fromIntegral remainder : accum)
  {- Case 2 -}
  | remainder > (power5 `quot` 2) = do
    let add1 = if null accum then [1] else head accum + 1 : tail accum
    recursionResult <- decimalToSnafuTail power5 (power5 - remainder) []
    return $ reverse add1 ++ map ((-1) *) recursionResult
  {- End Case 2 -}
  | remainder >= 2 * next5 = decimalToSnafuTail next5 (remainder - (2 * next5)) (2 : accum)
  | remainder >= power5 `quot` 5 = decimalToSnafuTail next5 (remainder - next5) (1 : accum)
  | otherwise = decimalToSnafuTail next5 remainder (0 : accum)
  where
    next5 = power5 `quot` 5

Once we have this encoding function, tying everything together is easy! We just source the first greater power of 5, and translate each number in the resulting list to a character.

findEasySolution :: (MonadLogger m) => EasySolutionType -> m String
findEasySolution number = do
  finalSnafuInts <- decimalToSnafuTail first5Power number []
  return (intToSnafuChar <$> finalSnafuInts)
  where
    first5Power = head [n | n <- map (5^) [0,1..], n >= number]

intToSnafuChar :: Int -> Char
intToSnafuChar 2 = '2'
intToSnafuChar 1 = '1'
intToSnafuChar (-1) = '-'
intToSnafuChar (-2) = '='
intToSnafuChar _ = '0'

And our last bit of code to tie these parts together:

solveEasy :: FilePath -> IO String
solveEasy fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  result <- processInputEasy input
  findEasySolution result

And that's the solution! All done for this year!

Video

Coming eventually.

Day 24 - Graph Problem Redemption

I don't have enough time for a full write-up at the moment, but I did complete today's problem, so I'll share the key insights and you can take a look at my final code on GitHub. I actually feel very good about this solution since I finally managed to solve one of the challenging graph problems (see Days 16 and 19) without needing help.

My first naive try at the problem was, of course, too slow. but I came up with a couple optimizations I hadn't employed before to bring it to a reasonable speed. I get the final solution in about 2-3 minutes, so some optimization might still be possible, but that's still way better than my 30-40 minute solution on Day 16.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

This is a 2D grid navigation problem, but we're now dealing with moving obstacles. Luckily, each obstacle moves in a very predictable pattern. We're navigating a valley with "blizzards", and each blizzard moves either up, down, left, or right one tile with each passing turn.

#.######
#>>.<^<#
#.<..<<#
#>v.><>#
#<^v^^>#
######.#

When a blizzard hits the wall of the valley (#), it wraps back around, traveling in the same direction along the same row starting from the other side. Blizzards do not affect each other's path, so it's possible for multiple blizzards to share a tile for a turn before continuing. We want to get from the top empty space (.) to the bottom space while avoiding the blizzards.

Each turn we move simultaneously with the blizzards. So we are trying to step into a space that will be empty on the next step. This means it is possible to move into a space that appears to be currently occupied by a blizzard. In the first step from the starting position above, it is legal for us to move down, because the blizzard there will have moved right during our move, and no other blizzard takes its place. Importantly, it is also legal for us to stand still for a turn and wait for the blizzards around us to pass (as long as a blizzard isn't coming into our space that turn).

In Part 1, we must find the shortest path to the end. Then in Part 2, we have to find the subsequent shortest path from the end back to the start and then once again proceed from the start to the end (the elves forgot their snacks). Because of the blizzards shifting, the three paths do not necessarily look the same.

Naive Approach

We can combine a simple Breadth-First-Search with the principles of state evolution. We have to track all the coordinates that currently contain a blizzard. But we do this in 4 different sets, so we can move the blizzards in the right direction each turn.

But essentially, we look at our neighboring tiles, see which ones will be empty, and treat all those as our neighboring options, until we complete the search.

However, this isn't sufficient to deliver an answer to the large input in a reasonable amount of time.

Optimization 1: Bit Vectors!

The first observation we can make with the naive approach is that for every state evolution, we're spending time updating each individual blizzard. In my "large" input, blizzards take up about 3/4 of the grid space, so we're essentially spending O(n^2) time on each state update.

We can reduce this to O(n) by using an Integer to represent each row of left/right blizzards and each column of up/down blizzards, and treating this integer as a bit vector. Imagine the following binary representation of the integer 18:

010010

We can do a bitwise "left shift", and our number doubles, becoming the integer 36:

100100

Likewise, we can "right shift" our original number to get 9:

001001

Notice how these operations resemble the shifting of a set of blizzards along a row (or column). A "1" bit represents the location of a blizzard, and "0" is a clear space.

So we might represent the "up blizzards" of column 5 with the number 9, since the up blizzards exist at rows 1 and 4:

1001

Since they go up, we shift "right", moving each bit. The trick is that we have to define our own shift function to handle that wrap around! The number should become 24, since the least significant bit wraps to the most significant:

1100

Haskell's Bits typeclass (from Data.Bits) provides all the tools you need to accomplish these tasks with the Integer type that implements the class:

setBit :: Integer -> Int -> Integer
clearBit :: Integer -> Int -> Integer
testBit :: Integer -> Int -> Bool
shiftR :: Integer -> Int -> Integer
shiftL :: Integer -> Int -> Integer

The testBit function is what you'll ultimately need to determine if a space has a blizzard or not in your search function. The others are needed for updates. But all these functions are extremely efficient and the shifting allows us to perform bulk updates!

You still need one array of integers for each column or row for each direction of blizzards. But updating these is still O(n) time compared to O(n^2) for the original approach.

This optimization is sufficient to bring the first part down to a tractable amount of time (3-5 minutes). But I had another idea to help.

Optimization 2: A-Star

We're still stuck with the fact that to find an optimal path of length 18, BFS will blindly explore every path up length 18. However, the A algorithm can give us a more directed search if* we provide a reasonable heuristic.

I had tried to apply A on the earlier graph problems. But for those problems, it was difficult to provide a good heuristic because of how the cost worked. A requires a heuristic that underestimates the final cost. But in the prior problems, the distance traveled wasn't actually the graph cost, making it difficult to provide an underestimate.

This time, we can simply use the manhattan distance to the end coordinate as a reasonable heuristic. This will direct our search more actively towards the end of the grid. It's not always optimal to do so, but it's a better guess that will prevent a lot of wasted time on branches that just retreat to the beginning unnecessarily.

This cut down my solution time by about half. So I could now get the first solution in less than a minute, and the final part in less than 3 minutes, which I'm satisfied with for now.

The only further optimization I can think of would be to observe that the blizzard paths are so predictable that we should be able to find a closed form math solution for the question of "does space X have a blizzard at time t", perhaps involving modulus and LCM operations. I might explore this idea later.

I'll also get into more details on the code later. For now, there's one more problem remaining tonight!

Day 23 - Spreading Out the Elves

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

In this problem, we've met back up with our elf friends, and they are trying to determine the optimal way to spread themselves out to plant some trees. They start out clustered up in a 2D grid. Each round, each elf considers moving in each of the 4 cardinal directions in turn. They won't move in a direction if another elf is anywhere near it (e.g. an elf won't move north if another elf is either north, northeast, or northwest of it). An elf also won't move if there are no elves around it.

The priority for their movement changes each round. In round 1, they'll consider moving north first, then south, then west, then east. In round 2, this order shifts so that south is considered first and north last, and so on in a rotating manner.

Finally, it is possible that two elfs propose moving into the same location from opposite directions. In this case, neither moves.

In part 1 of the problem, we run 10 rounds of the simulation and determine how much empty space is covered by the rectangle formed by the elves. In part 2, we see how many rounds it takes for the simulation to reach a stable state, with every elf having no more neighbors.

Solution Approach and Insights

This problem doesn't require any super deep insights, just careful accounting. One realization that makes the solution a bit easier is that if an elf moves from coordinate C, no other elf can possibly move into position C that round.

Relevant Utilities

This problem uses a couple utilities. First, we'll parse our input as a 2D Hashmap where each cell is just a Bool value. Then, we'll reuse our occurrence map idea that's come up a few times. This will track the number of elves moving into a certain coordinate.

Parsing the Input

Here's a sample input:

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

As usual, . spaces are empty, and # spaces contain an elf. We'll parse this as a 2D Hashmap just to get the coordinates straight, and then we'll filter it down to a Hashset of just the occupied coordinates.

type InputType = HS.HashSet Coord2

-- Parse as 2D Hash Map of Bools.
-- Filter out to the coordinates that are occupied.
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  hashMap <- parse2DHashMap (some parseLoc)
  return $ HS.fromList $ fst <$> filter snd (HM.toList hashMap)
  where
    parseLoc = (char '.' >> return False) <|> (char '#' >> return True)

Getting the Solution

First, let's add a quick type for the 4 cardinal directions. This will help us track the priority order.

data Direction = North | South | East | West
  deriving (Show, Eq)

At its core, this is a state evolution problem. So we'll use the appropriate pattern. The state we're tracking for each round consists of 3 pieces:

1. The set of coordinates occupied by elves
2. The current direction priority (rotates each round)
3. Whether or not any elf moved this round.

So let's fill in the pattern like so:

type StateType = (HS.HashSet Coord2, [Direction], Bool)

-- Recursively run the state evolution n times.
solveStateN :: (MonadLogger m) => Int -> StateType -> m StateType
solveStateN 0 st = return st {- Base case: (n = 0) -}
solveStateN n st = do
  st' <- evolveState st
  solveStateN (n - 1) st' {- Recursive case: (n - 1) -}

evolveState :: (MonadLogger m) => StateType -> m StateType

Now all the magic happens in our evolveState function. This has 3 core steps:

1. Get all proposed moves from the elves.
2. Exclude proposed moves with more than 1 elf moving there.
3. Update the set of occupied squares

The first part is the most complicated. We'll fold over each of the existing elf coordinates and see if we can propose a new move for it. The fold state will track the number of times each move is proposed, as well as a mapping from destination coordinates back to source coordinates.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = ...

The first order of business here is checking if each direction is empty. We do this with list comprehensions.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = (prevMoves, destOcc) c@(row, col) = do
      let northEmpty = not $ or [HS.member c elfSet | c <- [(row - 1, col - 1), (row - 1, col), (row - 1, col + 1)]]
          southEmpty = not $ or [HS.member c elfSet | c <- [(row + 1, col - 1), (row + 1, col), (row + 1, col + 1)]]
          westEmpty = not $ or [HS.member c elfSet | c <- [(row + 1, col - 1), (row , col - 1), (row - 1, col - 1)]]
          eastEmpty = not $ or [HS.member c elfSet | c <- [(row + 1, col + 1), (row , col + 1), (row - 1, col + 1)]]
          stayStill = northEmpty && southEmpty && eastEmpty && westEmpty
      ...

Now we need some helpers to "try" each direction and return a move. These functions will each take the corresponding Empty boolean and return the appropriate coordinate for the direction if the boolean is True. Otherwise they'll give Nothing.

tryNorth :: Bool -> Coord2 -> Maybe Coord2
tryNorth b (row, col) = if b then Just (row - 1, col) else Nothing

trySouth :: Bool -> Coord2 -> Maybe Coord2
trySouth b (row, col) = if b then Just (row + 1, col) else Nothing

tryEast :: Bool -> Coord2 -> Maybe Coord2
tryEast b (row, col) = if b then Just (row, col + 1) else Nothing

tryWest :: Bool -> Coord2 -> Maybe Coord2
tryWest b (row, col) = if b then Just (row, col - 1) else Nothing

Now we need to try each move in order using these functions, our Empty booleans, and in particular the alternative operator <|>.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = (prevMoves, destOcc) c@(row, col) = do
      let northEmpty = ...
          southEmpty = ...
          westEmpty = ...
          eastEmpty = ...
          stayStill = northEmpty && southEmpty && eastEmpty && westEmpty
          trialMove = case head directions of
                        North -> tryNorth northEmpty c <|> trySouth southEmpty c <|> tryWest westEmpty c <|> tryEast eastEmpty c
                        South -> trySouth southEmpty c <|> tryWest westEmpty c <|> tryEast eastEmpty c <|> tryNorth northEmpty c
                        West -> tryWest westEmpty c <|> tryEast eastEmpty c <|> tryNorth northEmpty c <|> trySouth southEmpty c
                        East -> tryEast eastEmpty c <|> tryNorth northEmpty c <|> trySouth southEmpty c <|> tryWest westEmpty c
      ...

Finally, we'll update our fold values as long as the trialMove is a Just value AND we are not staying still. We increment the destination move in the occurrence map, and we add the destination->source mapping.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)
    proposeMove = (prevMoves, destOcc) c@(row, col) = do
      let northEmpty = ...
          southEmpty = ...
          westEmpty = ...
          eastEmpty = ...
          stayStill = northEmpty && southEmpty && eastEmpty && westEmpty
          trialMove = ...
      return $ if isJust trialMove && not stayStill 
            then (HM.insert (fromJust trialMove) c prevMoves, incKey destOcc (fromJust trialMove))
            else (prevMoves, destOcc)

In step 2, we filter the move proposals down to those that only have one elf moving there.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  let spacesWithOne = filter (\(_, occ) -> occ == 1) (Data.Map.toList occurrences)
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)

Now we just need to update the original elfSet with these values. The helper updateSetForMove will delete the original source from our set and add the new destination (this is why we need the destination->source mapping).

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  let spacesWithOne = filter (\(_, occ) -> occ == 1) (Data.Map.toList occurrences)
  let updatedSet = foldl (updateSetForMove proposedMoves) elfSet (fst <$> spacesWithOne)
  ...
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)

    updateSetForMove :: HM.HashMap Coord2 Coord2 -> HS.HashSet Coord2 -> Coord2 -> HS.HashSet Coord2
    updateSetForMove moveLookup prevSet newLoc = HS.insert newLoc (HS.delete (moveLookup HM.! newLoc) prevSet)

Finally, we rotate the directions so that first becomes last, and add a null check on spacesWithOne to see if any elves moved this turn.

evolveState :: (MonadLogger m) => StateType -> m StateType
evolveState (elfSet, directions, _) = do
  (proposedMoves, occurrences) <- foldM proposeMove (HM.empty, emptyOcc) elfSet
  let spacesWithOne = filter (\(_, occ) -> occ == 1) (Data.Map.toList occurrences)
  let updatedSet = foldl (updateSetForMove proposedMoves) elfSet (fst <$> spacesWithOne)
  return (updatedSet, rotatedDirections, not (null spacesWithOne))
  where
    proposeMove :: (MonadLogger m) => (HM.HashMap Coord2 Coord2, OccMap Coord2) -> Coord2 -> m (HM.HashMap Coord2 Coord2, OccMap Coord2)

    updateSetForMove :: HM.HashMap Coord2 Coord2 -> HS.HashSet Coord2 -> Coord2 -> HS.HashSet Coord2
    updateSetForMove moveLookup prevSet newLoc = HS.insert newLoc (HS.delete (moveLookup HM.! newLoc) prevSet)

    rotatedDirections = tail directions ++ [head directions]

We're almost done! Now we need to find the smallest axis-aligned bounding box for all the elves, and we have to find the number of unoccupied squares within that box. This is fairly straightforward. We unzip the coordinates to separate x's and y's, and we take the maximum and minimum in each direction. We subtract the total number of elves from the area of this rectangle.

findEasySolution :: (MonadLogger m, MonadIO m) => EasySolutionType -> m (Maybe Int)
findEasySolution occupiedSquares = do
  let (rows, cols) = unzip $ HS.toList occupiedSquares
  let r@(minRow, maxRow, minCol, maxCol) = (minimum rows, maximum rows, minimum cols, maximum cols)
  return $ Just $ (maxRow - minRow + 1) * (maxCol - minCol + 1) - HS.size occupiedSquares

And then we just add a little glue to complete part 1.

type EasySolutionType = HS.HashSet Coord2

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = do
  (result, _, _) <- solveStateN 10 (inputs, [North, South, West, East], True)
  return result

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

Part 2

Not a whole lot changes in Part 2! We just use a slightly different recursive function to call evolveState. Instead of counting down to 0 for its base case, we'll instead have our counter go upwards and return this count once the last part of our state type is False.

-- Evolve the state until no more elves move.
solveStateEnd :: (MonadLogger m) => Int -> StateType -> m Int
solveStateEnd n st@(_, _, False) = return n {- Base Case: No elves moved. -}
solveStateEnd n st = do
  st' <- evolveState st
  solveStateEnd (n + 1) st' {- Recursive Case: Add 1 to count -}

And some last bits of code to tie it together:

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = solveStateEnd 0 (inputs, [North, South, West, East], True)

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

And now we're done! 2 more days to go!

Video

Coming eventually.

Day 22 - Cube Maze

Not necessarily the most challenging in terms of algorithms or performance. But this problem required a tremendous amount of intricacy with processing each move through a maze. Dozens of places to make off-by-one errors or basic arithmetic issues.

With so many details, this article will give a higher level outline, but the code on GitHub is extensively commented to show what's happening, so you can use that as a guide as well.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

We're given an irregularly shaped maze. Most positions are empty but some are walls. Here's an example:

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

We're going to navigate this maze based on a series of instructions where we turn (right or left) and then move a certain distance.

In part 1, whenever we go off the end of the grid, we wrap back around to the opposite end of the maze in the direction we're going.

But in part 2, we imagine that the maze is folded up into a cube with six sides! We still retain the same 2D coordinate system, but the logic for what happens when we wrap is a lot more challenging.

Solution Approach and Insights

The key insight I had for the first part was to make a 2D grid where spaces not in the maze are marked as Blank. I also added a padding layer of Blank spaces around the edge. This made it easy to determine when I needed to wrap. Then I kept track of the non-blank indices in each row and column to help with calculating where to go.

In part 2, I basically hard-coded the structure of the cube to determine the wrapping rules (and the structures were different for the example input and the large input). This was quite tedious, but allowed me to keep the overall structure of my code.

Parsing the Input

First, some simple types for directions and turning:

data Direction =
  FaceUp |
  FaceDown |
  FaceLeft |
  FaceRight
  deriving (Show, Eq)

data Turn = TurnLeft | TurnRight
  deriving (Show, Eq)

Now for the "cells" in our grid. We have empty spaces that are actually part of the maze (.), walls in the maze (#), and "blank" spaces that are not part of the grid but fall within its 2D bounds.

data Cell =
  Empty |
  Wall |
  Blank
  deriving (Show, Eq)

Now for parsing. Here's the full example input:

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

10R5L5R10L4R5L5

First parse a single line of maze input. In addition to the list of cells, this also returns the start and end column of the non-blank spaces. Note: this function adds an extra 'Blank' to the front of the row because we want to pad all 4 directions.

type LineType = ([Cell], (Int, Int))
parseLine :: (MonadLogger m, MonadFail m) => ParsecT Void Text m LineType
parseLine = do
  cells <- some parseCell
  let frontPadded = Blank : cells
  case findIndex (/= Blank) frontPadded of
    Nothing -> fail "A line is completely blank!"
    Just i -> do
      return (frontPadded, (i, length frontPadded - 1))
  where
    parseCell = (char ' ' >> return Blank) <|> (char '.' >> return Empty) <|> (char '#' >> return Wall)

Let's also have a function to parse the directions. This function is recursive. It runs until we encounter 'eof'.

parsePath :: (MonadLogger m, MonadFail m) => [(Turn, Int)] -> ParsecT Void Text m [(Turn, Int)]
parsePath accum = finished <|> notFinished
  where
    finished = eof >> return (reverse accum) {- Base Case: End-of--File -}
    notFinished = do
      t <- (char 'R' >> return TurnRight) <|> (char 'L' >> return TurnLeft)
      i <- parsePositiveNumber
      parsePath ((t, i) : accum) {- Recursive Case: Add the new turn and distance. -}

Now we'll put it all together. This is a fairly intricate process (7 steps).

1. Parse the cell lines (which adds padding to the front of each, remember).
2. Get the maximum column and add padding to the back for each line. This includes one Blank beyond the final column for every row.
3. Add an extra line of padding of 'Blank' to the top and bottom.
4. Construct a 2D Array with the cells. The first element that can be in the maze is (1,1), but Array's index starts at (0,0) for padding.
5. Make an array out of "rowInfos", which are included from parsing the rows. These tell us the first and last non-Blank index in each row.
6. Calculate "columnInfos" based on the maze grid. These tell us the first and last non-Blank index in each column.
7. Parse the path/directions.

type MazeInfo = (Grid2 Cell, A.Array Int (Int, Int), A.Array Int (Int, Int))
type InputType = (MazeInfo, [(Turn, Int)])

parseInput :: (MonadLogger m, MonadFail m) => ParsecT Void Text m InputType
parseInput = do
  {- 1 -}
  cellLines <- sepEndBy1 parseLine eol
  let maxColumn = maximum (snd . snd <$> cellLines)
{-2-} paddedCellLines = map (\(cells, (_, lastNonBlankIndex)) -> cells ++ replicate (maxColumn - lastNonBlankIndex + 1) Blank) cellLines
{-3-} topBottom = replicate (maxColumn + 2) Blank
      finalCells = concat (topBottom : paddedCellLines) ++ topBottom
{-4-} maze = A.listArray ((0, 0), (length paddedCellLines + 1, maxColumn + 1)) finalCells
{-5-} rowInfos = A.listArray (1, length cellLines) (snd <$> cellLines)
{-6-} columns = map (calculateColInfo maze) [1..maxColumn]
      columnInfos = A.listArray (1, maxColumn) columns
  eol
  {-7-}
  firstLength <- parsePositiveNumber
  path <- parsePath [(TurnRight, firstLength)]
  return ((maze, rowInfos, columnInfos), path)
  where
    {- 6 -}
    calculateColInfo :: Grid2 Cell -> Int -> (Int, Int)
    calculateColInfo maze col =
      let nonBlankAssocs = filter (\((r, c), cell) -> c == col && cell /= Blank) (A.assocs maze)
          sorted = sort $ fst . fst <$> nonBlankAssocs
      in  (head sorted, last sorted)

Part 1

We start with a simple function for changing our direction based on turning:

turn :: Turn -> Direction -> Direction
turn TurnLeft d = case d of
  FaceUp -> FaceLeft
  FaceRight -> FaceUp
  FaceDown -> FaceRight
  FaceLeft -> FaceDown
turn TurnRight d = case d of
  FaceUp -> FaceRight
  FaceRight -> FaceDown
  FaceDown -> FaceLeft
  FaceLeft -> FaceUp

Now we'll calculate a single move, based on the location and direction.

1. Get the next coordinate based on our direction
2. If the next coordinate is empty, move there. If it's a wall, return the old location.
3. If it's blank, wrap around to the next cell.

This last step requires checking the rowInfo for horizontal wrapping, and the columnInfo for vertical wrapping.

move :: (MonadLogger m) => MazeInfo -> (Coord2, Direction) -> m Coord2
move (maze, rowInfo, columnInfo) (loc@(row, column), direction) = return nextCell
  where
    {- 1 -}
    nextCoords = case direction of
      FaceUp -> (row - 1, column)
      FaceRight -> (row, column + 1)
      FaceDown -> (row + 1, column)
      FaceLeft -> (row, column - 1)
    nextCell = case maze A.! nextCoords of
      Wall -> loc {- 2 -}
      Empty -> nextCoords {- 2 -}
      Blank -> if maze A.! nextCellWrapped == Empty
        then nextCellWrapped
        else loc

    {- 3 -}
    nextCellWrapped = case direction of
      FaceUp -> (snd $ columnInfo A.! column, column)
      FaceRight -> (row, fst $ rowInfo A.! row)
      FaceDown -> (fst $ columnInfo A.! column, column)
      FaceLeft -> (row, snd $ rowInfo A.! row)

Now we can run all the moves. This requires two layers of recursion. In the outer layer, we process a single combination of turn/distance. In the inner layer we run a single move, recursing n times based on the distance given in the directions. For part 1, we only need to calculate the new direction once.

-- Recursively run all the moves.
-- With each call, process one element of 'directions' - turn once and move the set number of times.
runMoves :: (MonadLogger m) => MazeInfo -> (Coord2, Direction) -> [(Turn, Int)] -> m (Coord2, Direction)
runMoves _ final [] = return final {- Base Case - No more turns/moves. -}
runMoves info (currentLoc, currentDir) ((nextTurn, distance) : rest) = do
  finalCoord <- runMovesTail distance currentLoc
  runMoves info (finalCoord, newDir) rest {- Recursive -}
  where
    newDir = turn nextTurn currentDir

    -- Recursively move the given direction a set number of times.
    runMovesTail :: (MonadLogger m) => Int -> Coord2 -> m Coord2
    runMovesTail 0 c = return c {- Base Case - n=0 -}
    runMovesTail n c = do
      result <- move info (c, newDir)
      runMovesTail (n - 1) result {- Recursive Case (n - 1) -}

Now to call this function the first time, we just need to calculate the start, which is a 3-step process:

1. Get all maze indices that are empty in Row 1
2. Sort by the column (snd)
3. Pick the first

processInputEasy :: (MonadLogger m) => (MazeInfo, [(Turn, Int)]) -> m EasySolutionType
processInputEasy (info@(maze, _, _), directions) = runMoves info (start, FaceUp) directions
  where
    -- The initial position in the maze
    start :: Coord2
    start = head $ {-3-}
{-2-} sortOn snd $
{-1-} filter (\c@(row, _) -> row == 1 && maze A.! c == Empty) (A.indices maze)

A noteworthy item is that we give the initial direction FaceUp, because the problem tells us to assume we are facing right initially, and we added a Right turn to the start of our turns list in order to resolve the mismatch between directions and distances in the input.

And now we tie the answer together:

solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
  input@((grid, rowInfos, columnInfos), turns) <- parseFile parseInput fp
  result <- processInputEasy input
  findEasySolution result

Part 2

Most of the heavy-lifting for Part 2 is done by some serious hard-coding of the (literally) edge cases where we travel from one edge of the cube to another. You can observe these functions here but I won't bother copying them here. Unfortunately, the small input and large input require different functions.

These get abstracted into a new MazeInfoHard typedef and a WrapFunction description:

type Face = Int
type MazeInfoHard = (Grid2 Cell, Coord2 -> Face)
type WrapFunction = Coord2 -> Face -> Direction -> (Coord2, Direction)

The move function looks basically the same as part 1, but the wrapping logic is abstracted out.

moveHard :: (MonadLogger m) => MazeInfoHard -> WrapFunction -> (Coord2, Direction) -> m (Coord2, Direction)
moveHard (maze, getFace) wrap (loc@(row, column), direction) = return result
  where
    nextCoords = case direction of
      FaceUp -> (row - 1, column)
      FaceRight -> (row, column + 1)
      FaceDown -> (row + 1, column)
      FaceLeft -> (row, column - 1)
    result = case maze A.! nextCoords of
      Wall -> (loc, direction)
      Empty -> (nextCoords, direction)
      Blank -> if maze A.! nextCellWrapped == Empty
        then (nextCellWrapped, nextDirWrapped)
        else (loc, direction)

    {- Primary difference comes with this logic, see functions below. -}
    (nextCellWrapped, nextDirWrapped) = wrap loc (getFace loc) direction

Note that we can now change direction when we move, which wasn't possible before. This is also apparent looking at the new function for processing all the directions. It also has the same structure as before (nested recursion), but the direction must also change in the inner function.

runMovesHard :: (MonadLogger m) => MazeInfoHard -> WrapFunction -> (Coord2, Direction) -> [(Turn, Int)] -> m (Coord2, Direction)
runMovesHard _ _ final [] = return final
runMovesHard info wrap (currentLoc, currentDir) ((nextTurn, distance) : rest) = do
  (finalCoord, finalDir) <- runMovesTail distance (currentLoc, newDir)
  runMovesHard info wrap (finalCoord, finalDir) rest
  where
    newDir = turn nextTurn currentDir

    -- Unlike part 1, our direction can change without us "turning", so this function
    -- needs to return a new coordinate and a new direction.
    runMovesTail :: (MonadLogger m) => Int -> (Coord2, Direction) -> m (Coord2, Direction)
    runMovesTail 0 c = return c
    runMovesTail n (c, d) = do
      result <- moveHard info wrap (c, d)
      runMovesTail (n - 1) result

The upper processing function is virtually identical:

processInputHard :: (MonadLogger m) => (MazeInfoHard, [(Turn, Int)]) -> WrapFunction -> m EasySolutionType
processInputHard (mazeInfoHard@(maze, _), directions) wrap = runMovesHard mazeInfoHard wrap (start, FaceUp) directions
  where
    start = fst $ head $ sortOn (snd . fst) $ filter (\((row, _), cell) -> row == 1 && cell == Empty) (A.assocs maze)

And our outer most wrapper must now parameterize based on the "size" (small or large) to use the different functions:

solveHard :: String -> FilePath -> IO (Maybe Int)
solveHard size fp = runStdoutLoggingT $ do
  input@((grid, _, _), turns) <- parseFile parseInput fp
  -- This problem requires hardcoding between small and large solutions.
  let (wrapFunc, faceFunc) = if size == "small" then (wrapEasy, getFaceEasy) else (wrapHard, getFaceHard)
  result <- processInputHard ((grid, faceFunc), turns) wrapFunc
  findEasySolution result -- < Evaluation solution is same as in the "Easy" part.

This was a rather exhausting solution to write, mainly from all the arithmetic on the wrapping cases. But it's done! 3 more days to go!

Video

Coming eventually.

Day 21 - Variable Tree Solving

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

In today's problem, we're effectively analyzing a variable tree. Some lines we'll read will contain constant values. Others depend on the results of other lines and perform operations. In the first part, we just have to work our way down the call tree to determine the appropriate final value.

In the second part, we have to be a bit more clever. The root operation expects equality between its two values. And we're responsible for determining the value of one of the variables (humn) such that the equality is true.

Throughout this problem, we're going to assume that the variables do, in fact, form a proper tree. That is, each variable has at most one parent that relies upon its value. If the humn variable we eventually fill in ends up on both sides of an equation, things would get a lot more complicated, but it turns out this never happens.

Solution Approach and Insights

Recursion works very nicely and gives us a compact solution, especially for Day 1. I started off keeping track of more things like the dependency mapping between variable names because I thought it might help performance. But once I saw the inputs are just a tree, I realized it was unnecessary.

Parsing the Input

Our input gives a variable name on each line, and then some kind of calculation. This can either be a constant number (they're all positive integers) or it can have two other variable names with an operation (+, -, *, /).

root: pppw + sjmn
dbpl: 5
cczh: sllz + lgvd
zczc: 2
ptdq: humn - dvpt
dvpt: 3
lfqf: 4
humn: 5
ljgn: 2
sjmn: drzm * dbpl
sllz: 4
pppw: cczh / lfqf
lgvd: ljgn * ptdq
drzm: hmdt - zczc
hmdt: 32

To represent these values, let's first define a type for operations (the Equals operation doesn't appear in the input, but it will come into play for part 2).

data Op =
  Plus |
  Minus |
  Times |
  Divided |
  Equals
  deriving (Show, Eq)

Now we'll define a Calculation type for the contents of each line. This is either a constant (FinalValue) or it is an Operation containing two strings and the Op constructor (we never have an operation with a string and a constant). As with Equals, we'll understand the meaning of HumanVal in part 2.

data Calculation =
  FinalValue Int64 |
  Operation Op String String |
  HumanVal
  deriving (Show, Eq)

First let's parse an Op:

parseOp :: (MonadLogger m) => ParsecT Void Text m Op
parseOp =
  (char '+' >> return Plus) <|>
  (char '-' >> return Minus) <|>
  (char '*' >> return Times) <|>
  (char '/' >> return Divided)

Then we can use this to parse the full Calculation for an operation involving two variables.

parseOpNode :: (MonadLogger m) => ParsecT Void Text m Calculation
parseOpNode = do
  s1 <- some letterChar
  char ' '
  op <- parseOp
  char ' '
  s2 <- some letterChar
  return $ Operation op s1 s2

Then using an alternative between this operation parser and a standard integer, we can parse the complete line, including the string.

type LineType = (String, Calculation)

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
  name <- some letterChar
  string ": "
  calc <- parseFinalValue <|> parseOpNode
  return (name, calc)
  where
    parseFinalValue = FinalValue . fromIntegral <$> parsePositiveNumber

And now we'll turn all our lines into a HashMap for easy access.

type CalculationMap = HM.HashMap String Calculation
type InputType = CalculationMap

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = HM.fromList <$> sepEndBy1 parseLine eol

Part 1

The first part is quite simple if we're familiar with recursion! We mainly want a function to solve a single String variable based on the calculation map. If this variable depends on other variables, we'll recursively calculate their values first, and combine them with the operation.

We'll start with a couple base cases. A FinalValue will simply return its constant. And then we'll fail if this function is called with a HumanVal. We'll see how that gets handled in part 2.

solveValue :: (MonadLogger m, MonadFail m) => CalculationMap -> String -> m Int64
solveValue calculationMap name = case calculationMap HM.! name of
  (FinalValue x) -> return x
  HumanVal -> fail "Can't solve human value! Check with hasHumanVal first."
  (Operation op s1 s2) -> = ...

Now we'll make the recursive calls on the string values in the operation, and combine them in the way specified. All numbers are integers, so quot is the proper kind of division.

solveValue :: (MonadLogger m, MonadFail m) => CalculationMap -> String -> m Int64
solveValue calculationMap name = case calculationMap HM.! name of
  (FinalValue x) -> return x
  HumanVal -> fail "Can't solve human value! Check with hasHumanVal first."
  (Operation op s1 s2) -> do
    x1 <- solveValue calculationMap s1
    x2 <- solveValue calculationMap s2
    case op of
      Plus -> return $ x1 + x2
      Minus -> return $ x1 - x2
      Times -> return $ x1 * x2
      Divided -> return $ x1 `quot` x2
      Equals -> if x1 == x2 then return 1 else return 0

Our implementation for Equals is arbitrary...this function shouldn't be used on any Equals operations.

Now to tie the solution together, we just call solveValue with root and we're already done!

type EasySolutionType = Int64

processInputEasy :: (MonadFail m, MonadLogger m) => InputType -> m EasySolutionType
processInputEasy calculationMap = solveValue calculationMap "root"

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

Part 2

Now we have a different challenge in Part 2. The root operation automatically becomes an Equals operation. So we expect that the two variables (pppw and sjmn in the above example) ultimately have equal values. The trick is we have to select the value for the "human" variable humn (discarding its original value of 5) such that these two end up equal to each other. We can start by updating our calculation map to make these two changes:

updateCalculationsHard :: (MonadLogger m, MonadFail m) => CalculationMap -> m CalculationMap
updateCalculationsHard calculationMap = do
  let map' = HM.insert "humn" HumanVal calculationMap
  case HM.lookup "root" calculationMap of
    Nothing -> fail "Error! Must have root!"
    Just (FinalValue x) -> fail "Error! Root cannot be final!"
    Just HumanVal -> fail "Error! Root cannot be human!"
    Just (Operation _ s1 s2) -> return $ HM.insert "root" (Operation Equals s1 s2) map'

Now, because we're assuming a tree structure, whenever we encounter an operation of two variables, we assume only one of them depends on the humn variable. To determine which, we'll write a function hasHumanDep to check if the particular variable depends on the human value. Of course, in the base cases, a HumanVal returns True while a FinalValue returns False.

hasHumanDep :: (MonadLogger m) => CalculationMap -> String -> m Bool
hasHumanDep calculationMap nodeName = case calculationMap HM.! nodeName of
  HumanVal -> return True
  (FinalValue _) -> return False
  ...

For operations, we simply look recursively at both sub-elements and "or" them together.

hasHumanDep :: (MonadLogger m) => CalculationMap -> String -> m Bool
hasHumanDep calculationMap nodeName = case calculationMap HM.! nodeName of
  HumanVal -> return True
  (FinalValue _) -> return False
  (Operation _ s1 s2) -> do
    human1 <- hasHumanDep calculationMap s1
    human2 <- hasHumanDep calculationMap s2
    return $ human1 || human2

With this function finished, we can start writing another recursive function to get the human value based on an expected outcome. The general outline for this is:

1. Determine which variable depends on the human value.
2. Solve the other variable (which does not depend on it).
3. Recursively determine a new expected value of the human-dependent variable.

This process starts with a couple base cases. Once we reach the HumanVal itself, we can simply return the expected value. If we encounter a FinalValue, something has gone wrong, because we should only call this on human-dependent nodes in our tree.

getHumanValForExpectedOutcome :: (MonadLogger m, MonadFail m) => CalculationMap -> Int64 -> String -> m Int64
getHumanValForExpectedOutcome calculationMap expected nodeName = case calculationMap HM.! nodeName of
  HumanVal -> return expected
  (FinalValue _) -> fail "This node doesn't actually depend on human value! Check implementation of hasHumanDep."
  (Operation op s1 s2) -> ...

For the Operation case, we start by determining which node is human-dependent. There are a couple fail cases here, if both or neither are dependent.

getHumanValForExpectedOutcome calculationMap expected nodeName = case calculationMap HM.! nodeName of
  HumanVal -> return expected
  (FinalValue _) -> fail "This node doesn't actually depend on human value! Check implementation of hasHumanDep."
  (Operation op s1 s2) -> do
    human1 <- hasHumanDep calculationMap s1
    human2 <- hasHumanDep calculationMap s2
    case (human1, human2) of
      (True, True) -> fail "Both sides have human dependency...can't use this approach!"
      (False, False) -> fail "Neither side has human dependency! Check implementation of hasHumanDep."
      ...

But now assuming we have a True/False or False/True, we begin by solving the non-dependent variable.

getHumanValForExpectedOutcome :: (MonadLogger m, MonadFail m) => CalculationMap -> Int64 -> String -> m Int64
getHumanValForExpectedOutcome calculationMap expected nodeName = case calculationMap HM.! nodeName of
  HumanVal -> return expected
  (FinalValue _) -> fail "This node doesn't actually depend on human value! Check implementation of hasHumanDep."
  (Operation op s1 s2) -> do
    human1 <- hasHumanDep calculationMap s1
    human2 <- hasHumanDep calculationMap s2
    case (human1, human2) of
      (True, True) -> fail "Both sides have human dependency...can't use this approach!"
      (False, False) -> fail "Neither side has human dependency! Check implementation of hasHumanDep."
      (True, False) -> do
        v2 <- solveValue calculationMap s2
        ...
      (False, True) -> do
        v1 <- solveValue calculationMap s1
        ...

Depending on the operation, we then determine a new "expected" value for the dependent value, and recurse. We can do this with basic algebra. Suppose our operation is Plus in the first case. The following statement is true:

expected = (s1) + v2

Therefore:

(s1) = v2 - expected

Similarly:

expected = (s1) - v2 ~-> (s1) = expected + v2
expected = (s1) * v2 ~-> (s1) = expected / v2
expected = (s1) / v2 ~-> (s1) = expected * v2

Here's how we fill in the function:

getHumanValForExpectedOutcome :: (MonadLogger m, MonadFail m) => CalculationMap -> Int64 -> String -> m Int64
getHumanValForExpectedOutcome calculationMap expected nodeName = case calculationMap HM.! nodeName of
  HumanVal -> return expected
  (FinalValue _) -> fail "This node doesn't actually depend on human value! Check implementation of hasHumanDep."
  (Operation op s1 s2) -> do
    human1 <- hasHumanDep calculationMap s1
    human2 <- hasHumanDep calculationMap s2
    case (human1, human2) of
      (True, True) -> fail "Both sides have human dependency...can't use this approach!"
      (False, False) -> fail "Neither side has human dependency! Check implementation of hasHumanDep."
      (True, False) -> do
        v2 <- solveValue calculationMap s2
        case op of
          Plus -> getHumanValForExpectedOutcome calculationMap (expected - v2) s1
          Minus -> getHumanValForExpectedOutcome calculationMap (expected + v2) s1
          Times -> getHumanValForExpectedOutcome calculationMap (expected `quot` v2) s1
          Divided -> getHumanValForExpectedOutcome calculationMap (expected * v2) s1
          Equals -> getHumanValForExpectedOutcome calculationMap v2 s1
      (False, True) -> do
        v1 <- solveValue calculationMap s1
        case op of
          Plus -> getHumanValForExpectedOutcome calculationMap (expected - v1) s2
          Minus -> getHumanValForExpectedOutcome calculationMap (v1 - expected) s2
          Times -> getHumanValForExpectedOutcome calculationMap (expected `quot` v1) s2
          Divided -> getHumanValForExpectedOutcome calculationMap (expected * v1) s2
          Equals -> getHumanValForExpectedOutcome calculationMap v1 s2

Of note is the Equals case. Here we expect the two values themselves to be equal, so we completely discard the previous expected value and replace it with either v1 or v2.

Since we've accounted for every case, we can then fill in our caller function quite easily! It updates the map and starts the expected value calculations from root. It does not matter what value we pass to start, because the Equals operation attached to root will discard it.

type HardSolutionType = EasySolutionType

processInputHard :: (MonadFail m, MonadLogger m) => InputType -> m HardSolutionType
processInputHard input = do
  calculationMap <- updateCalculationsHard input
  getHumanValForExpectedOutcome calculationMap 0 "root"

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

And now we're done!

Video

Coming eventually.

Day 20 - Shifting Sequences

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

For this problem we are tracking a queue of numbers. We are constantly moving the numbers around in the queue, based on the value of the number itself. Our queue can also wrap around, so the items in the front might easily move to the back. In part 2, we have to apply our mixing algorithm multiple times, while keeping track of the order in which we move the numbers around.

Solution Approach and Insights

The logic for this problem is fairly intricate. You need to enumerate the cases and be very careful with your index and modulus operations. Off-by-1 errors are lurking everywhere! However, you don't need any advanced structures or logic to save time, because Haskell's Sequence structure is already quite good, allowing insertions and deletions from arbitrary indices in logarithmic time. My solution doesn't use any serious performance tricks and finishes in under 15 seconds or so.

Parsing the Input

For our input, we just get a signed number for each line.

1
2
-3
3
-2
0
4

The parsing code for this is near-trival.

type InputType = [Int]

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

Part 1

In part 1, we loop through all the items of our queue in order. We shift each one by its index, and then continue until we've hit all the elements. The trick of course, is that the "last" item we look at might not be in the "last" location in the queue by the time we get to it. Everything is being shifted around, and so we have to account for that.

The "state" type for this problem will be our sequence of numbers AND a list of the indices of the numbers we still have to shift. Both of these are quite dynamic! But initializing them is easy. We take our inputs and convert to a sequence, and then we'll use 0..n as our initial set of indices.

type EasyState = (Seq.Seq Int, [Int])

initialEasy :: [Int] -> EasyState
initialEasy inputs = (Seq.fromList inputs, [0,1..(length inputs - 1)])

The core of the easy solution is a recursive helper that will process the next index we want to move. In the base case, there are no indices and we return the queue in its final state.

easyTail :: (MonadLogger m) => EasyState -> m (Seq.Seq Int)
easyTail (queue, []) = return queue
...

Our first job with the recursive case is to locate the value at the top index and delete it from the sequence.

easyTail :: (MonadLogger m) => EasyState -> m (Seq.Seq Int)
easyTail (queue, []) = return queue
easyTail (queue, nextIndex : restIndices) = do
  let val = Seq.index queue nextIndex
      queue' = Seq.deleteAt nextIndex queue
  ...

Now we determine the index where we want to insert this item. We'll add the value to the index and then take the modulus based on the length of the modified queue. That is, the modulus should be n - 1 overall. Remember, adding the value can cause the index to overflow in either direction, and we need to reset it to a position that is within the bounds of the sequence it is getting inserted into.

easyTail (queue, nextIndex : restIndices) = do
  let val = Seq.index queue nextIndex
      queue' = Seq.deleteAt nextIndex queue
      newIndex = (nextIndex + val) `mod` Seq.length queue'
      queue'' = Seq.insertAt newIndex val queue'
      ...

Now the last intricacy. When we insert an element later in the queue, we must bring forward the indices of all the elements that come before this new index. They are now in an earlier position relative to where they started. So we modify our indices in this way and then recurse with our new queue and indices.

easyTail :: (MonadLogger m) => EasyState -> m (Seq.Seq Int)
easyTail (queue, []) = return queue
easyTail (queue, nextIndex : restIndices) = do
  let val = Seq.index queue nextIndex
      queue' = Seq.deleteAt nextIndex queue
      newIndex = (nextIndex + val) `mod` Seq.length queue'
      queue'' = Seq.insertAt newIndex val queue'
      (indicesToChange, unchanged) = partition (<= newIndex) restIndices
  easyTail (queue'', map (\i -> i - 1) indicesToChange ++ unchanged)

To answer the question, we then run our tail recursive function to get the final sequence. Then we have to retrieve the index of the first place we see a 0 element.

type EasySolutionType = Int

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = do
  finalSeq <- easyTail (initialEasy inputs)
  let first0 = Seq.findIndexL (== 0) finalSeq
  ...

We need the 1000th, 2000th and 3000th indices beyond this, using mod to wrap around our queue as needed. We sum these values and return this number.

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = do
  finalSeq <- easyTail (initialEasy inputs)
  let first0 = Seq.findIndexL (== 0) finalSeq
  case first0 of
    Nothing -> logErrorN "Couldn't find 0!" >> return minBound
    Just i -> do
      let indices = map (`mod` Seq.length finalSeq) [i + 1000, i + 2000, i + 3000]
      return $ sum $ map (Seq.index finalSeq) indices

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

This completes part 1.

Part 2

Part 2 contains a couple wrinkles. First, we'll multiply every number by a large number (811589153), so we'll start using Int64 to be safe. Second, we must run this process iteratively 10 times. Except we should always move the numbers in the same order. If the number 10 starts out in position 0, and gets moved to position 17 through the mixing process, we must still move that number first in each round.

This requires us to store each number's original index with it in the sequence as part of our state. Here's how we initialize it:

type HardState = (Seq.Seq (Int64, Int), [Int])

initialHard :: [Int] -> HardState
initialHard inputs = (Seq.fromList tuples, [0,1..(length inputs - 1)])
  where
    indices = [0,1..(length inputs - 1)]
    tuples = zip (map ((* 811589153) . fromIntegral) inputs) indices

Before we get further, Data.Seq doesn't have toList for some odd reason, so let's write it:

seqToList :: Seq.Seq a -> [a]
seqToList sequence = reverse $ foldl (flip (:)) [] sequence

Now we can write the vital function that will make this all work. The newIndices function will take a shifted sequence (where each number is paired with its original index), and determine the new ordering of indices in which to move the numbers from this sequence. This is a 3-step process:

1. Zip each value/index pair with its index in the new order.
2. Sort this zipped list based on the original index order
3. Source the fst values from the result.

Here's what that code looks like:

newIndices :: Seq.Seq (Int64, Int) -> [Int]
newIndices inputs = seqToList (fst <$> sortedByOrder)
  where
    zipped = Seq.zip (Seq.fromList [0,1..(Seq.length inputs - 1)]) inputs
    sortedByOrder = Seq.sortOn (snd . snd) zipped

Our primary tail recursive function now looks almost identical. All that's different is how we adjust the indices:

hardTail :: (MonadLogger m) => HardState -> m (Seq.Seq (Int64, Int))
hardTail (queue, []) = return queue
hardTail (queue, nextIndex : restIndices) = do
  let (val, order) = Seq.index queue nextIndex
      queue' = Seq.deleteAt nextIndex queue
      val' = fromIntegral (val `mod` fromIntegral (Seq.length queue'))
      newIndex = (nextIndex + val') `mod` Seq.length queue'
      queue'' = Seq.insertAt newIndex (val, order) queue'
      finalIndices = ...
  hardTail (queue'', finalIndices)

As with the easy part, the adjustment will reduce the index of all remaining indices that came before the new index we placed it at. What is different though is that if we move a value backward, we also have to increase the remaining indices that fall in between. This case couldn't happen before since we looped through indices in order. Here's the complete function.

hardTail :: (MonadLogger m) => HardState -> m (Seq.Seq (Int64, Int))
hardTail (queue, []) = return queue
hardTail (queue, nextIndex : restIndices) = do
  let (val, order) = Seq.index queue nextIndex
      queue' = Seq.deleteAt nextIndex queue
      val' = fromIntegral (val `mod` fromIntegral (Seq.length queue'))
      newIndex = (nextIndex + val') `mod` Seq.length queue'
      queue'' = Seq.insertAt newIndex (val, order) queue'
      finalIndices = adjustIndices nextIndex newIndex
  hardTail (queue'', finalIndices)
  where
    adjustIndices old new 
      | old > new = map (\i -> if i >= new && i < old then i + 1 else i) restIndices
      | old < new = map (\i -> if i <= new && i > old then i - 1 else i) restIndices
      | otherwise = restIndices

Now we write a function so we can run this process of moving the numbers and generating new indices as many times as we want:

solveN :: (MonadLogger m) => Int -> HardState -> m (Seq.Seq (Int64, Int))
solveN 0 (queue, _) = return queue
solveN n (queue, indices) = do
  newSet <- hardTail (queue, indices)
  let nextIndices = newIndices newSet
  solveN (n - 1) (newSet, nextIndices)

And we glue it together by solving 10 times and following the same process as the easy solution to get the final number.

type HardSolutionType = Int64

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  finalSet <- solveN 10 (initialHard inputs)
  let first0 = Seq.findIndexL (\(v, _) -> v == 0) finalSet
  case first0 of
    Nothing -> logErrorN "Couldn't find 0!" >> return minBound
    Just i -> do
      let indices = map (`mod` Seq.length finalSet) [i + 1000, i + 2000, i + 3000]
      return $ sum $ map (fst . Seq.index finalSet) indices

solveHard :: FilePath -> IO Int64
solveHard fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  processInputHard input

As I said, this takes 10-15 seconds on my machine for the larger input. Optimization is probably possible. My idea was to store the indices in a segment tree, since this structure could allow for rapid bulk updates over a contiguous interval of items. But I'm not 100% sure if it works out.

Video

Coming eventually.

Day 19: Graph Deja Vu

A problem so nice they did it twice. And by "nice" I mean quite difficult. This problem was very similar in some respects to Day 16. It's a graph problem where we're trying to collect a series of rewards in a limited amount of time. However, we have to use different tricks to explore the search space efficiently.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

We're trying to mine geodes. To build geode mining robots, we need ore and obsidian. To mine obsidian, we need to make different robots out of ore and clay. And to mine clay, we need robots made out of ore. Luckily, we start with one ore-mining robot, and can make more of these if we choose. It's all a matter of balancing our resources.

We have a number of different blueprints with which we can configure our robot factory. These blueprints tell us how many resources are required to make each robot. The factory can produce one robot every minute if we have the proper materials. Each robot mines one of its mineral per minute. In part 1, we want to mine as many geodes as we can in 24 minutes with each blueprint. In part 2, we'll only consider 3 blueprints, but try to mine for 32 minutes.

Solution Approach and Insights

As with Day 16, we can model this as a graph problem, but the search space is very large. So we'll need some way to prune that space. First, we'll exclude any scenario where we make so many robots of one type that we produce more resources that we could use in a turn. We can only produce one robot each turn anyway, so there's no point in, for example, having more clay robots than it takes clay to produce an obsidian robot. Second, we'll exclude states we've seen before. Third, we'll track the maximum number of geodes we've gotten as a result so far, and exclude any state that cannot reach that number.

This final criterion forces us to use a depth-first search, rather than a breadth-first search or Dijkstra's algorithm. Both of these latter algorithms will need to explore virtually the whole search space before coming up with a single solution. However, with DFS, we can get early solutions and use those to prune later searches.

Parsing the Input

We receive input where each line is a full blueprint, specifying how much ore is required to build another ore robot, how much is needed for a clay robot, and so on:

Blueprint 1: Each ore robot costs 4 ore. Each clay robot costs 2 ore. Each obsidian robot costs 3 ore and 14 clay. Each geode robot costs 2 ore and 7 obsidian.
Blueprint 2: Each ore robot costs 2 ore. Each clay robot costs 3 ore. Each obsidian robot costs 3 ore and 8 clay. Each geode robot costs 3 ore and 12 obsidian.

Let's start with a data type for a blueprint. It needs an ID number (we'll multiply the final answer by this in Part 1), as well as the costs for each robot. Obsidian robots require ore and clay, and then geode robots require ore and obsidian.

type InputType = [LineType]
type LineType = BluePrint

data BluePrint = BluePrint
  { idNumber :: Int
  , oreRobotCost :: Int
  , clayRobotCost :: Int
  , obsidianRobotCost :: (Int, Int)
  , geodeRobotCost :: (Int, Int)
  } deriving (Show)

We're fortunate here in that there are no issues with plurals and grammar in the input (unlike Day 16). So we can write a fairly tedious but straightforward parser for each line:

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
  string "Blueprint "
  bpNum <- parsePositiveNumber
  string ": Each ore robot costs "
  oreCost <- parsePositiveNumber
  string " ore. Each clay robot costs "
  clayCost <- parsePositiveNumber
  string " ore. Each obsidian robot costs "
  obsOreCost <- parsePositiveNumber
  string " ore and "
  obsClayCost <- parsePositiveNumber
  string " clay. Each geode robot costs "
  geodeOreCost <- parsePositiveNumber
  string " ore and "
  geodeObsCost <- parsePositiveNumber
  string " obsidian."
  return $ BluePrint bpNum oreCost clayCost (obsOreCost, obsClayCost) (geodeOreCost, geodeObsCost)

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

Depth First Search

The core of this problem is our depth-first search. We start with a type to capture the current search state. This has the number of each type of robot, the number of each resource we have, and the current time step.

data SearchState = SearchState
  { numOreRobots :: Int
  , numClayRobots :: Int
  , numObsidianRobots :: Int
  , numGeodeRobots :: Int
  , ore :: Int
  , clay :: Int
  , obsidian :: Int
  , geodes :: Int
  , time :: Int
  } deriving (Eq, Ord, Show)

Now we need to write a "neighbors" function. This tells us the possible "next states" that we can go to from our current state. This will take several additional parameters: the blueprint we're using, the maximum number of geodes we've seen so far, and the maximum time (since this changes from part 1 to part 2).

neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
  (BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
  st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) = ...

First, let's calculate the maximum reachable geodes from this state in the best possible case. Let's suppose we take our current geodes, plus all the geodes our current robots make, plus the number of geodes if we make a new geode robot every turn. If this optimistic number is still smaller than the largest we've seen, we'll return no possible moves:

neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
  (BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
  st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
  if maxGeodes < prevMax
    then return []
    else ...
  where
    maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]

Now we'll start considering hypothetical moves. One move is to build nothing. We call this stepTime, since we allow time to move forward and we just accumulate more resources. This is always an option for us.

neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
  (BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
  st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
  if maxGeodes < prevMax
    then return []
    else ...
  where
    maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
    stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)

Now let's think about making a geode robot. We can only do this if we have enough resources. So this expression will result in a Maybe value. The resulting state uses stepTime as its base, because it takes a minute to build the robot. The changes we'll make are to increment the geode robot count, and then subtract the resources we used based on the blueprint.

neighbors maxTime prevMax
  (BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
  st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
  if maxGeodes < prevMax
    then return []
    else ...
  where
    maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
    stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)
    tryMakeGeode = if ore' >= geoOre && obsidian' >= geoObs
      then Just $ stepTime {numGeodeRobots = geoRobots + 1, ore = ore stepTime - geoOre, obsidian = obsidian stepTime - geoObs}
      else Nothing

We'll do the same for building an obsidian-collecting robot, but with one exception. We'll also enforce obsRobots < geoObs. That is, if we already have enough obsidian robots to afford the obsidian for a geode robot every minute, we won't make any more obsidian robots.

neighbors maxTime prevMax
  (BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
  st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
  if maxGeodes < prevMax
    then return []
    else ...
  where
    maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
    stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)
    tryMakeGeode = if ore' >= geoOre && obsidian' >= geoObs
      then Just $ stepTime {numGeodeRobots = geoRobots + 1, ore = ore stepTime - geoOre, obsidian = obsidian stepTime - geoObs}
      else Nothing
    tryMakeObsidian = if ore' >= obsOre && clay' >= obsClay && obsRobots < geoObs
      then Just $ stepTime {numObsidianRobots = obsRobots + 1, ore = ore stepTime - obsOre, clay = clay stepTime - obsClay}
      else Nothing

And we do the same for constructing ore-collecting and clay-collecting robots.

neighbors maxTime prevMax
  (BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
  st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
  if maxGeodes < prevMax
    then return []
    else ...
  where
    maxGeodes = geodes' + (geoRobots * (maxTime - t)) + sum [1..(maxTime - t)]
    stepTime = SearchState oRobots cRobots obsRobots geoRobots (ore' + oRobots) (clay' + cRobots) (obsidian' + obsRobots) (geodes' + geoRobots) (t + 1)
    tryMakeGeode = if ore' >= geoOre && obsidian' >= geoObs
      then Just $ stepTime {numGeodeRobots = geoRobots + 1, ore = ore stepTime - geoOre, obsidian = obsidian stepTime - geoObs}
      else Nothing
    tryMakeObsidian = if ore' >= obsOre && clay' >= obsClay && obsRobots < geoObs
      then Just $ stepTime {numObsidianRobots = obsRobots + 1, ore = ore stepTime - obsOre, clay = clay stepTime - obsClay}
      else Nothing
    tryMakeOre = if ore' >= o && oRobots < maximum [o, c, obsOre, geoOre]
      then Just $ stepTime {numOreRobots = oRobots + 1, ore = ore stepTime - o}
      else Nothing
    tryMakeClay = if ore' >= c && cRobots < obsClay
      then Just $ stepTime {numClayRobots = cRobots + 1, ore = ore stepTime - c}
      else Nothing

Now to get all our options, we'll use catMaybes with the building moves, and also include stepTime. I reversed the options so that attempting to make the higher-level robots takes priority in the search. With this heuristic, we're likely to get to higher yields earlier in the search, which will improve performance.

neighbors :: (MonadLogger m) => Int -> Int -> BluePrint -> SearchState -> m [SearchState]
neighbors maxTime prevMax
  (BluePrint _ o c (obsOre, obsClay) (geoOre, geoObs))
  st@(SearchState oRobots cRobots obsRobots geoRobots ore' clay' obsidian' geodes' t) =
  if maxGeodes < prevMax
    then return []
    else do
      let (results :: [SearchState]) = reverse (stepTime : catMaybes [tryMakeOre, tryMakeClay, tryMakeObsidian, tryMakeGeode])
      return results
  where
    maxGeodes = ...
    stepTime = ...
    tryMakeOre = ...
    tryMakeClay = ...
    tryMakeObsidian = ...
    tryMakeGeode = ...

Now we need to write the search function itself. It will have two constant parameters - the blueprint and the maximum time. We'll also take variable values for the maximum number of geodes we've found, and the set of visited states. These will be our return values as well so other search branches can be informed of our results. Finally, we take a list of search states representing the "stack" for our depth-first search.

dfs :: (MonadLogger m) => Int -> BluePrint -> (Int, Set.Set SearchState) -> [SearchState] -> m (Int, Set.Set SearchState)

First we need a base case. If our search stack is empty, we'll return our previous values.

dfs maxTime bp (mostGeodes, visited) stack = case stack of
  [] -> return (mostGeodes, visited)
  ...

Next we have a second base case. If the top element of our stack has reached the maximum time, we'll compare its number of geodes to the previous value and return the larger one. We'll add the state to the visited set (though it probably already lives there).

dfs maxTime bp (mostGeodes, visited) stack = case stack of
  [] -> return (mostGeodes, visited)
  (top : rest) -> if time top >= maxTime
    then return (max mostGeodes (geodes top), Set.insert top visited)
    else ...

Now in the normal case, we'll get our neighboring states, filter them with the visited set, and add the remainder to the visited set.

dfs maxTime bp (mostGeodes, visited) stack = case stack of
  [] -> return (mostGeodes, visited)
  (top : rest) -> if time top >= maxTime
    then return (max mostGeodes (geodes top), Set.insert top visited)
    else do
      next <- neighbors maxTime mostGeodes bp top
      let next' = filter (\st -> not (st `Set.member` visited)) next
          newVisited = foldl (flip Set.insert) visited next'
      ...

Now you may have noticed that our function is set up for a fold after we remove the constant parameters:

(Int, Set.Set SearchState) -> [SearchState] -> m (Int, Set.Set SearchState)

To accomplish this, we'll have to make a sub-helper though, which we'll just call f. It will "accumulate" the maximum value by comparing to our previous max, starting with the input mostGeodes.

dfs maxTime bp (mostGeodes, visited) stack = case stack of
  [] -> return (mostGeodes, visited)
  (top : rest) -> if time top >= maxTime
    then return (max mostGeodes (geodes top), Set.insert top visited)
    else do
      next <- neighbors maxTime mostGeodes bp top
      let next' = filter (\st -> not (st `Set.member` visited)) next
          newVisited = foldl (flip Set.insert) visited next'
      foldM f (mostGeodes, newVisited) next'
  where
    f (prevMax, newVisited) st = do
      (resultVal, visited') <- dfs maxTime bp (prevMax, newVisited) (st : stack)
      return (max resultVal prevMax, visited')

This is all we need for our search! Now we just have to fill in a couple details to answer the question.

Answering the Question

For part 1, we'll write a fold wrapper that loops through each blueprint, gets its result, and then adds this to an accumulated value. We multiply each "quality" value (the maximum number of geodes) by the ID number for the blueprint. Note we use 24 as the maximum time.

type FoldType = Int

foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prev blueprint = do
  quality <- fst <$> dfs 24 blueprint (0, Set.empty) [initialState]
  return $ prev + (idNumber blueprint * quality)
  where
    initialState = SearchState 1 0 0 0 0 0 0 0 0

Then we glue all this together to get our part 1 solution.

type EasySolutionType = Int

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

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

For part 2, we do mostly the same thing. All that's different is that we only take the first 3 blueprints, we run them for 32 steps, and then we multiply those results.

type HardSolutionType = EasySolutionType

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard blueprints = foldM foldLineHard 1 (take 3 blueprints)

foldLineHard :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLineHard prev blueprint = do
  quality <- fst <$> dfs 32 blueprint (0, Set.empty) [initialState]
  return $ prev * quality
  where
    initialState = SearchState 1 0 0 0 0 0 0 0 0

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

And this gives us our answer! It takes a few minutes for each part, but isn't intractable. Perhaps I'll look for optimizations later.

Video

Coming eventually. I'm on vacation now so videos aren't a top priority.

Day 18 - Lava Surface Area

After a couple brutally hard days, today was a breather.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

For this problem we are estimating the exposed surface area of a series of cubes in 3D space. In part 1, we'll include the surface area of air pockets inside the structure. For part 2, we'll only consider those faces on the outside.

Solution Approach and Insights

For part 2, the key is to view it as a BFS problem. We want to explore all the space around the lava structure. Each time we try to explore a cube and find that it's part of the structure, we'll increase the count of faces.

Parsing the Input

Our input is a series of 3D coordinates. Each of these represents a 1x1x1 cube that is part of the lava structure.

2,2,2
1,2,2
3,2,2
2,1,2
2,3,2
2,2,1
2,2,3
2,2,4
2,2,6
1,2,5
3,2,5
2,1,5
2,3,5

Parsing this is a straightforward line-by-line solution.

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

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

parseLine :: (MonadLogger m) => ParsecT Void Text m Coord3
parseLine = do
  i <- parsePositiveNumber
  char ','
  j <- parsePositiveNumber
  char ','
  k <- parsePositiveNumber
  return (i, j, k)

Part 1

We'll fold through our coordinates and keep a running count of the number of faces that are exposed. We'll also track the set of cubes we've seen so far.

type FoldType = (Int, HS.HashSet Coord3)

initialFoldV :: FoldType
initialFoldV = (0, HS.empty)

foldLine :: (MonadLogger m) => FoldType -> Coord3 -> m FoldType
foldLine (prevCount, prevSet) c@(x, y, z) = ...

To start, let's get a helper to find the 6 neighboring coordinates in 3D space (diagonals don't count):

neighbors3 :: Coord3 -> [Coord3]
neighbors3 (x, y, z) =
  [ (x + 1, y, z)
  , (x - 1, y, z)
  , (x, y + 1, z)
  , (x, y - 1, z)
  , (x, y, z + 1)
  , (x, y, z - 1)
  ]

By default, adding a cube would add 6 new faces. However, for each face that borders a cube already in our set, we'll actually subtract 2! The face of the new cube will not be exposed and it will cover up the previously exposed face of the other cube. But that's pretty much all the logic we need for this part. We update the count and insert the new cube into the set:

foldLine :: (MonadLogger m) => FoldType -> Coord3 -> m FoldType
foldLine (prevCount, prevSet) c@(x, y, z) = return (prevCount + newCount, HS.insert c prevSet)
  where
    newCount = 6 - 2 * countWhere (`HS.member` prevSet) neighbors
    neighbors = neighbors3 c

And then to tie this part together:

processInputEasy :: (MonadLogger m) => InputType -> m Int
processInputEasy inputs = fst <$> foldM foldLine initialFoldV inputs

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

Part 2

As stated above, we'll first define a sort of bounding box for our structure. We want to explore all the space around it, but we need a limit so that we terminate quickly! Here's a Dimens type to capture those bounds, as well as a predicate for whether or not a coordinate is in bounds:

data Dimens = Dimens
  { minX :: Int
  , maxX :: Int
  , minY :: Int
  , maxY :: Int
  , minZ :: Int
  , maxZ :: Int
  } deriving (Show)

inBounds :: Dimens -> Coord3 -> Bool
inBounds (Dimens mnx mxx mny mxy mnz mxz) (x, y, z)  =
  x >= mnx && x <= mxx && y >= mny && y <= mxy && z >= mnz && z <= mxz

Now we'll write a breadth-first-search function to explore the surrounding space. This will take the dimensions and the cube set structure as constant inputs. Its state will include the current count of faces, the queue of coordinates to explore, and the set of coordinates we've already enqueued at some point.

bfs :: (MonadLogger m) => Dimens -> HS.HashSet Coord3 -> (Int, Seq.Seq Coord3, HS.HashSet Coord3) -> m Int
bfs dimens cubeSet (count, queue, visited) = ...

Our base case comes when the queue is empty. We'll just return our count:

bfs :: (MonadLogger m) => Dimens -> HS.HashSet Coord3 -> (Int, Seq.Seq Coord3, HS.HashSet Coord3) -> m Int
bfs dimens cubeSet (count, queue, visited) = case Seq.viewl queue of
  Seq.EmptyL -> return count
  top Seq.:< rest -> ...

Now to explore an object, we'll take a few steps:

1. Find its neighbors, but filter out ones we've explored or that are out of bounds.
2. Determine which neighbors are in the cube set and which are not.
3. Enqueue the coordinates outside the structure and add them to our visited set.
4. Recurse, updating the count with the number of neighbors that were in the structure.

bfs :: (MonadLogger m) => Dimens -> HS.HashSet Coord3 -> (Int, Seq.Seq Coord3, HS.HashSet Coord3) -> m Int
bfs dimens cubeSet (count, queue, visited) = case Seq.viewl queue of
  Seq.EmptyL -> return count
  top Seq.:< rest -> do
    let neighbors = filter (\c -> inBounds dimens c && not (HS.member c visited)) (neighbors3 top)
        (inLava, notLava) = partition (`HS.member` cubeSet) neighbors
        newQueue = foldl (Seq.|>) rest notLava
        newVisited = foldl (flip HS.insert) visited notLava
    bfs dimens cubeSet (count + length inLava, newQueue, newVisited)

And now our processing function just creates the dimensions, and triggers the BFS using an initial state, starting from the "minimum" position in the dimensions.

processInputHard :: (MonadLogger m) => InputType -> m Int
processInputHard inputs = do
  let cubeSet = HS.fromList inputs
      (xs, ys, zs) = unzip3 inputs
      dimens = Dimens (minimum xs - 1) (maximum xs + 1) (minimum ys - 1) (maximum ys + 1) (minimum zs - 1) (maximum zs + 1)
      initialLoc = (minX dimens, minY dimens, minZ dimens)
  bfs dimens cubeSet (0, Seq.singleton initialLoc, HS.singleton initialLoc)

And our last bit of code:

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

Video

Video is coming soon!

But in the meantime, here's another Star Wars prequel meme, inspired by the lava in today's problem.

Days 16 & 17 - My Brain Hurts

Day 16 Solution Code

Day 16 Video

Day 17 Solution Code

Day 17 Video

All 2022 Problems

Subscribe to Monday Morning Haskell!

The last couple days (Day 16 & Day 17) have been extremely rough. I finally got working solutions but my code is still quite messy and inefficient, especially for Day 16 part 2. So I won't be doing detailed write-ups until I get a chance to try optimizing those. I'll share some insights for each problem though.

Day 16 Insights

Full Problem Description

This is a graph problem, and my immediate thought was, of course, to use Dijkstra's algorithm. It's a bit odd though. I treated the "cost" of each step through time as the sum of the unreleased pressure. Thus our search should be incentivized to turn off higher pressure valves as quickly as possible.

At first, I tried generating new graph states for each timestep. But this ended up being waaay too slow on the larger input graph. So I simplified to pre-calculating all distances between nodes (using Floyd Warshall) and limiting the search space to only those nodes with non-zero flow. This worked well enough for Part 1.

However, this solution appears to break completely in Part 2, where we add a second actor to the search. Each actor takes a different amount of time to reach their nodes, so running a simultaneous search is extremely difficult; there are dozens of cases and branches because of the possibility of an actor being "in between" nodes while the other reaches its valve, and I wasn't confident I could make it work.

What ultimately got me the answer was the suggestion to bisect the nodes into two disjoint sets. Each actor will then try to maximize their score on one of the sets, and we'll add them together. This sounds problematic because we need to then consider an exponential number of possible bisections. However, the number of non-zero flow nodes is only 15.

We can then exclude half the bisections, because it doesn't matter which player goes after which set of nodes. For example, if we divide them into {A, B} and {C, D}, we'll get the same result no matter if Player 1 is assigned {A,B} or if Player 2 (the elephant) is assigned {A, B}.

This leaves about 16000 options, which is large but not intractable. My final solution ran in about 30 minutes, which is very far from ideal.

On reddit I saw other people claiming to do exhaustive searches instead of using Dijkstra, which seemed strange to me. Perhaps I missed certain opportunities to prune my search; I'm not sure.

This is also a very reward-driven problem, so machine learning could definitely be used in some capacity.

Day 17 Insights

Full Problem Description

This problem involved writing a sort of Tetris simulator, as blocks fall and are blown by jets until they land on top of one another. The first part was tricky, with lots of possible logic errors, but I eventually got it working, correctly simulating the height of 2022 blocks falling.

Then in part 2, we need the height for one trillion blocks. Not only is this too many iterations to run through a simulator doing collision checking, it's too many to iterate through in any sense.

The trick is to look for some way to find a cycle in the resulting structure. Then you can use some math to figure out what the final height will be. I naively thought that the structure would be kind enough to reset at some point to a "flat" surface like the beginning in conjunction with a reset of the pieces and a reset of the jet directions (a trillion iterations seemed like a lot of opportunities for that to happen!).

However, the secret was to look for the pattern in the delta of the maximum height with each block. So I ran about one hundred thousand iterations, got all these values, and deployed a cycle finding algorithm on the results. This algorithm is a variation on the "tortoise and hare" approach to finding a cycle in a link list. Within the first few thousand iterations, it found a cycle that lasted about 1900 blocks. So I ended up getting the right answer after a lot of math.

Conclusion

As I said, I'll try to do more detailed write-ups once I take another look at optimizing these problems. But for now I have to focus my time on solving the newer problems!

Day 15 - Beacons and Scanners

Unfortunately this solution took me quite a while to complete (I spent a while on an infeasible solution), so I don't have as much time for details on the writeup.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Solution Approach and Insights

My initial approach would effectively count every square that would be excluded, but this isn't feasible because the grid size is "millions by millions" for the large input.

If you actually consider the question being asked in the first part, then things become a bit easier. You can count the number of excluded spaces on single row by using arithmetic to gather a series of exclusion intervals. You can then sort and merge these, which allows you to count the number of excluded items very quickly.

Then in the second part, it is not prohibitive to go through this process for each of the 4 million rows until you find an interval list that has a gap.

Relevant Utilities

Manhattan distance:

type Coord2 = (Int, Int)

manhattanDistance :: Coord2 -> Coord2 -> Int
manhattanDistance (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1)

Get neighbors in each direction:

getNeighbors4Unbounded :: Coord2 -> [Coord2]
getNeighbors4Unbounded (x, y) =
  [ (x + 1, y)
  , (x, y + 1)
  , (x - 1, y)
  , (x, y - 1)
  ]

Parsing the Input

Here's a sample input:

Sensor at x=2, y=18: closest beacon is at x=-2, y=15
Sensor at x=9, y=16: closest beacon is at x=10, y=16
Sensor at x=13, y=2: closest beacon is at x=15, y=3
Sensor at x=12, y=14: closest beacon is at x=10, y=16
Sensor at x=10, y=20: closest beacon is at x=10, y=16
Sensor at x=14, y=17: closest beacon is at x=10, y=16
Sensor at x=8, y=7: closest beacon is at x=2, y=10
Sensor at x=2, y=0: closest beacon is at x=2, y=10
Sensor at x=0, y=11: closest beacon is at x=2, y=10
Sensor at x=20, y=14: closest beacon is at x=25, y=17
Sensor at x=17, y=20: closest beacon is at x=21, y=22
Sensor at x=16, y=7: closest beacon is at x=15, y=3
Sensor at x=14, y=3: closest beacon is at x=15, y=3
Sensor at x=20, y=1: closest beacon is at x=15, y=3

Simple line-by-line stuff, combining keywords and numbers.

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

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

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
  string "Sensor at x="
  i <- parseSignedInteger
  string ", y="
  j <- parseSignedInteger
  string ": closest beacon is at x="
  k <- parseSignedInteger
  string ", y="
  l <- parseSignedInteger
  return ((i, j), (k, l))

Part 1

To exclude coordinates on a particular row, determine if the distance from the sensor to that row is less than the manhattan distance to its nearest beacon. Whatever distance is leftover can be applied in both directions from the x coordinate (a column in this problem), giving an interval.

excludedCoords :: (MonadLogger m) => Int -> (Coord2, Coord2) -> m (Maybe Interval)
excludedCoords rowNum (sensor@(sx, sy), beacon) = do
  let dist = manhattanDistance sensor beacon
  let distToRow = abs (sy - rowNum)
  let leftoverDist = dist - distToRow
  if leftoverDist < 0
    then return Nothing
    else return $ Just (sx - leftoverDist, sx + leftoverDist)

Intervals should be sorted and merged together, giving a disjoint set of intervals covering the whole row.

mergeIntervals :: (MonadLogger m) => [Interval] -> m [Interval]
mergeIntervals [] = return []
mergeIntervals intervals = do
  let sorted = sort intervals
  mergeTail [] (head sorted) (tail sorted)
  where
    mergeTail :: (MonadLogger m) => [Interval] -> Interval -> [Interval] -> m [Interval]
    mergeTail accum current [] = return $ reverse (current : accum)
    mergeTail accum current@(cStart, cEnd) (first@(fStart, fEnd) : rest) = if fStart > cEnd 
      then mergeTail (current : accum) first rest
      else mergeTail accum (cStart, max cEnd fEnd) rest

Now let's count the total size of the intervals. In part 1, we have to be careful to exclude the locations of beacons themselves. This makes the operation quite a bit more difficult, introducing an extra layer of complexity to the recursion.

countIntervalsExcludingBeacons :: (MonadLogger m) => [Interval] -> [Int] -> m Int
countIntervalsExcludingBeacons intervals beaconXs = countTail 0 intervals (sort beaconXs)
  where
    countTail :: (MonadLogger m) => Int -> [Interval] -> [Int] -> m Int
    countTail accum [] _ = return accum
    countTail accum ((next1, next2) : rest) [] = countTail (accum + (next2 - next1 + 1)) rest []
    countTail accum ints@((next1, next2) : restInts) beacons@(nextBeaconX : restBeacons)
      | nextBeaconX < next1 = countTail accum ints restBeacons
      | nextBeaconX > next2 = countTail (accum + (next2 - next1)) restInts restBeacons
      | otherwise = countTail (accum - 1) ints restBeacons

Now combine all these together to get a final count of the excluded cells in this row. Note we need an extra parameter to these functions (the size) because the small input and large input use different row numbers on which to evaluate the excluded locations (10 vs. 2000000).

type EasySolutionType = Int

processInputEasy :: (MonadLogger m) => InputType -> Int -> m EasySolutionType
processInputEasy inputs size = do
  resultingIntervals <- mapM (excludedCoords size) inputs
  mergedIntervals <- mergeIntervals (catMaybes resultingIntervals)
  let beacons = nub $ filter (\c@(_, y) -> y == size) (snd <$> inputs)
  countIntervalsExcludingBeacons mergedIntervals (fst <$> beacons)

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

Part 2

In part 2, we need one extra helping function. This finds a "hole" in a series of intervals, as long as that hold comes before the "max" column.

findHole :: (MonadLogger m) => [Interval] -> Int -> m (Maybe Int)
findHole [] _ = return Nothing
findHole [(start, end)] maxCol
  | start > 0 = return (Just (start - 1))
  | end < maxCol = return (Just (end + 1))
  | otherwise = return Nothing
findHole ((start1, end1) : (start2, end2) : rest) maxCol = if end1 + 1 < start2 && (end1 + 1) >= 0 && (end1 + 1) <= maxCol
  then return (Just (end1 + 1))
  else findHole ((start2, end2) : rest) maxCol

The rest of the solution for part 2 involves combining our old code for a evaluating a single row, just done recursively over all the rows until we find one that has a hole.

processInputHard :: (MonadLogger m) => InputType -> Int -> m HardSolutionType
processInputHard inputs maxDimen = evaluateRow 0
  where
    evaluateRow :: (MonadLogger m) => Int -> m (Maybe Coord2)
    evaluateRow row = if row > maxDimen then return Nothing
      else do
        resultingIntervals <- mapM (excludedCoords row) inputs
        mergedIntervals <- mergeIntervals (catMaybes resultingIntervals)
        result <- findHole mergedIntervals maxDimen
        case result of
          Nothing -> evaluateRow (row + 1)
          Just col -> return $ Just (col, row)

Notice again we have an extra input, this time for the maxDimen, which is 20 for the small input and 4 million for the large part.

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

Video

YouTube link

Day 14 - Crushed by Sand?

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

We're in a cave and sand is pouring on top of us! Not so great. Because sand is rough, and coarse, and irritating, and it gets everywhere.

But as long as we can calculate how many grains of sand will actually pour into the cave, I guess it's all right. Here's a diagram of the empty cave, with rock lines (#) that can catch grains of sand. The sand is falling in from the + position, with coordinates (500, 0). Note that y values increase as we go down into the cave.

4     5  5
  9     0  0
  4     0  3
0 ......+...
1 ..........
2 ..........
3 ..........
4 ....#...##
5 ....#...#.
6 ..###...#.
7 ........#.
8 ........#.
9 #########.

As the sand pours in, it eventually falls into an abyss off the edge (at least in part 1).

.......+...
.......~...
......~o...
.....~ooo..
....~#ooo##
...~o#ooo#.
..~###ooo#.
..~..oooo#.
.~o.ooooo#.
~#########.
~..........
~..........
~..........

Parsing the Input

Our actual puzzle input (not the diagram) is laid out line-by-line, where each line has a variable number of coordinates:

498,4 -> 498,6 -> 496,6
503,4 -> 502,4 -> 502,9 -> 494,9

These coordinates give us the locations of the "rock lines" in the cave, denoted by # in the images above. The spaces between each input coordinate are filled out.

Parsing this isn't too hard. We use sepBy1 and a parser for the arrow in between, and then parse two comma separated numbers. Easy stuff with Megaparsec:

parseLine :: Monad m => ParsecT Void Text m [Coord2]
parseLine = sepBy1 parseNumbers (string " -> ")
  where
    parseNumbers = do
      i <- parsePositiveNumber 
      char ','
      j <- parsePositiveNumber
      return (i, j)

Getting all these lines line-by-line isn't a challenge. What's a little tricky is taking the coordinates and building out our initial set of all the coordinates covered by rocks. This should take a nested list of coordinates and return our final set.

type InputType = HS.HashSet Coord2

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  coordLines <- sepEndBy1 parseLine eol
  lift $ buildInitialMap coordLines

buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
...

How does this function work? Well first we need a function that will take two coordinates and fill in the missing coordinates between them. We have the horizontal and vertical cases. List comprehensions are our friend here (and tuple sections!). We just need to get the direction right so the comprehension goes the correct direction. We'll have one error case if the line isn't perfectly horizontal or vertical.

makeLine :: (MonadLogger m) => Coord2 -> Coord2 -> m [Coord2]
makeLine a@(a1, a2) b@(b1, b2) 
  | a1 == b1 = return $ map (a1,) (if a2 >= b2 then [b2,(b2+1)..a2] else [a2,(a2+1)..b2])
  | a2 == b2 = return $ map (,b2) (if a1 >= b1 then [b1,(b1+1)..a1] else [a1,(a1+1)..b1])
  | otherwise = logErrorN ("Line is neither horizontal nor vertical: " <> (pack . show $ (a, b))) >> return []

Now the rest of buildInitialMap requires a loop. We'll go through each coordinate list, but use recursion in such a way that we're always considering the front two elements of the list. So length 0 and length 1 are base cases.

buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
buildInitialMap = foldM f HS.empty
  where
    f :: (MonadLogger m) => HS.HashSet Coord2 -> [Coord2] -> m (HS.HashSet Coord2)
    f prevSet [] = return prevSet
    f prevSet [_] = return prevSet
    f prevSet (firstCoord : secondCoord : rest) = ...

And the recursive case isn't too hard either. We'll get the new coordinates with makeLine and then use another fold to insert them into the set. Then we'll recurse without removing the second coordinate.

buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
buildInitialMap = foldM f HS.empty
  where
    f :: (MonadLogger m) => HS.HashSet Coord2 -> [Coord2] -> m (HS.HashSet Coord2)
    f prevSet [] = return prevSet
    f prevSet [_] = return prevSet
    f prevSet (firstCoord : secondCoord : rest) = do
      newCoords <- makeLine firstCoord secondCoord
      f (foldl (flip HS.insert) prevSet newCoords) (secondCoord : rest)

So now we've got a hash set with all the "blocked" coordinates. How do we solve the problem?

Getting the Solution

The key to this problem is writing a function to drop a single grain of sand and take that to its logical conclusion. We need to determine if it either comes to rest (adding a new location to our hash set) or if it falls into the abyss (telling us that we're done).

This is easy as long as we can wrap our heads around the different cases. Most importantly, there's the end condition. When do we stop counting? Well once a grain falls below the maximum y-value of our walls, there will be nothing to stop it. So let's imagine we're taking this maxY value as a parameter.

dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces = ...

Now there are several cases here that we'll evaluate in order:

1. Grain is past maximum y
2. Space below the grain is empty
3. Space below and left of the grain is empty
4. Space below and right of the grain is empty
5. All three spaces are blocked.

We can describe all these cases using guards:

dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
  | y > maxY = ...
  | not (HS.member (x, y + 1) filledSpaces) = ...
  | not (HS.member (x - 1, y + 1) filledSpaces) = ...
  | not (HS.member (x + 1, y + 1) filledSpaces) = ...
  | otherwise = ...

The first case is our base case. We'll return False without inserting anything.

dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
  | y > maxY = return (filledSpaces, False)
  ...

In the next three cases, we'll recurse, imagining this grain falling to the coordinate in question.

dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
  | y > maxY = return (filledSpaces, False)
  | not (HS.member (x, y + 1) filledSpaces) = dropSand maxY (x, y + 1) filledSpaces
  | not (HS.member (x - 1, y + 1) filledSpaces) = dropSand maxY (x - 1, y + 1) filledSpaces
  | not (HS.member (x + 1, y + 1) filledSpaces) = dropSand maxY (x + 1, y + 1) filledSpaces
  ...

In the final case, we'll insert the coordinate into the set, and return True.

dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
  | y > maxY = return (filledSpaces, False)
  | not (HS.member (x, y + 1) filledSpaces) = dropSand maxY (x, y + 1) filledSpaces
  | not (HS.member (x - 1, y + 1) filledSpaces) = dropSand maxY (x - 1, y + 1) filledSpaces
  | not (HS.member (x + 1, y + 1) filledSpaces) = dropSand maxY (x + 1, y + 1) filledSpaces
  | otherwise = return (HS.insert (x, y) filledSpaces, True)

Now we just need to call this function in a recursive loop. We drop a grain of sand from the starting position. If it lands, we recurse with the updated set and add 1 to our count. If it doesn't land, we return the number of grains we've stored.

evolveState :: (MonadLogger m) => Int -> (HS.HashSet Coord2, Int) -> m Int
evolveState maxY (filledSpaces, prevSands) = do
  (newSet, landed) <- dropSand maxY (500, 0) filledSpaces
  if landed
    then evolveState maxY (newSet, prevSands + 1)
    else return prevSands

And all that's left is to call this with an initial value, including grabbing the maxY parameter from our initial hash set:

type EasySolutionType = Int

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputWalls = do
  let maxY = maximum $ snd <$> HS.toList inputWalls
  evolveState maxY (inputWalls, 0)

Part 2

Part 2 is not too different. Instead of imagining the sand falling into the abyss, we actually have to imagine there's an infinite horizontal line two levels below the maximum y-value.

...........+........
        ....................
        ....................
        ....................
        .........#...##.....
        .........#...#......
        .......###...#......
        .............#......
        .............#......
        .....#########......
        ....................
<-- etc #################### etc -->

This means the sand will eventually stop flowing once we have three grains below our starting location. We'll place one final grain at the start location, and then we'll be done.

............o............
...........ooo...........
..........ooooo..........
.........ooooooo.........
........oo#ooo##o........
.......ooo#ooo#ooo.......
......oo###ooo#oooo......
.....oooo.oooo#ooooo.....
....oooooooooo#oooooo....
...ooo#########ooooooo...
..ooooo.......ooooooooo..
#########################

The approach stays mostly the same, so we'll make a copy of our dropSand function, except with an apostrophe to differentiate it (dropSand'). We just have to tweak the end conditions in this function a little bit.

dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)

Our first condition of y > maxY should now work the same as the previous otherwise case, because all grains should come to rest once they hit maxY + 1. We'll insert the coordinate into our set and return True.

dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
  | y > maxY = return (HS.insert (x, y) filledSpaces, True)
  ...

The middle conditions don't change at all.

dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
  | y > maxY = return (HS.insert (x, y) filledSpaces, True)
  | not (HS.member (x, y + 1) filledSpaces) = dropSand' maxY (x, y + 1) filledSpaces
  | not (HS.member (x - 1, y + 1) filledSpaces) = dropSand' maxY (x - 1, y + 1) filledSpaces
  | not (HS.member (x + 1, y + 1) filledSpaces) = dropSand' maxY (x + 1, y + 1) filledSpaces
  ...

Now we need our otherwise case. In this case, we've determined that our grain is blocked on all three spaces below it. Generally, we still want to insert it into our set. However, if the location we're inserting is the start location (500, 0), then we should return False to indicate it's time to stop recursing! Otherwise we return True as before.

dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
  | y > maxY = return (HS.insert (x, y) filledSpaces, True)
  | not (HS.member (x, y + 1) filledSpaces) = dropSand' maxY (x, y + 1) filledSpaces
  | not (HS.member (x - 1, y + 1) filledSpaces) = dropSand' maxY (x - 1, y + 1) filledSpaces
  | not (HS.member (x + 1, y + 1) filledSpaces) = dropSand' maxY (x + 1, y + 1) filledSpaces
  | otherwise = return (HS.insert (x, y) filledSpaces, (x, y) /= (500, 0))

The rest of the code for part 2 stays basically the same!

evolveState' :: (MonadLogger m) => Int -> StateType -> m Int
evolveState' maxY (filledSpaces, prevSands) = do
  (newSet, landed) <- dropSand' maxY (500, 0) filledSpaces
  if landed
    then evolveState' maxY (newSet, prevSands + 1)
    else return (prevSands + 1)

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputWalls = do
  let maxY = maximum $ snd <$> HS.toList inputWalls
  evolveState' maxY (inputWalls, 0)

Answering the Question

And now we're able to solve both parts by combining our code.

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

This gives us our final answer, so we're done! This is another case where some better abstracting could save us from copying code. But when trying to write a solution as quickly as possible, copying old code is often the faster approach!

Video

YouTube Link

Day 13 - Sorting Nested Packets

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

For today's problem, we're parsing and comparing packets, which appear as integers in lists with potentially several levels of nesting. In part 1, we'll consider the packets 2-by-2 and determine how many pairs are already ordered correctly. Then in part 2, we'll sort all the packets and determine the right place to insert a couple new packets.

Solution Approach and Insights

Haskell works very well for this problem! The ability to use a sum type, simple recursive parsing, and easy ordering mechanism make this a smooth solution.

Parsing the Input

Here's a sample input:

[1,1,3,1,1]
[1,1,5,1,1]

[[1],[2,3,4]]
[[1],4]

[9]
[[8,7,6]]

[[4,4],4,4]
[[4,4],4,4,4]

[7,7,7,7]
[7,7,7]

[]
[3]

[[[]]]
[[]]

[1,[2,[3,[4,[5,6,7]]]],8,9]
[1,[2,[3,[4,[5,6,0]]]],8,9]

Once again, we have blank line separation. Another noteworthy factor is that the empty list [] is a valid packet.

So let's start with a simple sum type to represent a single packet:

data Packet =
  IntPacket Int |
  ListPacket [Packet]
  deriving (Show, Eq)

To parse an individual packet, we have two cases. The IntPacket case is easy:

parsePacket :: (MonadLogger m) => ParsecT Void Text m Packet
parsePacket = parseInt <|> parseList
  where
    parseInt = parsePositiveNumber <&> IntPacket
    parseList = ...

To parse a list, we'll of course need to account for the bracket characters. But we'll also want to use sepBy (not sepBy1 since an empty list is valid!) in order to recursively parse the subpackets of a list.

parsePacket :: (MonadLogger m) => ParsecT Void Text m Packet
parsePacket = parseInt <|> parseList
  where
    parseInt = parsePositiveNumber <&> IntPacket
    parseList = do
      char '['
      packets <- sepBy parsePacket (char ',')
      char ']'
      return $ ListPacket packets

And now to complete the parsing, we'll parse two packets together in a pair:

parsePacketPair :: (MonadLogger m) => ParsecT Void Text m (Packet, Packet)
parsePacketPair = do
  p1 <- parsePacket
  eol
  p2 <- parsePacket
  eol
  return (p1, p2)

And then return a whole list of these pairs:

type InputType = [(Packet, Packet)]

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

Getting the Solution

The core of the solution is writing a proper ordering on the packets. By using an Ordering instead of simply a Bool when comparing two packets, it will be easier to use this function recursively. We'll need to do this when comparing packet lists! So let's start with the type signature:

evalPackets :: Packet -> Packet -> Ordering

There are several cases that we can handle 1-by-1. First, to compare two IntPacket values, we just compare the underlying numbers.

evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
...

Now we have two cases where one value is an IntPacket and the other is a ListPacket. In these cases, we promote the IntPacket to a ListPacket with a singleton. Then we can recursively evaluate them.

evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
evalPackets (IntPacket a) b@(ListPacket _) = evalPackets (ListPacket [IntPacket a])  b
evalPackets a@(ListPacket _) (IntPacket b) = evalPackets a (ListPacket [IntPacket b])
...

Now for the case of two ListPacket inputs. Once again, we have to do some case analysis depending on if the lists are empty or not. If both are empty, the packets are equal (EQ).

evalPackets :: Packet -> Packet -> Ordering
...
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
  ([], []) -> EQ
  ...

If only the first packet is empty, we return LT. Conversely, if the second list is empty but the first is non-empty, we return GT.

evalPackets :: Packet -> Packet -> Ordering
...
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
  ([], []) -> EQ
  ([], _) -> LT
  (_, []) -> GT
  ...

Finally, we think about the case where both have at least one element. We start by comparing these two front packets. If they are equal, we must recurse on the remainder lists. If not, we can return that result.

evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
evalPackets (IntPacket a) b@(ListPacket _) = evalPackets (ListPacket [IntPacket a])  b
evalPackets a@(ListPacket _) (IntPacket b) = evalPackets a (ListPacket [IntPacket b])
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
  ([], []) -> EQ
  ([], _) -> LT
  (_, []) -> GT
  (a : rest1, b : rest2) ->
    let compareFirst = evalPackets a b
    in  if compareFirst == EQ
          then evalPackets (ListPacket rest1) (ListPacket rest2)
          else compareFirst

With this function in place, the first part is quite easy. We loop through the list of packet pairs with a fold. We'll zip with [1,2..] in order to match each pair to its index.

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = foldM foldLine initialFoldV (zip [1,2..] inputs)

type FoldType = Int

initialFoldV :: FoldType

foldLine :: (MonadLogger m) => FoldType -> (Int, (Packet, Packet)) -> m FoldType

The FoldType value is just our accumulated score. Each time the packets match, we add the index to the score.

initialFoldV :: FoldType
initialFoldV = 0

foldLine :: (MonadLogger m) => FoldType -> (Int, (Packet, Packet)) -> m FoldType
foldLine prev (index, (p1, p2)) = do
  let rightOrder = evalPackets p1 p2
  return $ if rightOrder == LT then prev + index else prev

And that gets us our solution to part 1!

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

Part 2

Part 2 isn't much harder. We want to sort the packets using our ordering. But first we should append the two divider packets [[2]] and [[6]] to that list.

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  let divider1 = ListPacket [ListPacket [IntPacket 2]]
      divider2 = ListPacket [ListPacket [IntPacket 6]]
      newInputs = (divider1, divider2) : inputs
      ...

Now we concatenate the pairs together, sort the list with the ordering, and find the locations of our two divider packets in the resulting list!

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  let divider1 = ListPacket [ListPacket [IntPacket 2]]
      divider2 = ListPacket [ListPacket [IntPacket 6]]
      newInputs = (divider1, divider2) : inputs
      sortedPackets = sortBy evalPackets $ concat (pairToList <$> newInputs)
      i1 = elemIndex divider1 sortedPackets
      i2 = elemIndex divider2 sortedPackets
      ...

As long as we get two Just values, we'll multiply them together (except we need to add 1 to each index). This gives us our answer!

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  let divider1 = ListPacket [ListPacket [IntPacket 2]]
  let divider2 = ListPacket [ListPacket [IntPacket 6]]
      newInputs = (divider1, divider2) : inputs
      sortedPackets = sortBy evalPackets $ concat (pairToList <$> newInputs)
      i1 = elemIndex divider1 sortedPackets
      i2 = elemIndex divider2 sortedPackets
  case (i1, i2) of
    (Just index1, Just index2) -> return $ (index1 + 1) * (index2 + 1)
    _ -> return (-1)
  where
    pairToList (a, b) = [a, b]

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

And now we're done with Day 13, and have just passed the halfway mark!

Video

YouTube Link!

Day 12 - Taking a Hike

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

For today's problem we're hiking through a trail represented with a 2D height map. We're given a start point (at low elevation) and an endpoint (at high elevation). We want to find the shortest path from start to end, but we can't increase our elevation by more than 1 with each step.

For the second part, instead of fixing our start position, we'll consider all the different positions with the lowest elevation. We'll see which one of these has the shortest path to the end!

Solution Approach and Insights

We can turn this into a graph problem, and because every "step" has the same cost, this is a textbook BFS problem! We'll be able to apply this bfsM function from the Algorithm.Search library.

Relevant Utilities

There are a few important pre-existing (or mostly pre-existing) utilities for 2D grids that will help with this problem.

Recall from Day 8 that we could use these functions to parse a 2D digit grid into a Haskell Array.

I then adapted the digit parser to also work with characters, resulting in this function.

Another useful helper is this function getNeighbors, which gives us the four neighbors (up/down/left/right) of a coordinate in a 2D grid, while accounting for bounds checking.

Parsing the Input

So given a sample input:

Sabqponm
abcryxxl
accszExk
acctuvwj
abdefghi

It's easy to apply the first step and get the digits into an array with our helper from above.

type InputType = (Grid2 Char, Coord2, Coord2)

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  charArray <- parse2DCharacterArray
  ...

However, we want to do a bit of post-processing. As you can see from my input type definition, we want to include the start and end coordinates of the grid as well. We'll also want to substitute the correct height values for those ('a' for 'S' and 'z' for 'E') back into the grid.

We start by finding the 'S' and 'E' characters and asserting that they exist.

postProcessGrid :: (MonadLogger m) => Grid2 Char -> m InputType
postProcessGrid parsedChars = do
  let allAssocs = A.assocs parsedChars
      start = find (\(c, v) -> v == 'S') allAssocs
      end = find (\(c, v) -> v == 'E') allAssocs
  case (start, end) of
    (Just (s, _), Just (e, _)) -> ...
    _ -> logErrorN "Couldn't find start or end!" >> return (parsedChars, (0, 0), (0, 0))

Now in the case they do, we just use the Array // operator to make the substitution and create our new grid.

postProcessGrid :: (MonadLogger m) => Grid2 Char -> m InputType
postProcessGrid parsedChars = do
  let allAssocs = A.assocs parsedChars
      start = find (\(c, v) -> v == 'S') allAssocs
      end = find (\(c, v) -> v == 'E') allAssocs
  case (start, end) of
    (Just (s, _), Just (e, _)) -> do
      let newGrid = parsedChars A.// [(s, 'a'), (e, 'z')]
      return (newGrid, s, e)
    _ -> logErrorN "Couldn't find start or end!" >> return (parsedChars, (0, 0), (0, 0))

So our final parsing function looks like this:

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  charArray <- parse2DCharacterArray
  lift $ postProcessGrid charArray

Getting the Solution

Now we'll fill in processInputEasy to get our first solution.

type EasySolutionType = Int

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = ...

To get the solution, we'll apply the bfsM function mentioned above. We need three items:

1. The function to determine the neighboring states
2. The end condition
3. The start value

For the purposes of our Breadth First Search, we'll imagine that our "state" is just the current coordinate. So the start value and end condition are given immediately.

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = do
  result <- bfsM (...) (\c -> return (c == end)) start
  ...

Now we need a function to calculate the neighbors. This will, of course, incorporate the getNeighbors helper above. It will also take our grid as a constant parameter:

validMoves :: (MonadLogger m) => Grid2 Char -> Coord2 -> m [Coord2]
validMoves grid current = do
  let neighbors = getNeighbors grid current
  ...

We now need to filter these values to remove neighbors that we can't move too because they are too high. This just requires comparing each new height to the current height using Data.Char.ord, and ensuring this difference is no greater than 1.

validMoves :: (MonadLogger m) => Grid2 Char -> Coord2 -> m [Coord2]
validMoves grid current = do
  let neighbors = getNeighbors grid current
      currentHeight = grid A.! current
  return $ filter (neighborTest currentHeight) neighbors
  where
    neighborTest currentHeight newCoord =
      let newHeight = grid A.! newCoord
      in  ord newHeight - ord currentHeight <= 1

And now we can fill in our definition for bfsM!

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = do
  result <- bfsM (validMoves parsedGrid) (\c -> return (c == end)) start
  ...

The last touch is to check the result because we want its size. If it's Nothing, we'll return maxBound as an error case. Otherwise, we'll take the length of the path.

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = do
  result <- bfsM (validMoves parsedGrid) (\c -> return (c == end)) start
  case result of
    Nothing -> return maxBound
    Just path -> return (length path)

Part 2

Now we need the "hard" solution for part 2. For this part, we take the same input but ignore the given start. Instead, we'll filter the array to find all positions with height a.

type HardSolutionType = EasySolutionType

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard (parsedGrid, _, end) = do
  let allStarts = fst <$> filter (\(_, h) -> h == 'a') (A.assocs parsedGrid)
  ...

Now we can map through each of these starts, and use our easy solution function to get the shortest path length! Then we'll take the minimum of these to get our answer.

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard (parsedGrid, _, end) = do
  let allStarts = fst <$> filter (\(_, h) -> h == 'a') (A.assocs parsedGrid)
  results <- mapM (\start -> processInputEasy (parsedGrid, start, end)) allStarts
  return $ minimum results

Note: while this solution for part 2 was the first solution I could think of and took the least additional code to write, we could optimize this part by reversing the search! If we start at the end point and search until we find any a elevation point, we'll solve this with only a single BFS instead of many!

Answering the Question

Nothing more is needed to calculate the final answers! We just parse the input and solve!

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

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

And we're done with Day 12, and almost halfway there!

Video

YouTube Link!