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.

Days 16 & 17 - My Brain Hurts

Day 16 Solution Code

Day 16 Video

Day 17 Solution Code

Day 17 Video

All 2022 Problems

Subscribe to Monday Morning Haskell!

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

Day 16 Insights

Full Problem Description

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

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

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

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

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

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

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

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

Day 17 Insights

Full Problem Description

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

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

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

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

Conclusion

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

Day 15 - Beacons and Scanners

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

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Solution Approach and Insights

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

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

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

Relevant Utilities

Manhattan distance:

type Coord2 = (Int, Int)

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

Get neighbors in each direction:

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

Parsing the Input

Here's a sample input:

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

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

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

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

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

Part 1

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

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

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

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

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

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

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

type EasySolutionType = Int

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

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

Part 2

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

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

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

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

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

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

Video

YouTube link

Day 14 - Crushed by Sand?

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

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

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

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

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

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

Parsing the Input

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

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

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

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

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

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

type InputType = HS.HashSet Coord2

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

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

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

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

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

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

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

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

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

Getting the Solution

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

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

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

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

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

We can describe all these cases using guards:

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

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

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

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

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

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

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

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

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

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

type EasySolutionType = Int

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

Part 2

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

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

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

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

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

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

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

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

The middle conditions don't change at all.

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

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

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

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

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

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

Answering the Question

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

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

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

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

Video

YouTube Link

Day 13 - Sorting Nested Packets

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

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

Solution Approach and Insights

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

Parsing the Input

Here's a sample input:

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

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

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

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

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

[]
[3]

[[[]]]
[[]]

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

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

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

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

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

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

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

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

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

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

And then return a whole list of these pairs:

type InputType = [(Packet, Packet)]

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

Getting the Solution

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

evalPackets :: Packet -> Packet -> Ordering

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

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

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

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

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

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

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

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

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

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

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

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

type FoldType = Int

initialFoldV :: FoldType

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

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

initialFoldV :: FoldType
initialFoldV = 0

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

And that gets us our solution to part 1!

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

Part 2

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

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

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

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

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

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

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

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

Video

YouTube Link!

Day 12 - Taking a Hike

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

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

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

Solution Approach and Insights

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

Relevant Utilities

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

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

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

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

Parsing the Input

So given a sample input:

Sabqponm
abcryxxl
accszExk
acctuvwj
abdefghi

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

type InputType = (Grid2 Char, Coord2, Coord2)

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

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

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

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

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

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

So our final parsing function looks like this:

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

Getting the Solution

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

type EasySolutionType = Int

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

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

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

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

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

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

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

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

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

And now we can fill in our definition for bfsM!

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

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

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

Part 2

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

type HardSolutionType = EasySolutionType

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

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

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

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

Answering the Question

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

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

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

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

Video

YouTube Link!

Day 11 - Monkeying Around

Today's problem was definitely the trickiest so far. It was the most complicated input format yet, and the part 2 twist definitely threw a wrench in the works. I also didn't get started until almost midnight, rather than the usual 9pm pacific time, which made things interesting.

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Monkeys have stolen our things and are throwing them around playing keep away. Apparently they can tell how worried we are about losing our items, and will throw the items to different monkeys depending on these numbers. Generally, we decide we'll track down the two monkeys who throw the most items.

In part 1, we'll simulate 20 rounds of the monkeys throwing and determine who threw the most items. In part 2 though, we encounter significant scaling problems. Our "worry" value for each item changes each round, often multiplicatively. Part 2 removes a feature that lets us divide the value back down each time. We also run 10000 rounds, so the size of these values will get out of control if we're not careful!

Solution Approach and Insights

Overall, this is a state evolution problem. We run a certain number of steps, and evolve our state each time. Folding mechanics will also play into this.

The key trick for part 2 lies in how we use the "worry" values. What happens each time a monkey inspects an item is that a divisibility check is performed, and the new monkey to get the item depends on the outcome of this check.

But since this is the only use for the worry value, instead of storing the value itself, we'll store a mapping of its modulus with respect to all the divisibility check values.

Parsing the Input

The input is quite intricate. We've taken a lot of "notes" on the monkeys' behavior. So we can parse the "worry" values of the items they start with. But we also note an "operation", which is how much the worry value rises each time that monkey inspects an item.

Finally, there is a "test" for each monkey. It will tell us a number to divide by. If the worry value is divisible by that number, it will throw to the first monkey on the following line. Otherwise, the item is thrown to the monkey on the "false" line.

Here's a sample input:

Monkey 0:
  Starting items: 79, 98
  Operation: new = old * 19
  Test: divisible by 23
    If true: throw to monkey 2
    If false: throw to monkey 3

Monkey 1:
  Starting items: 54, 65, 75, 74
  Operation: new = old + 6
  Test: divisible by 19
    If true: throw to monkey 2
    If false: throw to monkey 0

We'll need a MonkeyRule type that tracks the rules for each monkey telling us the operation performed on the worry value, the divisibility check number, and the monkeys we might throw to. From perusing the input files, we can see that the possible operations are 1.) adding a number, 2.) multiplying by a number and 3.) squaring the old number. So capture these in an Operation type.

data MonkeyRule = MonkeyRule
  { mrOperation :: Operation
  , testDivisible :: Int
  , throwTrue :: Int
  , throwFalse :: Int
  } deriving (Show)

data Operation =
  Addx Int |
  Multx Int |
  Square
  deriving (Show)

Now the rules themselves are static, so we can capture those in an Array. But we'll also want to track the sequence of items a monkey has. This will be dynamic, so it will live in a different HashMap structure.

type MonkeyRules = A.Array Int MonkeyRule
type MonkeyItems = HM.HashMap Int (Seq.Seq Int)
type InputType = (MonkeyItems, MonkeyRules)

Now let's parse the input! Essentially, we want one parser for each of the types of lines in our input. These follow the patterns we've generally seen, with string signifiers and then some numbers. Parsing an operation is a little tricky because of the old * old possibility, but alternatives still make this easy.

parseStartingItems :: (MonadLogger m) => ParsecT Void Text m [Int]
parseStartingItems = do
  string "  Starting items: "
  nums <- sepBy1 parsePositiveNumber (string ", ")
  eol
  return nums

parseOperation :: (MonadLogger m) => ParsecT Void Text m Operation
parseOperation = do
  string "  Operation: new = old "
  op <- try addOp <|> try multOp <|> squareOp
  eol
  return op
  where
    addOp = string "+ " >> parsePositiveNumber >>= return . Addx
    multOp = string "* " >> parsePositiveNumber >>= return . Multx
    squareOp = string "* old" >> return Square

parseTest :: (MonadLogger m) => ParsecT Void Text m Int
parseTest = do
  string "  Test: divisible by "
  i <- parsePositiveNumber
  eol
  return i

parseThrow :: (MonadLogger m) => ParsecT Void Text m Int
parseThrow = do
  string "    If "
  string "true" <|> string "false"
  string ": throw to monkey "
  i <- parsePositiveNumber
  eol
  return i

And now we combine all these together to parse a single Monkey. We'll return two tuples - one matching the monkey index to its sequence of items, and another to its rule.

parseMonkey :: (MonadLogger m) => ParsecT Void Text m ((Int, Seq.Seq Int), (Int, MonkeyRule))
parseMonkey = do
  string "Monkey "
  i <- parsePositiveNumber
  char ':'
  eol
  startingNums <- parseStartingItems
  op <- parseOperation
  test <- parseTest
  true <- parseThrow
  false <- parseThrow
  eol
  return ((i, Seq.fromList startingNums), (i, MonkeyRule op test true false))

The index is repeated because this makes it easier for us to construct our final types from the accumulation of monkey notes.

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
  monkeys <- some parseMonkey
  let indices = fst . snd <$> monkeys
  return (HM.fromList (fst <$> monkeys), A.array (minimum indices, maximum indices) (snd <$> monkeys))

Getting the Solution

So with each "round", we loop through the monkeys. Each monkey processes all their items. And in processing each item, we update our state, which is the mapping from monkeys to the items they hold. We will play a total of 20 rounds.

With these rules in mind, we can start writing our solution outline. We'll define our state type with the items map, as well as an occurrence map for the number of times a monkey inspects an item (this will help us get our answer).

type StateType = (MonkeyItems, OccMap Int)

initialStateV :: MonkeyItems -> StateType
initialStateV i = (i, emptyOcc)

Now we'll have functions for 1.) running the full round, 2.) processing each monkey and 3.) processing each item.

playRound :: (MonadLogger m) => MonkeyRules -> StateType -> m StateType

playMonkey :: (MonadLogger m) => MonkeyRules -> StateType -> Int -> m StateType

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType

We'll write our solveStateN function, which will call playRound the given number of times, recursing with n - 1 until it reaches 0.

solveStateN :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> m StateType
solveStateN _ 0 st = return st
solveStateN rules n st = do
  st' <- playRound rules st
  solveStateN rules (n - 1) st'

Playing a full round is a simple fold through the monkeys. We use the "rules" array as the source of truth for all the indices we want to loop through, and to make sure we loop through them in order.

-- Play a full round (all monkeys)
playRound :: (MonadLogger m) => MonkeyRules -> StateType -> m StateType
playRound rules st = foldM (playMonkey rules) st (Ix.range (A.bounds rules))

Processing a monkey is also a simple fold loop through the items, with the added part that we set the monkey's own item list to empty after it's done. This spares us the trouble of making two map updates each time we process an item.

-- Process all the items a single monkey has
playMonkey :: (MonadLogger m) => MonkeyRules -> StateType -> Int -> m StateType
playMonkey rules st monkey = do
  (newItems, newOcc) <- foldM (playItem rules monkey) st (fst st HM.! monkey)
  return (HM.insert monkey Seq.empty newItems, newOcc)

Processing one item is where most of the core logic happens. To do the core processing, we first have to think about "applying" an operation. For part 1, this is simple, because our worry values are just Int values.

applyOp :: Operation -> Int -> Int 
applyOp (Addx x) a = x + a
applyOp (Multx x) a = x * a
applyOp Square a = a * a

Now that we can apply the operation to our worry values, we can use the rules correctly. We start by incrementing the counter for the monkey processing the item, and fetching its rule from the array.

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
  ...

Now we update the worry value. First, we apply the operation. Then, just for part 1, we divide it by 3.

playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOp (mrOperation rule) item
      worry2 = worry1 `quot` 3
      ...

Now we perform the throw check to determine which monkey we're throwing to.

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOp (mrOperation rule) item
      worry2 = worry1 `quot` 3
      throwTo = if worry2 `mod` testDivisible rule == 0
                  then throwTrue rule else throwFalse rule
      ...

Finally, we gather the pre-existing items sequence for the new monkey, insert the appended sequence into our state, and then return the updated state.

playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOp (mrOperation rule) item
      worry2 = worry1 `quot` 3
      throwTo = if worry2 `mod` testDivisible rule == 0
                  then throwTrue rule else throwFalse rule
      currentThrowToSeq = items HM.! throwTo
      newItems = HM.insert throwTo (currentThrowToSeq Seq.|> worry2) items
  return (newItems, occ2)

This is all our core logic code for part 1. Before we combine everything and get our solution, let's see how the problem changes in part 2.

Part 2

In part 2 we no longer divide by 3, and we run 10000 rounds. This means our worry values will get too big. So instead of treating each item as an Int, we'll track its modulus with respect to all the divisibility check values in the rules, calling this a ModulusHash. Our stateful type will map monkey indices to sequences of this type instead of Int. Here's how we initialize this type given our starting values:

type ModuloHash = HM.HashMap Int Int
type StateType2 = (HM.HashMap Int (Seq.Seq ModuloHash), OccMap Int)

initialStateHard :: (MonkeyItems, MonkeyRules) -> StateType2
initialStateHard (items, rules) = (HM.map (fmap mkModuloHash) items, emptyOcc)
  where
    allDivisibles = testDivisible <$> A.elems rules
    mkModuloHash x = HM.fromList (map (\d -> (d, x `mod` d)) allDivisibles)

Applying an operation now looks a little different. The keys in this map are all the divisors for the different monkeys and their divisibility checks. The values in the map tell us the existing moduluses (moduli?) for each key. If we add a value to the modulus and re-take the modulus, the resulting modulus is the same as if we were just tracking the original number. Same with multiplication. We can use mapWithKeys to capture the idea of modifying each value, but using the key to help with this process.

applyOpHard :: Operation -> ModuloHash -> ModuloHash
applyOpHard (Addx x) modHash = HM.mapWithKey (\k v1 -> (v1 + x) `mod` k) modHash
applyOpHard (Multx x) modHash = HM.mapWithKey (\k v1 -> (v1 * x) `mod` k) modHash
applyOpHard Square modHash = HM.mapWithKey (\k v1 -> (v1 * v1) `mod` k) modHash

The inner parentheses on each line (as in (v1 + x)) are necessary! Otherwise x mod k takes precedence and you'll get the wrong result!

But now we can rewrite playItem to work with this function. It looks very similar, except without division by 3.

playItemHard :: (MonadLogger m) => MonkeyRules -> Int -> StateType2 -> ModuloHash -> m StateType2
playItemHard rules monkey (items, occ1) item = do
  let occ2 = incKey occ1 monkey
      rule = rules A.! monkey
      worry1 = applyOpHard (mrOperation rule) item
      throwTo = if worry1 HM.! testDivisible rule == 0
                  then throwTrue rule else throwFalse rule
      currentThrowToSeq = items HM.! throwTo
      newItems = HM.insert throwTo (currentThrowToSeq Seq.|> worry1) items
  return (newItems, occ2)

And now I found the perfect way to generalize this idea across part 1 and part 2.

Just kidding.

It was 1:30am at this point so I just copied most of my part 1 code over and tweaked the types a bit.

solveStateNHard :: (MonadLogger m) => MonkeyRules -> Int -> StateType2 -> m StateType2
solveStateNHard _ 0 st = return st
solveStateNHard rules n st = do
  st' <- playRoundHard rules st
  solveStateNHard rules (n - 1) st'

playRoundHard :: (MonadLogger m) => MonkeyRules -> StateType2 -> m StateType2
playRoundHard rules st = foldM (playMonkeyHard rules) st (Ix.range (A.bounds rules))

playMonkeyHard :: (MonadLogger m) => MonkeyRules -> StateType2 -> Int -> m StateType2
playMonkeyHard rules st monkey = do
  (newItems, newOcc) <- foldM (playItemHard rules monkey) st (fst st HM.! monkey)
  return (HM.insert monkey Seq.empty newItems, newOcc)

Answering the Question

At long last we're ready to answer the question. For part 1, we run solveStateN 20 times and take the snd value, which is the occurrence map.

type EasySolutionType = OccMap Int

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (initialItems, rules) = snd <$> solveStateN rules 20 (initialStateV initialItems)

Then we sort its elements, take the highest 2, and multiply them.

findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe Int)
findEasySolution finalOccMap = do
  let results = take 2 . reverse . sort $ M.elems finalOccMap
  return $ Just $ fromIntegral $ product results

Part 2 is similar, but we run 10000 rounds:

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard input@(_, rules) = snd <$> solveStateNHard rules 10000 (initialStateHard input)

And then before multiplying our top 2 values, we use fmap fromIntegral to convert them to Integer values, because the product will go beyond the Word limit.

findHardSolution :: (MonadLogger m) => HardSolutionType -> m (Maybe Integer)
findHardSolution finalOccMap = do
  let results = fmap fromIntegral . take 2 . reverse . sort $ M.elems finalOccMap
  return $ Just $ product results

And now we can combine our pieces!

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

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

Perhaps it was just the result of doing this late at night, but this problem was a definite marathon for me, and there are still 14 days left! So plenty of time for problems to get even harder. At some point next year I'll come back to this problem and clean up the abstraction.

Video

YouTube Link

Day 10 - Instruction Processing

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

Today we're processing some very simple machine instructions. The only instructions we have are "noop" (which does nothing) and "addx", which adds (or subtracts) an integer to a single register value.

In the first part, we'll deal with the "signal strength", which multiplies the cycle number by the current register value at certain cycles.

In the second part, we'll actually render a message using the register value in a very interesting way! The full instructions for this are a bit intricate. But essentially, depending on the register value and the cycle number, we either render a light bit # or a dark bit ., and then rearrange these bits in a 40-column by 6-row grid.

Solution Approach and Insights

The main thing here is determining how to handle the cycle updates. The stateful nature of the problem makes it a bit tricky - off-by-one issues are lurking everywhere! But if the cycle update is correct, the rest of the problem is pretty simple.

Relevant Utilities

In this problem, we're parsing integers, but they can be positive or negative. So here's a utility parser that can handle that:

parseSignedInteger :: (Monad m) => ParsecT Void Text m Int
parseSignedInteger = parsePositiveNumber <|> parseNegativeNumber

parseNegativeNumber :: (Monad m) => ParsecT Void Text m Int
parseNegativeNumber = do
  char '-'
  ((-1) *) <$> parsePositiveNumber

parsePositiveNumber :: (Monad m) => ParsecT Void Text m Int
parsePositiveNumber = read <$> some digitChar

Parsing the Input

Now, let's parse our problem input. Here's a small sample:

noop
addx 3
addx -5

We have "no-op" commands and "add" commands with a number. We start with an Instruction type to represent these:

data Instruction =
  Noop |
  Addx Int
  deriving (Show)

type InputType = [LineType]
type LineType = Instruction

And parsing each line is a simple alternative.

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = (string "noop" >> return Noop) <|> do
  string "addx "
  Addx <$> parseSignedInteger

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

Getting the Solution

This will be another folding solution, where we process a single instruction at a time. So we need a stateful type to capture all the information we need about the problem. We'll track the following fields:

1. The cycle number
2. The register value
3. The accumulated signal strength - this is our answer for part 1.
4. The accumulated render string - this will give us the answer for part 2.

Here's what the type looks like, along with its initial value.

initialMachineState :: MachineState
initialMachineState = MachineState 1 1 0 ""

data MachineState = MachineState
  { cycleNum :: Int
  , registerValue :: Int
  , accumSignalStrength :: Int
  , renderedString :: String
  }

So the question becomes…how do we process a single instruction?

processInstruction :: (MonadLogger m) => MachineState -> Instruction -> m MachineState

This is a little tricky because the no-op instruction only takes one cycle, while the add instruction takes two cycles. And it's only at the end of those two cycles that the register value is updated. So the key to this is another helper that bumps the cycle values without worrying about adding.

bumpCycle :: (MonadLogger m) => MachineState -> m MachineState

Here's how we apply this function within processInstruction:

processInstruction :: (MonadLogger m) => MachineState -> Instruction -> m MachineState
processInstruction ms Noop = bumpCycle ms
processInstruction ms0 (Addx i) = do
  ms1 <- bumpCycle ms0
  ms2 <- bumpCycle ms1
  return $ ms2 { registerValue = registerValue ms0 + i}

A no-op does nothing except bump the cycle. For adding, we bump twice and then update the register value using the instruction.

So what actually happens when we bump the cycle? Well most obviously, we increment the cycle number and keep the register value the same.

bumpCycle :: (MonadLogger m) => MachineState -> m MachineState
bumpCycle (MachineState cNum regVal accumSignal render) = do
  ...
  return $ MachineState (cNum + 1) regVal (...) (...)

So what happens with the other values? First let's think about the signal strength. At certain cycles (20, 60, 100, 140, 180, 220), we multiply the register value by the cycle number, and add this to the previous signal strength value.

bumpCycle :: (MonadLogger m) => MachineState -> m MachineState
bumpCycle (MachineState cNum regVal accumSignal render) = do
  let maybeAccum = if HS.member cNum signalCycles
        then regVal * cNum
        else 0
  ...
  return $ MachineState (cNum + 1) regVal (accumSignal + maybeAccum) (...)

signalCycles :: HS.HashSet Int
signalCycles = HS.fromList [20, 60, 100, 140, 180, 220]

And now for the second part, we need to render the right character. First, we need the "column" for the cycle number. We subtract 1 and mod by 40. Then we want to check if that value is equal to the register value (+/- 1). If it is, we'll use a "light" bit #. Otherwise, it's a "dark" bit .. And this completes our function!

bumpCycle :: (MonadLogger m) => MachineState -> m MachineState
bumpCycle (MachineState cNum regVal accumSignal render) = do
  let maybeAccum = if HS.member cNum signalCycles
        then regVal * cNum
        else 0
  let newChar = if ((cNum - 1) `mod` 40) `elem` [regVal - 1, regVal, regVal + 1] then '#' else '.'
  return $ MachineState (cNum + 1) regVal (accumSignal + maybeAccum) (newChar : render)

Answering the Question

For the "easy" part, we fold the instructions and collect the accumulated signal strength:

type EasySolutionType = Int

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = accumSignalStrength <$> foldM processInstruction initialMachineState inputs

For the "hard" part, we instead reverse the rendered string.

type HardSolutionType = String

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = reverse . renderedString <$> foldM processInstruction initialMachineState inputs

And now we're basically done! The only wrinkle is that you'll want to print the final string properly in order to see what the letters are! You'll want to use chunksOf 40.

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

solveHard :: FilePath -> IO (Maybe String)
solveHard fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  result <- processInputHard input
  mapM_ (logErrorN . pack) (chunksOf 40 result)
  return $ Just result

And that's all!

Video

YouTube Link

Day 9 - Knot Tracing

Solution code on GitHub

All 2022 Problems

Subscribe to Monday Morning Haskell!

Problem Overview

Full Description

For this problem, we're tracking the movement of a rope with knots in it as it moves through a 2D grid. Our input is a series of "moves" (up/right/down/left) with numbers attached for the times we move in that direction. The move tells us how the "head" of the rope moves. The "tail" (or tails) follow the head in a particular fashion.

In the first part, we only have two knots. We move the head knot, and then one tail knot follows. In the second part, we have 10 total knots. Each tail knot follows the knot ahead of it. In each case, our final answer is the number of unique coordinates traveled by the final knot in the rope.

Parsing the Input

This is mostly a line-by-line parsing problem, but we'll have a slight change.

All we're parsing in the input is the list of moves, each with a direction character and a number of moves.

R 4
U 4
L 3
D 1
R 4
D 1
L 5
R 2

We'll start with a type to represent the moves:

data Move = UpMove | RightMove | DownMove | LeftMove
  deriving (Show)

Parsing one line into a list of moves is pretty easy. We'll replicate the move using the number.

type LineType = [Move]

parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
  move <- up <|> right <|> down <|> left
  char ' '
  i <- parsePositiveNumber
  return $ replicate i move
  where
    up = char 'U' >> return UpMove
    right = char 'R' >> return RightMove
    down = char 'D' >> return DownMove
    left = char 'L' >> return LeftMove

And to combine this, we'll just concat the lines together.

type InputType = [Move]

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

Getting the Solution

There are basically three parts to this solution.

1. One function to move the head knot based on the move
2. One function to determine how a tail knot follows a head
3. Write a recursive loop function to move a whole list of knots to follow each other, and use this to fold over the moves.

The first function is an easy case statement.

nextHead :: Coord2 -> Move -> Coord2
nextHead (headX, headY) move = case move of
  UpMove -> (headX + 1, headY)
  RightMove -> (headX, headY + 1)
  DownMove -> (headX - 1, headY)
  LeftMove -> (headX, headY - 1)

Now for the knot-following logic. This has many cases. Note: the last 4 deal with the Cartesian Quadrants.

1. The tail is within 1 space (including diagonally) of the head. In this case the knot doesn't move.
2. Head and tail are in the same row. Tail moves one space horizontally towards the head.
3. Head and tail are in the same column. Tail moves one space vertically towards the head.
4. The head is in Quadrant 1 compared to the tail. Move tail up and right.
5. The head is in Quadrant 2. Move tail up and left..
6. The head is in Quadrant 3. Move tail down and left.
7. Otherwise (should be Quadrant 4), move tail down and right.

We can start with the "don't move" logic.

nextTail :: Coord2 -> Coord2 -> Coord2
nextTail head@(headX, headY) tail@(tailX, tailY) 
  | dontMove = tail
  ...
  where
    dontMove = abs (headX - tailX) <= 1 && abs (headY - tailY) <= 1
    ...

Next, consider the "same row" or "same column" logic. We need if-statements within these for the distinction of left/right or up/down.

nextTail :: Coord2 -> Coord2 -> Coord2
nextTail head@(headX, headY) tail@(tailX, tailY) 
  | dontMove = tail
  | headX == tailX = (tailX, if tailY < headY then tailY + 1 else tailY - 1)
  | headY == tailY = (if tailX > headX then tailX - 1 else tailX + 1, tailY)
  ...
  where
    dontMove = abs (headX - tailX) <= 1 && abs (headY - tailY) <= 1
    ...

And finally, we handle the quadrants.

nextTail :: Coord2 -> Coord2 -> Coord2
nextTail head@(headX, headY) tail@(tailX, tailY) 
  | dontMove = tail
  | headX == tailX = (tailX, if tailY < headY then tailY + 1 else tailY - 1)
  | headY == tailY = (if tailX > headX then tailX - 1 else tailX + 1, tailY)
  | q1 = (tailX + 1, tailY + 1)
  | q2 = (tailX + 1, tailY - 1)
  | q3 = (tailX - 1, tailY - 1)
  | otherwise = (tailX - 1, tailY + 1)
  where
    dontMove = abs (headX - tailX) <= 1 && abs (headY - tailY) <= 1
    q1 = headX > tailX && headY > tailY
    q2 = headX > tailX && headY < tailY
    q3 = headX < tailX && headY < tailY

Now for the final step. We'll fold through the moves, and keep an updated set of the coordinates where the tail has been, as well as the list of the knot locations. We'll parameterize by the number of knots.

type FoldType = (S.Set Coord2, [Coord2])

initialFoldV :: Int -> FoldType
initialFoldV n = (S.empty, replicate n (0, 0))

Now for the folding function itself. First let's handle an invalid case of empty knots.

foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = if null knots then logErrorN "Invalid case, empty knots list!" >> return (prevSet, knots)
  else do
    ...

Then we'll have a recursive helper within this function that will gradually accumulate the new knots from the old locations. So the first argument is the accumulator of new locations, and the second argument is the remaining knots to shift. So let's write the base case first.

foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = if null knots then logErrorN "Invalid case, empty knots list!" >> return (prevSet, knots)
  else do
    ...
  where
    hardFoldTail :: (MonadLogger m) => [Coord2] -> [Coord2] -> m [Coord2]
    hardFoldTail [] _ = logErrorN "Invalid case!" >> return []
    hardFoldTail done [] = return done
    ...

In the first case, we never expect the accumulated list to be empty, since we'll give it one to start. For the second case, we have no more remaining knots, so we return our list.

In the recursive case, we'll use our nextTail function based on the most recent knot in the first list. We'll add this new location to the front of the list and then recurse on the rest.

foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = ...
  where
    hardFoldTail :: (MonadLogger m) => [Coord2] -> [Coord2] -> m [Coord2]
    hardFoldTail [] _ = logErrorN "Invalid case!" >> return []
    hardFoldTail done [] = return done
    hardFoldTail done@(head : _) (next : rest) = hardFoldTail (nextTail head next : done) rest

Finally, we launch into this recursive call by first getting the nextHead of the top of the input list. Then we'll add the final knot's location to our accumulated set. Because we accumulated in reverse, this is currently on top of our resulting list. But then we'll reverse it when we return.

foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = if null knots then logErrorN "Invalid case, empty knots list!" >> return (prevSet, knots)
  else do
    newLocations <- hardFoldTail [nextHead (head knots) move] (tail knots)
    return (S.insert (head newLocations) prevSet, reverse newLocations)
  where
    hardFoldTail :: (MonadLogger m) => [Coord2] -> [Coord2] -> m [Coord2]
    hardFoldTail [] _ = logErrorN "Invalid case!" >> return []
    hardFoldTail done [] = return done
    hardFoldTail done@(head : _) (next : rest) = hardFoldTail (nextTail head next : done) rest

Answering the Question

Pulling the rest of this together is easy! We just use different parameters for the initial fold value in the easy and hard solution. (Admittedly, I did the first part a slightly different way before I knew what the second part was and refactored after).

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = do
  (finalSet, _) <- foldM foldMove (initialFoldV 2) inputs
  return $ S.size finalSet

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  (finalSet, _) <- foldM foldMove (initialFoldV 10) inputs
  return $ S.size finalSet

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

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

And this will give us our answer!

Video

YouTube Link