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!

Creating a Local Docker Image

Running a web server locally is easy. Deploying it so other people can use your web application can be challenging. This is especially true with Haskell, since a lot of deployment platforms don't support Haskell natively (unlike say, Python or Javascript). In the past, I've used Heroku for deploying Haskell applications. In fact, in my Practical Haskell and Effectful Haskell courses I walk through how to launch a basic Haskell application on Heroku.

Unfortunately, Heroku recently took away its free tier, so I've been looking for other platforms that could potentially fill this gap for small projects. The starting point for a lot of alternatives though, is to use Docker containers. Generally speaking, Docker makes it easy to package your code into a container image that you can deploy in many different places.

So today, we're going to explore the basics of packing a simple Haskell application into such a container. As a note, this is different from building our project with stack using Docker. That's a subject for a different time. My next few articles will focus on eventually publishing and deploying our work.

Starting the Dockerfile

So for this article, we're going to assume we've already got a basic web server application that builds and runs locally on port 8080. The key step in enabling us to package this application for deployment with Docker is a Dockerfile.

The Dockerfile specifies how to set up the environment in which our code will operate. It can include instructions for downloading any dependencies (e.g. Stack or GHC), building our code from source, and running the necessary executable. Dockerfiles have a procedural format, where most of the functions have analogues to commands we would run on a terminal.

Doing all the setup work from scratch would be a little exhausting and error-prone. So the first step is often that we want to "inherit" from a container that someone else has published using the FROM command. In our case, we want to base our container off of one of the containers in the Official Haskell repository. We'll use one for GHC 9.2.5. So here is the first line we'll put in our Dockerfile:

FROM haskell:9.2.5

Building the Code

Now we have to actually copy our code into the container and build it. We use the COPY command to copy everything from our project root (.) into the absolute path /app of the Docker container. Then we set this /app directory as our working directory with the WORKDIR command.

FROM haskell:9.2.5

COPY . /app
WORKDIR /app

Now we'll build our code. To run setup commands, we simply use the RUN descriptor followed by the command we want. We'll use 2-3 commands to build our Haskell code. First we use stack setup to download GHC onto the container, and then we build the dependencies for our code. Finally, we use the normal stack build command to build the source code for the application.

FROM haskell:9.2.5

...

RUN stack setup && stack build --only-dependencies
RUN stack build

Running the Application

We're almost done with the Dockerfile! We just need a couple more commands. First, since we are running a web server, we want to expose the port the server runs on. We do this with the EXPOSE command.

FROM haskell:9.2.5
...

EXPOSE 8080

Finally, we want to specify the command to run the server itself. Supposing our project's cabal file specifies the executable quiz-server, our normal command would be stack exec quiz-server. You might expect we would accomplish this with RUN stack exec quiz-server. However, we actually want to use CMD instead of RUN:

FROM haskell:9.2.5
...

CMD stack exec quiz-server

If we were to use RUN, then the command would be run while building the docker container. Since the command is a web server that listens indefinitely, this means the build step will never complete, and we'll never get our image! However, by using CMD, this command will happen when we run the container, not when we build the container.

Here's our final Dockerfile (which we have to save as "Dockerfile" in our project root directory):

FROM haskell:9.2.5

COPY . /app

WORKDIR /app

RUN stack setup && stack build --only-dependencies
RUN stack build

EXPOSE 8080
CMD stack exec quiz-server

Creating the Image

Once we have finished our Dockerfile, we still need to build it to create the image we can deploy elsewhere. To do this, you need to make sure you have Docker installed on your local system. Then you can use the docker build command to create a local image.

>> docker build -t quiz-server .

You can then see the image you created with the docker images command!

>> docker images
REPOSITORY TAG    IMAGE ID ...
quiz-server latest abcdef123456 ...

If you want, you can then run your application locally with the docker run command! The key thing with a web server is that you have to use the -p argument to make sure that the exposed ports on the docker container are then re-exposed on your local machine. It's possible to use a different port locally, but for our purposes, we'll just use 8080 for both like so:

>> docker run -it -p 8080:8080 --rm quiz-server

Conclusion

This creates a local docker image for us. But this isn't enough to run the program anywhere on the web! Next time we'll upload this image to a service to deploy our application to the internet!

If you want to keep up with this series, make sure to subscribe to our monthly newsletter!

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!

What's Next in 2023?

To start the year I wrote a few different articles about Chat GPT looking at what it thinks about Haskell. After some extra reflection, my emotional reaction probably matched that of a lot of other programmers. I felt plenty of excitement about the tasks that could become a lot easier using AI tools, but also a twinge of existential panic over the prospect of being replaced as a programmer. This latter feeling was especially acute when I thought about the future of this blog.

After all, what's the point of writing a blog post about a topic when someone can type their question into Chat GPT, get a response, and then even have a coherent conversation about the details?

However, there are still plenty of things that Chat GPT isn't able to help with yet. And as I'm planning out what I'm going to write about over the next year, I want to focus on material that isn't quite so replaceable.

The most pithy distinction that will be guiding me is show, don't tell. AI can tell you what you really want to know, but it's still going to be a long time before it can really show it to you in the context you want to use it. Even if you can have a coherent conversation with a chatbot, this doesn't mean it can adequately respond to all the needs you can present for a larger project. You can't just feed in your whole codebase to Chat GPT and have it tell you what you need to write next.

So on the blog this year, you can expect a lot of content will be more project-based. I'll be working on some larger, overarching ideas. I'll often be presenting these more through video than written style, since a video presents more of the context and struggles you can expect while actually creating something.

Another distinction with AI is that it can tell you what to learn, but not necessarily how to learn it. It doesn't necessarily know how humans acquire knowledge, especially in something as complex as programming. So you can expect more course-related content in this area, but I'll be aiming for multiple shorter courses (including one or two free courses) this year to complement the existing, longer course offerings.

If you want to keep up to date with all this, make sure to subscribe to our monthly newsletter!

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.

Writing Haskell with Chat GPT

In our last couple of articles, we've asked Chat GPT a bunch of questions about Haskell and functional programming. Today we're going to do one more exploration to see what kinds of Haskell code this chatbot can write.

Hello World

We'll start with a simple "Hello World" program.

How do I write a "Hello World" program in Haskell?

Chat GPT:

To write a "Hello World" program in Haskell, you can use the putStrLn function from the Prelude, which is Haskell's default library. This function takes a string as an argument and prints it to the console. Here's an example of a simple "Hello World" program in Haskell:

main :: IO ()
main = putStrLn "Hello, World!"

This program defines a function main that has the type IO (). The IO type is used for actions that perform input/output, and the () type represents the empty tuple, which has no contents. The main function is special in Haskell because it is the entry point of every executable Haskell program. When the program is run, the main function will be called and the string "Hello, World!" will be printed to the console.

You can compile and run this program using the ghc compiler, which is included with the Haskell Platform. First, save the program to a file named HelloWorld.hs. Then, open a terminal and navigate to the directory where you saved the file. To compile the program, type the following command:

ghc HelloWorld.hs

This will produce an executable file named HelloWorld. To run the program, type the following command:

./HelloWorld

This will print "Hello, World!" to the console.

Commentary

This not only gives the code to run the program, it also gives detailed instructions for running it using GHC. Recommending Stack and GHCup would be better advice for beginners though. I'm sure it would know how to describe using these tools if asked about them. But it would be best if it knew to recommend these tools to someone who didn't know about them. Still, I'm nit-picking a bit here.

Sorting Algorithms

So a "Hello World" program is one of the simplest things you can do though. How does ChatGPT do with writing some algorithmic code? Let's start with a couple simple sorting algorithms, quicksort and mergesort.

How can I write quicksort in Haskell?

Chat GPT:

Here is an implementation of quicksort in Haskell:

quicksort :: Ord a => [a] -> [a]
quicksort [] = []
quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++ [x] ++ quicksort [y | y <- xs, y > x]

This function defines a quicksort that sorts a list of elements that are part of the Ord type class (which includes types like Int, Char, and Double). The function uses a recursive approach to sort the list.

The base case of the recursion is the empty list, which is already sorted. For the recursive case, the function divides the list into three parts:

1. A sublist of elements that are less than or equal to the pivot element (x)
2. The pivot element itself
3. A sublist of elements that are greater than the pivot element

The function then recursively sorts the first and third sublists, and concatenates the sorted sublists with the pivot element to produce the final sorted list.

You can test this implementation by calling quicksort with a list of elements:

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

This should return the sorted list [1, 2, 3, 4, 5, 6, 7, 8, 9].

How can I write mergesort in Haskell?

Chat GPT:

Here is an implementation of mergesort in Haskell:

merge :: Ord a => [a] -> [a] -> [a]
merge xs [] = xs
merge [] ys = ys
merge (x:xs) (y:ys)
  | x <= y    = x : merge xs (y:ys)
  | otherwise = y : merge (x:xs) ys

mergesort :: Ord a => [a] -> [a]
mergesort []  = []
mergesort [x] = [x]
mergesort xs  = merge (mergesort left) (mergesort right)
  where
    mid   = length xs `div` 2
    left  = take mid xs
    right = drop mid xs

This implementation defines a merge function that merges two sorted lists into a single sorted list, and a mergesort function that sorts a list using the merge sort algorithm.

The merge function works by comparing the head elements of the two input lists, and adding the smaller of the two to the result list. It repeats this process until one of the input lists is empty, at which point it appends the remaining elements of the other list to the result.

The mergesort function works by dividing the input list into two halves, sorting each half using a recursive call to mergesort, and then merging the two sorted halves using the merge function.

You can test this implementation by calling mergesort with a list of elements:

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

This should return the sorted list [1, 2, 3, 4, 5, 6, 7, 8, 9].

Commentary

For quicksort, it comes up with a simple 3-line solution, and the mergesort solution is also quite succinct. However, one change I would make to the solution is to tail recursion. As with the "Hello, World" example though, the descriptions are very helpful for someone just learning the language.

Heap Sort

Quicksort and mergesort are one thing. These algorithms have fairly straightforward recursive implementations that work well in Haskell. What about heapsort?

How can I write heapsort in Haskell?

Chat GPT:

Here is an implementation of heapsort in Haskell:

heapify :: Ord a => [a] -> [a]
heapify xs = heapify' (length xs `div` 2 - 1) xs
  where
    heapify' (-1) xs = xs
    heapify' i xs = heapify' (i - 1) (heapifyOne i xs)

heapifyOne :: Ord a => Int -> [a] -> [a]
heapifyOne i xs = case cmp of
                    GT -> xs
                    _  -> heapifyOne' i cmp xs
  where
    cmp = compare (xs !! i) (xs !! child)
    child = if r < length xs && xs !! r > xs !! l then r else l
    l = 2 * i + 1
    r = 2 * i + 2

heapifyOne' i GT xs = xs
heapifyOne' i _  xs = heapifyOne (if r < length xs && xs !! r > xs !! l then r else l) $ swap i (if r < length xs && xs !! r > xs !! l then r else l) xs
  where
    l = 2 * i + 1
    r = 2 * i + 2

swap i j xs = [if k == i then xs !! j else if k == j then xs !! i else xs !! k | k <- [0..length xs - 1]]

sort :: Ord a => [a] -> [a]
sort [] = []
sort xs = y : sort ys
  where
    (y:ys) = heapify xs

This implementation defines a heapify function that turns a list into a heap, and a sort function that sorts a list using the heap sort algorithm.

The heapify function works by recursively transforming the list into a heap, starting from the middle of the list and working towards the beginning. It does this by repeatedly calling the heapifyOne function, which restores the heap property to a single element and its children in the heap.

The sort function works by repeatedly extracting the maximum element (the root of the heap) and placing it at the end of the result list, until the heap is empty.

You can test this implementation by calling sort with a list of elements:

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

This should return the sorted list [1, 2, 3, 4, 5, 6, 7, 8, 9].

Commentary

Very impressive, especially with the detailed description! This time, we do see tail recursion applied in the heapify function.

List Functions

How does it do with a more abstract prompt? I came up with this question based on Day 1 of the recently concluded 2022 Advent of Code.

Write a Haskell function to solve the following problem. The input is a list of lists of integers. We want to find the three lists with the largest sums, and add their sums together. So the output is just an integer.

Chat GPT:

Here is a function that solves the problem you described:

largestThreeSums :: [[Int]] -> Int
largestThreeSums xs = sum $ take 3 $ sortBy (flip compare) $ map sum xs

This function first applies the sum function to each sublist in xs, producing a list of sums. It then sorts this list in descending order using the sortBy function, and takes the first three elements using the take function. Finally, it sums these three elements using the sum function and returns the result.

To use this function, you can call it with a list of lists of integers as an argument:

largestThreeSums [[1, 2, 3], [4, 5, 6], [7, 8, 9], [10, 11, 12]]

This should return the result 33, which is the sum of the three largest sublists [7, 8, 9], [10, 11, 12], and [4, 5, 6].

Commentary

This is quite similar to my solution! So Chat GPT did an effective job parsing my description, and determining the right list functions to use to make an efficient, one-line solution.

Making a Server

For one more example, let's try doing something more practical, like a web server. This will require using libraries beyond Haskell's base packages. Once again, this works quite well!

How can I write a basic HTTP server in Haskell?

Chat GPT:

Here is an example of a basic HTTP server in Haskell using the wai and wai-extra libraries:

{-# LANGUAGE OverloadedStrings #-}

import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types (status200)
import Blaze.ByteString.Builder (copyByteString)
import qualified Data.ByteString.UTF8 as BU

app :: Application
app request respond = respond $
    case rawPathInfo request of
        "/hello" -> hello
        _        -> notFound
  where
    hello = responseBuilder
        status200
        [("Content-Type", "text/plain")]
        (copyByteString "Hello, World!")
    notFound = responseBuilder
        status404
        [("Content-Type", "text/plain")]
        (copyByteString "Not Found")

main :: IO ()
main = do
    putStrLn "Listening on port 3000"
    run 3000 app

This server listens for incoming HTTP requests on port 3000, and responds with a "Hello, World!" message for requests to the /hello path, and a "Not Found" message for all other paths.

To run this server, save the code to a file and compile it using the ghc compiler:

ghc Server.hs

This will produce an executable file named Server. To start the server, run the executable:

./Server

You should see the message "Listening on port 3000" printed to the console. You can then send HTTP requests to the server using a tool like curl or by opening a web browser and going to http://localhost:3000/hello. You should receive a "Hello, World!" response for the /hello path, and a "Not Found" response for all other paths.

Conclusion

So overall, Chat GPT does quite well with these basic challenges! It would be interesting to take this further still and see if we could make our server program more and more complex, like adding custom functionality for different routes. But Chat GPT definitely seems useful enough to help with basic tasks, even in a less well-known language like Haskell!

As a final note, I did check (out of curiosity) to see if Chat GPT seemed to know much about this blog. The answer appeared to be a resounding "no", leading to a good laugh for me! I asked, "do you know about Monday Morning Haskell?" This was the response I got from Chat GPT (emphasis is mine):

Yes, I am familiar with the term "Monday Morning Haskell." It refers to a programming style or approach that involves using the Haskell programming language to solve problems or write software on a Monday morning, with the implication being that Haskell is a particularly well-suited language for starting the work week off with a clear and focused mind. Haskell is a functional programming language known for its strong static type system, expressive type inference, and purity (lack of side effects). Many developers find that programming in Haskell can help them write clearer, more concise, and more maintainable code, and that it is especially well-suited for tasks that require reasoning about abstract concepts or dealing with complex data.

I might just have to add that description to the home page!

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.

Chat GPT and Functional Programming

Last week I explored what Chat GPT has to say about monads. But it's interesting to go beyond this single area and see what its thoughts are about functional programming (FP) in general, and how different languages fit within this paradigm.

So I asked the bot a few questions in these areas to see its response. In each section, the question is either the header, or if it is a longer question, it is given as a quote below the header. This will then be followed by Chat GPT's answer. I'll then follow most sections with some commentary.

We'll see that despite providing a lot of useful knowledge, the bot still sometimes struggles with consistency and the handling of ambiguous and contentious issues.

What is Functional Programming?

Chat GPT:

Functional programming is a programming paradigm that treats computation as the evaluation of mathematical functions. It is based on the idea of immutability and the avoidance of changing state and mutable data. In functional programming, functions are first-class citizens, meaning that they can be passed as arguments to other functions and returned as values from functions. This allows for the creation of higher-order functions that take other functions as input or return them as output.

Functional programming languages typically provide features such as higher-order functions, anonymous functions, and lazy evaluation to support the functional programming paradigm. Some examples of functional programming languages include Lisp, ML, Haskell, and Erlang.

Functional programming has a number of advantages, including the ability to write code that is easier to reason about, easier to test, and less prone to errors. It can also be more efficient in some cases, since it avoids the overhead of mutable state and allows for the use of techniques such as memoization and parallelization. However, it can also be more difficult to understand and learn for programmers who are used to imperative programming styles.

Commentary

So we start with an abstract definition: FP is a paradigm that views programming as the evaluation of mathematical functions. Then we get a slew of features (immutable state, functions as first class citizens, etc.). The features it lists include lazy evaluation, which is noteworthy.

It's interesting though to compare the advantages and disadvantages the bot mentions. It says that functional code is "easier" to reason about and test. It also lists efficiency as an important feature.

It then claims a disadvantage is that it is more difficult to understand...but mainly for people coming from imperative styles. So overall it should be easier to understand, but programmers who have been trained in other systems have a difficult time migrating to FP.

We'll come back to a number of these points later. But first, let's ask about a couple other languages and how they relate to functional programming.

Is C++ a Functional Language?

Chat GPT:

C++ is a multi-paradigm programming language, meaning that it supports several programming paradigms, including functional programming. However, C++ is not a purely functional language, as it also supports other paradigms such as imperative programming and object-oriented programming.

While C++ does not have some of the features that are commonly found in functional programming languages, such as first-class functions and lazy evaluation, it does support the creation of functions and the use of function pointers, which allows for the use of functional programming techniques to some extent.

For example, it is possible to write code in C++ that uses higher-order functions, anonymous functions, and recursive functions, which are all common features of functional programming languages. However, C++ does not have some of the other features that are commonly found in functional programming languages, such as pattern matching and algebraic data types.

Is Rust a Functional Language?

Chat GPT:

Like C++, Rust is a multi-paradigm programming language that supports functional programming, among other paradigms. Rust provides a number of features that make it suitable for functional programming, such as first-class functions, pattern matching, and algebraic data types.

However, Rust is not a purely functional language, as it also supports imperative programming and object-oriented programming. Rust's support for functional programming is more limited than that of languages that were specifically designed for functional programming, such as Haskell or ML.

Despite this, Rust's support for functional programming is sufficient to allow developers to write code in a functional style, and many Rust developers use functional programming techniques in their Rust code.

Commentary

What we see here is the difference between "what is functional programming" and "what is a functional language". C++ and Rust both allow you to use functional programming techniques even if FP isn't their primary paradigm. They're both intended to be flexible, multi-paradigm languages.

However, Rust facilitates FP much more through specific features, specifically abstract data types and pattern matching. Features like these are definitely an important part of why, culturally speaking, Rust programmers are more likely to employ functional programming ideas in their code.

What about the reverse? Does Chat GPT think we can use Haskell for Object Oriented Programming (OOP)?

Can Haskell be used in an object-oriented way?

Chat GPT:

Haskell is a purely functional programming language, which means that it does not support object-oriented programming as a primary paradigm. However, that does not necessarily mean that it is impossible to write object-oriented code in Haskell.

One way to write object-oriented code in Haskell is to use a typeclass-based approach, where types are defined as data types and behaviors are defined as functions on those data types. This can provide a way to define classes and objects, and to define methods on those objects.

Another way to write object-oriented code in Haskell is to use the "Object I/O" library, which provides a set of libraries and tools for building graphical user interface (GUI) applications in Haskell using an object-oriented style. This library allows developers to define classes, objects, and methods in a way that is similar to object-oriented languages such as Java or C++.

Overall, while Haskell is not a language that was designed for object-oriented programming, it is possible to use it in an object-oriented way with some effort. However, the functional programming paradigm is more idiomatic in Haskell, and most Haskell code is written in a functional style.

Commentary

This answer arrives at a conclusion I've had for a while. Typeclasses provide most of the abstraction you really need to get a lot of the benefits of OOP. Of course, they don't inherently provide stateful mutations, which are implicit in OOP, but this is possible to include in Haskell with the State monad.

It is interesting to see the trend that FP is a "more restrictive" paradigm. FP languages don't naturally address OOP as easily or as often as OOP languages allow functional ideas. But I would spin this as a positive for FP. Java and C++ have added more functional features (especially with lambda syntax) in the last few years because functional ideas are inherently useful. Haskell doesn't feel the need to incorporate OOP ideas as much because it doesn't need them.

Lazy Evaluation

In response to the first question, the bot included "lazy evaluation" as one of the features of functional programming, even though this is more specific to a few languages than to the whole paradigm. So I asked the following question:

Is lazy evaluation a defining characteristic of functional programming? Are there functional languages that use eager evaluation?

Chat GPT:

Lazy evaluation is a common feature of functional programming languages, but it is not a defining characteristic of functional programming. Lazy evaluation is a evaluation strategy that delays the evaluation of an expression until it is needed, rather than evaluating it as soon as it is bound to a variable.

Lazy evaluation can be useful in functional programming because it allows for the creation of infinite data structures, and it can also lead to more efficient code in some cases by avoiding the computation of unnecessary expressions. However, lazy evaluation is not a requirement for a language to be considered functional.

There are indeed functional programming languages that use eager evaluation, which is the opposite of lazy evaluation. Eager evaluation evaluates expressions as soon as they are bound to a variable, rather than delaying their evaluation until they are needed.

Some examples of functional programming languages that use eager evaluation include Miranda and Mercury. These languages provide many of the same features as lazy functional languages, such as higher-order functions and immutable data structures, but they use eager evaluation instead of lazy evaluation.

Commentary

So it seems like I've caught the bot in a bit of inconsistency. Lazy evaluation is not actually a necessary part of FP (like it implied in its first answer). But it's certainly more common in FP-oriented languages.

Disadvantages of FP

You said functional programming is more difficult to understand for programmers used to an imperative style. Are there any other disadvantages to functional programming?

Chat GPT:

Functional programming can be more difficult to understand for programmers who are used to imperative programming styles because it involves a different way of thinking about computation. In functional programming, the emphasis is on expressing the desired result of a computation rather than specifying how the computation should be performed, which can be a shift for programmers who are used to an imperative approach.

There are a few other potential disadvantages to functional programming to consider:

1. Performance: In some cases, functional code can be less efficient than imperative code, particularly if it makes heavy use of higher-order functions or lazy evaluation.
2. Debugging: Debugging functional code can be more difficult in some cases because it can be harder to understand the flow of control in a functional program, especially if the program makes heavy use of higher-order functions or anonymous functions.
3. Lack of familiar libraries: Depending on the language, the functional programming ecosystem may not have as many libraries and frameworks available as other paradigms. This can make it more difficult to build certain types of applications, and may require more work to integrate functional code with existing systems.
4. Limited adoption: Functional programming is not as widely used as imperative programming, which means that there may be a smaller pool of developers with functional programming experience to draw from. This can make it more difficult to find developers with functional programming skills, and can also make it more difficult to find resources and documentation when learning functional programming.

It's worth noting that these disadvantages are not unique to functional programming, and many of them can be mitigated with the right tools and techniques. Ultimately, the choice of programming paradigm should be based on the needs of the project and the preferences of the development team.

Commentary

So two of the 4 disadvantages still mainly come down to "Haskell/FP are hard because fewer people use them". If there was wider adoption (point #4), then there would be more familiar libraries (point #3).

It's curious though that performance is now listed as a disadvantage when "efficiency" was given as an advantage before! But both points are salient. Immutability does make parallelization easier, but a variety of issues can make FP less efficient, especially in Haskell, where a simple action like changing a value in a contiguous array might require re-copying the whole array.

Debugging is definitely an important issue to list as a disadvantage. Besides GHCI, I haven't used a specific debugging tool for Haskell with much success, so this is a good topic to explore.

In this discussion of the advantages and disadvantages of FP, I thought it would be a good idea to check on formal research in the area. Here's what Chat GPT had to say:

Research

You said functional programming can be easier to reason about and easier to test. Are there experiments or research comparing functional programming and other paradigms in these areas?

Chat GPT:

There have been a number of studies and surveys conducted over the years that have compared functional programming with other paradigms in terms of readability, maintainability, and other factors. These studies have generally found that functional programming can be easier to reason about and easier to test in some cases, although the results are not always clear-cut and can depend on a variety of factors.

For example, a study published in the Journal of Systems and Software in 2002 compared the maintainability of functional, imperative, and object-oriented programs and found that functional programs had fewer maintenance-related defects and were easier to understand than imperative programs.

Another study published in the Journal of Functional Programming in 2005 surveyed developers who had used both functional and imperative programming languages and found that the functional programmers reported fewer debugging and testing problems, and felt that their programs were easier to understand and modify.

Overall, it seems that functional programming can offer some benefits in terms of readability and testability, but more research is needed to determine the extent to which these benefits hold up in practice. It's also important to note that the choice of programming paradigm is just one factor that can impact the readability and maintainability of code, and other factors such as code style, architecture, and the use of good design practices can also be important.

Are There More Recent Studies?

Chat GPT:

There have been a number of more recent studies and surveys that have compared functional programming with other paradigms in terms of readability, maintainability, and other factors.

For example, a study published in the Journal of Systems and Software in 2015 examined the effect of functional programming on the reliability of software systems and found that functional programs had fewer defects and were easier to understand than imperative programs.

Another survey published in the ACM SIGPLAN Haskell Symposium in 2018 surveyed developers who had used both functional and imperative programming languages and found that the functional programmers reported fewer debugging problems and felt that their programs were easier to understand and modify.

Overall, it seems that the results of these more recent studies are consistent with the findings of earlier studies, which is that functional programming can offer some benefits in terms of readability, maintainability, and reliability, but more research is needed to determine the extent to which these benefits hold up in practice.

Linking to Studies

Can you link me to these studies?

Chat GPT:

Sure! Here are the links to the studies I mentioned:

1. "A comparison of the maintainability of object-oriented, imperative and functional programs" (2002): https://www.sciencedirect.com/science/article/pii/S0164121201001866
2. "Functional programming experience: A survey of functional and imperative programmers" (2005): https://www.researchgate.net/publication/220654465_Functional_programming_experience_A_survey_of_functional_and_imperative_programmers
3. "Functional programming and the reliability of software systems" (2015): https://www.sciencedirect.com/science/article/pii/S0164121214001442
4. "The State of Haskell in Industry" (2018): https://dl.acm.org/doi/10.1145/3236779.3236782

Commentary

Similar to my experience with asking Chat GPT for monad tutorials, none of these links work unfortunately. So Google is still definitely a better option for finding research and tutorials. But the summary we get from the bot is consistent with what I had thought before. A few groups have tried to study FP vs. OOP, and cautiously concluded some small advantages with FP, but it's difficult to resolve this issue conclusively.

Conclusion

Chat GPT provides a very good summary of the broad points about programming issues. However, when you really dig into the details, things aren't always completely consistent, and it is definitely not the best tool for finding research results just yet.

Next week, we'll take one final run with Chat GPT and see if it can write some Haskell code for us!

Monads According to a Robot

To start the new year, I thought it would be fun to spend some time messing around with the item that's all the rage right now - Chat GPT, the newest chatbot published by Open AI.

This chatbot can provide decent answers to most questions you throw at it, similar in concept to Google. However, instead of simply linking to other pages, it can provide fairly detailed and lengthy responses to the question, which Google cannot do. It also does a good job of maintaining conversational context, which is well beyond Google's abilities right now.

So I thought it would be interesting to ask it about a few Haskell-related topics. This week, we'll start with Monads, one of the trickier subjects involved with learning Haskell. I wanted to see how its suggestions line up with my Monads Series.

So the next three sections consist of me asking a question to Chat GPT, and its (often lengthy) response.

What is a Monad?

A monad is a concept from functional programming, which involves structuring programs as a series of computations that are strung together and can be combined in various ways. It's a way of abstracting out certain patterns of computation and making it easier to reuse and compose code. Monads are a bit of an advanced topic, and can be difficult to understand at first, but they can be very powerful once you get the hang of them.

What are Monads used for?

Monads are a powerful concept from functional programming that can be used to structure programs in a way that makes them easier to write, understand, and maintain.

At their core, monads are a way of abstracting out common patterns of computation and making them more modular and reusable. This allows you to write code that is more flexible and easier to work with, and can help you avoid common pitfalls and mistakes.

One of the key benefits of using monads is that they allow you to write code that is more declarative and abstract, rather than focusing on the details of how the computation is actually performed. This can make your code more concise and easier to read, and can help you avoid getting bogged down in the specifics of how the code works.

Another advantage of monads is that they make it easier to combine and compose different pieces of code, allowing you to build larger, more complex programs from smaller, more modular components. This can help you write more flexible and reusable code, and can make it easier to write programs that are modular, maintainable, and easy to understand.

Overall, monads are a powerful tool that can help you write better, more elegant code. They may take some time to understand and get used to, but once you get the hang of them, they can be a valuable asset in your programming toolkit.

How do I use Monads in Haskell?

To use monads in Haskell, you first need to have a basic understanding of the Haskell programming language and how it works. Once you have a handle on the basics, you can start learning about monads and how to use them in your programs.

One way to get started with monads in Haskell is to read through some tutorials or blog posts that introduce the concept and provide examples of how to use monads in your code. There are many resources available online that can help you learn about monads and how to use them in Haskell, including tutorials, blog posts, and videos.

Another way to learn about monads is to experiment with using them in your own programs. This can be a great way to get a feel for how monads work and how they can help you write better code. You can try writing simple programs that use monads, and see how they help you structure your code in a more modular and reusable way.

Overall, the best way to learn how to use monads in Haskell is to dive in and start experimenting with them in your own code. The more you use monads and see how they work, the better you will understand them and be able to apply them in your programs.

My Thoughts

I often describe a monad as a "computational context", and this idea is clearly seen in the bot's response. It talks about "abstracting patterns of computation", which is more or less the same thing. Its response also emphasizes some elements that get lost when we get too far into the weeds of a tutorial, like the modularity and reusability of code. Perhaps I'll go back and re-emphasize those pieces in my own tutorials.

The general response for "how do I use monads" is also good. Reading tutorials helps, and writing your own programs is ultimately essential. I'll link once again to my tutorial series, which contains some code examples you can try for yourself. For more detailed examples that allow you to work on your own project code, you can also try out my two monad-related courses, Making Sense of Monads, and Effectful Haskell.

Limitations

Unfortunately, the bot does a surprisingly poor job providing links to such tutorials. It provided me with several examples of blog posts that sounded very convincing, like "All About Monads by Brent Yorgey", and then it would link me to Brent Yorgey's blog page with a URL that contained the title "All About Monads" from 2009 or so. But the link was broken, suggesting the specific post of that title never existed. (Incidentally, the Haskell Wiki contains a page for All About Monads, but it doesn't seem as though Brent Yorgey was a contributor).

This process repeated with 3-4 different suggestions. It would have a monad related title, the name of a notable Haskell practitioner, and a link that seemed link it should work. And yet the link would be broken. In one case, it gave the title of Monads for the Working Haskell Programmer but attributed this work to Bartosz Milewski (instead of Theodore Newell, plainly listed as the author at the top of the page) along with an incorrect link (I found the correct link after googling the title).

I would have expected the bot to check links before supplying them, so this was definitely surprising behavior.

I also tried to push the boundaries and see if it could write a code-based tutorial for me. It would start writing some promising looking code, but eventually the whole thing would get deleted! Perhaps the code was getting too long and I was getting rate limited, I'm not sure. I'll experiment more with having it write code in the coming weeks.

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.