# Advent of Code 2021

This year I will publish my solutions for Advent of Code in Haskell, using Entangled to do **Literate Programming**.

## Advent of Code

Advent of Code is an anual coding challenge keeping nerds off the street for the entire merry month of decemeber. This is officially the best way to learn a new programming language or improve on your existing skills.

## Spoiler warning

If you’re still trying to solve AOC2021, this site contains spoilers.

## Entangled

Entangled is a tool for Literate Programming. My challenge for this years’ Advent of Code is to create a set of beautifull solutions, that are completely documented in a literate form. The idea is that the code you see here is the complete solution to a problem. Think of Entangled as a content-management system for code blocks in your Markdown documents. The code blocks are assembled into compilable code, while changes are also tracked back to your markdown files. This means you can still debug and work with your favourite IDE.

## Instructions

To run this code, I recommend installing Haskell using the GHCUp installer. Run all solutions:

`cabal run x2021 -- -a`

## Generic remarks

All solutions use the `RIO`

library to replace the standard `Prelude`

. This saves a long list of standard imports and is much better suited to modern Haskell practices. Most of the input parsing is done through `Megaparsec`

, for which I have a submodule that contains some common types and functions, see the boilerplate section.

## License

This code is licensed under the Apache v2 license, see `LICENSE`

file in this repository.

# Day 1: Sonar Sweep

It seems we are going on a deep dive this year! We are given the height data of a sonar sweep of the bottom of the sea.

file:app/Day01.hs

```
module Day01 where
import RIO
import qualified RIO.Text as Text
readInput :: MonadIO m => m [Int]
= do
readInput <- Text.lines <$> readFileUtf8 "data/day01.txt"
text return $ mapMaybe (readMaybe . Text.unpack) text
<<solution-day-1>>
<<run-solutions>>
```

The question is: how often do we find this sequence ascending? We may solve this by computing the difference between each consecutive element in the input list. Then we need to know the number of possitive numbers in the difference list:

«solution-day-1»

```
solutionA :: [Int] -> Int
= length . filter (> 0) . diff
solutionA where diff (a1:a2:as) = a2 - a1 : diff (a2:as)
= [] diff _
```

In the second part we need to do a sliding sum over the list of input numbers, reducing the problem to that of part A:

«solution-day-1»

```
solutionB :: [Int] -> Int
= solutionA . slidingSum
solutionB where slidingSum (a1:a2:a3:as) = a1 + a2 + a3 : slidingSum (a2:a3:as)
= [] slidingSum _
```

In hindsight, a more efficient solution would be:

```
= length . filter (> 0) . diff3
solutionB where diff3 (a1:a2:a3:a4:as) = a4 - a1 : diff3 (a2:a3:a4:as)
= [] diff3 _
```

The middle terms in the finite difference drop out.

# Day 2: Dive!

We are given our first mini instruction set! We need to steer the submarine using an instruction set `forward`

, `down`

or `up`

with a number attached. We get to do our first parsing of this year (yay!).

file:app/Day02.hs

```
module Day02 where
import RIO
import RIO.List (foldl)
import qualified RIO.Text as Text
import Parsing (readInputParsing, Parser, lexeme, string, integer, sepEndBy1, eol)
<<solution-day-2>>
<<run-solutions>>
```

We start by defining a datatype and the associated parser:

«solution-day-2»

```
data Instruction
= GoForward Int
| GoUp Int
| GoDown Int
deriving (Show)
instructions :: Parser [Instruction]
= sepEndBy1 (lexeme direction <*> integer) eol
instructions where direction = (string "forward" $> GoForward)
<|> (string "up" $> GoUp)
<|> (string "down" $> GoDown)
readInput :: (MonadIO m, MonadReader env m, HasLogFunc env) => m [Instruction]
= readInputParsing "data/day02.txt" instructions readInput
```

In the first part, we are asked to do some Turtle movement. We can reduce the set of instructions in a `foldl`

if we define a function that updates the position for each move:

«solution-day-2»

```
type Pos = (Int, Int)
moveA :: Pos -> Instruction -> Pos
GoForward dx) = (x + dx, y)
moveA (x, y) (GoUp dy) = (x, y - dy)
moveA (x, y) (GoDown dy) = (x, y + dy)
moveA (x, y) (
solutionA :: [Instruction] -> Int
= x * y
solutionA inst where (x, y) = foldl moveA (0, 0) inst
```

In the second part, the interpretation of the instructions changes slightly, but the only thing we have to change is the `moveA`

function and the corresponding accumulator data type (I’m using `NamedFieldPuns`

and `RecordWildCards`

, which I prefer over lenses in these simple cases):

«solution-day-2»

```
data Navigation = Navigation
navDepth :: Int
{ navAim :: Int
, navPos :: Int
,deriving (Show)
}
moveB :: Navigation -> Instruction -> Navigation
@Navigation{..} (GoForward x) = n{ navPos = navPos + x
moveB n= navDepth + navAim * x }
, navDepth @Navigation{..} (GoUp x) = n{ navAim = navAim - x }
moveB n@Navigation{..} (GoDown x) = n{ navAim = navAim + x }
moveB n
solutionB :: [Instruction] -> Int
= navPos * navDepth
solutionB inst where Navigation{..} = foldl moveB (Navigation 0 0 0) inst
```

# Day 3: Binary Diagnostic

file:app/Day03.hs

```
module Day03 where
import RIO
import RIO.List.Partial (foldl1)
import Parsing (Parser, sepEndBy1, char, eol, readInputParsing)
import qualified Data.Vector as Vector
import Data.Vector (Vector)
<<solution-day-3>>
<<run-solutions>>
```

Because of part 2 of this puzzle, I chose to put the bit sequence in a `Vector`

.

«solution-day-3»

```
type Bits = Vector Int
bitSequence :: Parser [Bits]
= sepEndBy1 bits eol
bitSequence where bits :: Parser Bits
= Vector.fromList
bits <$> some ( (char '0' $> 0)
<|> (char '1' $> 1))
readInput :: (HasLogFunc env) => RIO env [Bits]
= readInputParsing "data/day03.txt" bitSequence readInput
```

We need to compute the most common digit for each bit position. I solve this by rounding of the mean bit value.

«solution-day-3»

```
fromBinary :: Bits -> Int
= go 0 . Vector.toList
fromBinary where go n (b:bs) = go (2*n + b) bs
= n
go n []
invertBinary :: Bits -> Bits
= Vector.map (1 -)
invertBinary
mostCommon :: [Bits] -> Bits
= Vector.map ((`div` length b) . (* 2))
mostCommon b $ foldl1 (Vector.zipWith (+)) b
leastCommon :: [Bits] -> Bits
= invertBinary . mostCommon
leastCommon
solutionA :: [Bits] -> Int
= gammaRate * epsilonRate
solutionA input where gammaRate = fromBinary mc
= fromBinary $ invertBinary mc
epsilonRate = mostCommon input mc
```

In the second part we need to filter down on a single bit in each iteration. The most or least common bit value needs to be computed every time, as it changes when bit sequences are filtered out.

«solution-day-3»

```
findRating :: ([Bits] -> Bits) -> Int -> [Bits] -> Bits
= b
findRating _ _ [b] =
findRating f idx bits + 1)
findRating f (idx $ filter (\b -> b Vector.!? idx == mc Vector.!? idx) bits
where mc = f bits
oxygenGeneratorRating :: [Bits] -> Int
= fromBinary . findRating mostCommon 0
oxygenGeneratorRating
co2ScrubberRating :: [Bits] -> Int
= fromBinary . findRating leastCommon 0
co2ScrubberRating
solutionB :: [Bits] -> Int
= oxygenGeneratorRating bits * co2ScrubberRating bits solutionB bits
```

# Day 4: Giant Squid

We’re playing Bingo with a giant squid. This is why I love advent of Code!

Doing contrived array arithmetic is not seen as the strong suit of Haskell. Solving this in Python with NumPy would seem so much easier. I will use the nice `Massiv`

library, that implements multi-dimensional arrays, fancy indexing, stencil operations etc.

file:app/Day04.hs

```
module Day04 where
import RIO hiding (try)
import RIO.List (partition, headMaybe, lastMaybe)
import Parsing ( Parser, sepEndBy1, sepBy1, char, hspace, eol
, integer, lexeme, readInputParsing
, failOnException )import qualified Data.Massiv.Array as A
<<data-types-day-4>>
<<parser-day-4>>
<<solution-day-4>>
<<run-solutions>>
```

We need to have integers that we can mark when we play Bingo. I’ll make a generic `Mark`

container, that contains an extra boolean flag.

«data-types-day-4»

```
data Mark a = Mark
marked :: Bool
{ markValue :: a
,
}
markEq :: (Eq a) => a -> Mark a -> Mark a
Mark{ .. }
markEq v | v == markValue = Mark True markValue
| otherwise = Mark marked markValue
unmarked :: Mark a -> Bool
= not . marked
unmarked
type Board = A.Array A.B A.Ix2 (Mark Int)
data Bingo = Bingo
draws :: [Int]
{ boards :: [Board]
, }
```

Next, we need to parse the input data.

«parser-day-4»

```
drawsP :: Parser [Int]
= sepBy1 integer (lexeme $ char ',')
drawsP
boardP :: Parser Board
= sepEndBy1 row eol >>= toBoard
boardP where whitespace = lexeme (return ())
= whitespace >> some (Mark False <$> integer)
row = failOnException . A.fromListsM A.Seq
toBoard
bingoP :: Parser Bingo
= Bingo <$> drawsP <* eol <* eol <*> sepEndBy1 boardP eol
bingoP
readInput :: (HasLogFunc env) => RIO env Bingo
= readInputParsing "data/day04.txt" bingoP readInput
```

We win at Bingo if a row of column on a board is fully marked. The `Massiv`

library provides the nice functions `outerSlices`

and `innerSlices`

, allowing us to traverse all rows and columns:

«solution-day-4»

```
win :: Board -> Bool
= rows || columns
win b where rows = any (all marked) (A.outerSlices b)
= any (all marked) (A.innerSlices b) columns
```

Each time a number is called we mark all matching values:

«solution-day-4»

```
markBoard :: Int -> Board -> Board
= markEq n <$> b markBoard n b
```

For part A we need to figure out, the first board to win and the last number that was called. I won’t pretend this is the first implementation I came up with. After also solving part B, it turns out this is the most elegant and generic way to do it. The function `winners`

generates a list of `(Int, Board)`

pairs, giving in order each board winning and on what number:

«solution-day-4»

```
winSeq :: [Int] -> [Board] -> [(Int, Board)]
= []
winSeq [] _ = []
winSeq _ [] :draws) boards = map (d,) winners <> winSeq draws losers
winSeq (dwhere (winners, losers) = partition win $ markBoard d <$> boards
```

Now, to get the first winner, we can just get the `head`

of the list of all winners:

«solution-day-4»

```
score :: (Int, Board) -> Int
= n * sum (unmarkedValues $ A.toList b)
score (n, b) where unmarkedValues = map markValue . filter unmarked
solutionA :: Bingo -> Maybe Int
Bingo{..} = score <$> headMaybe (winSeq draws boards) solutionA
```

For part B we need to know the last board to win, which is now a trivial ajustment:

«solution-day-4»

```
solutionB :: Bingo -> Maybe Int
Bingo{..} = score <$> lastMaybe (winSeq draws boards) solutionB
```

# Day 5: Hydrothermal Venture

We need to plot a map of hydrothermal vents on a grid. We are given lists of coordinates in the form `x1,y1 -> x2,y2`

. Since we are plotting on 2D grids again, I reach for my friend `Massiv`

. Today, we’ll see how to program in Haskell like its Fortran 77.

file:app/Day05.hs

```
module Day05 where
import RIO hiding (try)
import RIO.ByteString (putStr)
import qualified RIO.Text as Text
import RIO.List.Partial (foldl1)
import RIO.List (partition, headMaybe, lastMaybe)
import Parsing ( Parser, sepEndBy1, sepBy1, char, hspace, eol
, integer, lexeme, readInputParsing
, string )import qualified Data.Massiv.Array as A
import qualified Data.Massiv.Array.Mutable as MA
<<data-types-day-5>>
<<parser-day-5>>
<<solution-day-5>>
<<extra-day-5>>
<<run-solutions>>
```

I like to have position variables that I can treat like applicatives.

«data-types-day-5»

```
newtype Vec2 a = Vec2 (a, a)
instance Show a => Show (Vec2 a) where
show (Vec2 (x, y)) = "(" <> show x <> " " <> show y <> ")"
instance Functor Vec2 where
fmap f (Vec2 (x, y)) = Vec2 (f x, f y)
instance Applicative Vec2 where
pure x = Vec2 (x, x)
Vec2 (ax, ay)) (Vec2 (bx, by)) = Vec2 (f ax bx, f ay by)
liftA2 f (
type Pos = Vec2 Int
pos :: Int -> Int -> Pos
= Vec2 (x, y)
pos x y
type Line = (Pos, Pos)
makeLine :: Int -> Int -> Int -> Int -> Line
= (pos x1 y1, pos x2 y2) makeLine x1 y1 x2 y2
```

Now we can parse the list of lines:

«parser-day-5»

```
lineP :: Parser Line
= makeLine <$> integer <* lexeme (char ',') <*> integer
lineP <* lexeme (string "->")
<*> integer <* lexeme (char ',') <*> integer
readInput :: (HasLogFunc env) => RIO env [Line]
= readInputParsing "data/day05.txt" (sepEndBy1 lineP eol) readInput
```

We need to plot the lines on a diagram. I will be using the `ST`

monad to do mutations on the diagram sequentially.

«data-types-day-5»

```
type Diagram = A.Array A.P A.Ix2 Int
type MutDiagram s = MA.MArray s A.P A.Ix2 Int
```

We need to know the min/max coordinates of the lines.

«solution-day-5»

```
lineMinMax :: Line -> (Pos, Pos)
= (min <$> a <*> b, max <$> a <*> b)
lineMinMax (a, b)
totalMinMax :: [Line] -> (Pos, Pos)
= foldl1 minMax $ lineMinMax <$> ls
totalMinMax ls where minMax (a, b) (c, d) = (min <$> a <*> c, max <$> b <*> d)
```

### Part A

In part A, we only need to treat the lines that are vertical or horizontal. We can write a routine that plots the line on the diagram, given a list of coordinates:

«solution-day-5»

```
plotCoords :: MutDiagram s -> [A.Ix2] -> ST s ()
= mapM_ (MA.modify_ d (return . (+ 1))) plotCoords d
```

Now we need to generate the list of coordinates, taking care that origin and end point can be flipped. I make a generic function that splits on several cases:

«solution-day-5»

```
range :: Int -> Int -> [Int]
range a b
| a > b = reverse [b .. a]
| otherwise = [a .. b]
lineCoords :: Line -> [A.Ix2]
lineCoords l<<day-5-line-cases>>
| otherwise = error $ "Illegal line: " <> show l
```

#### Horizontal

«day-5-line-cases»

`| horizontal l = horizontalCoords l`

«solution-day-5»

```
horizontal :: Line -> Bool
Vec2 (_, ay), Vec2 (_, by)) = ay == by
horizontal (
horizontalCoords :: Line -> [A.Ix2]
Vec2 (ax, y), Vec2 (bx, _))
horizontalCoords (= A.toIx2 . (,y) <$> range ax bx
```

#### Vertical

«day-5-line-cases»

`| vertical l = verticalCoords l`

«solution-day-5»

```
vertical :: Line -> Bool
Vec2 (ax, _), Vec2 (bx, _)) = ax == bx
vertical (
verticalCoords :: Line -> [A.Ix2]
Vec2 (x, ay), Vec2 (_, by))
verticalCoords (= A.toIx2 . (x,) <$> range ay by
```

Now, for the solution:

«solution-day-5»

```
plotLines :: [Line] -> Diagram
= runST $ do
plotLines l <- MA.newMArray (A.Sz2 1000 1000) 0
arr mapM_ (plotCoords arr . lineCoords) l
MA.freezeS arr
solutionA :: [Line] -> Int
= length . filter (> 1) . A.toList
solutionA . plotLines . filter (not . diagonal)
```

### Part B

Adding the case of diagonal lines:

«day-5-line-cases»

`| diagonal l = diagonalCoords l`

«solution-day-5»

```
diagonal :: Line -> Bool
Vec2 (ax, ay), Vec2 (bx, by))
diagonal (= abs (ax - bx) == abs (ay - by)
diagonalCoords :: Line -> [A.Ix2]
Vec2 (ax, ay), Vec2 (bx, by))
diagonalCoords (= A.toIx2 <$> zip (range ax bx) (range ay by)
solutionB :: [Line] -> Int
= length . filter (> 1) . A.toList . plotLines solutionB
```

# Day 6: Lanternfish

We need to simulate the number of lanternfish, each with a timer, spawning new lanternfish etc. Since we have an exponential growth process, to simulate this naively would be stupid, which is kind of the point of the exercise. We only have nine possible states for each fish, so instead we can tally **how many** lanternfish exist in each state. It turns out however, that programming it the stupid way first, turns this innocent looking exercise into a nice lesson on **Constraint Kinds**.

file:app/Day06.hs

```
module Day06 where
import RIO
import RIO.List (foldl)
import RIO.List.Partial (last)
import Parsing ( Parser, readInputParsing, sepEndBy1
, lexeme, char, integer)import RIO.Map (Map, (!?))
import qualified RIO.Map as Map
<<imports-day-6>>
<<parser-day-6>>
<<solution-day-6>>
<<run-solutions>>
```

As always, we first parse the input:

«parser-day-6»

```
csvInts :: Parser [Int]
= sepEndBy1 integer (lexeme (char ','))
csvInts
readInput :: (HasLogFunc env) => RIO env [Int]
= readInputParsing "data/day06.txt" csvInts readInput
```

The point of the exercise is that we can have a naive solution, which I implement here just for fun:

```
rules :: Int -> [Int]
rules clock| clock == 0 = [8, 6]
| otherwise = [clock - 1]
step :: [Int] -> [Int]
= (>>= rules) step
```

We then iterate the `step`

any number of times and get the length of the result:

«solution-day-6»

```
iterate :: Int -> (a -> a) -> a -> [a]
iterate n f x
| n == 0 = [x]
| otherwise = x : iterate (n - 1) f (f x)
solutionA :: [Int] -> Int
= length . last . iterate 80 step solutionA
```

The problem is that this solution doesn’t scale very well. To solve this more efficiently, we should keep track of how many fish are present in each state, then we can solve this problem in constant memory.

For tallying the amount of lanternfish in each state, I like to use a `Map Int Int`

.

«tally»

```
newtype Tally a = Tally { tallyMap :: Map a Integer }
deriving (Show)
```

Now we can implement `Semigroup`

and `Monoid`

:

«tally»

```
instance (Ord a) => Semigroup (Tally a) where
Tally a <> Tally b = Tally $ Map.unionWith (+) a b
instance (Ord a) => Monoid (Tally a) where
mempty = Tally mempty
```

Now we could do something like,

```
multiply :: (Ord a) => [a] -> Int -> Tally a
= foldMap (\k -> Tally $ Map.singleton k n) items
multiply items n
concatMap :: (Ord a) => (a -> [a]) -> Tally a -> Tally a
concatMap f (Tally a) = Map.foldMapWithKey (multiply . f) a
step :: Tally Int -> Tally Int
= concatMap rules step
```

However, things could be even pretier if we could define something like `Applicative`

on `Tally`

.

## Associated Constraint Types

What if we could implement the naive version of this problem in such a way that we can easily scale it up later? We could say:

```
rules :: (Applicative f, Semigroup (f Int)) => Int -> f Int
rules clock| clock == 0 = pure 8 <> pure 6
| otherwise = pure (clock - 1)
```

But this comes with another problem: our intended container `Tally`

can never be a `Functor`

or `Applicative`

, since it only works on sortable `Ord`

types. This kind of problem can only be solved if we are allowed associated constraint types with our class implementation. For this to work you need to enable the `TypeFamilies`

and `ConstraintKinds`

language extensions enabled.

We have to reimplement the `Functor > Applicative > Monad`

stack.

«tally»

```
class CFunctor f where
type ElemCt f a :: Constraint
cmap :: (ElemCt f a, ElemCt f b) => (a -> b) -> f a -> f b
class CFunctor f => CApplicative f where
cpure :: (ElemCt f a) => a -> f a
cliftA2 :: (ElemCt f a, ElemCt f b, ElemCt f c)
=> (a -> b -> c) -> f a -> f b -> f c
```

It is already impossible to implement the constraint version of `<*>`

from the type signature. The default implementation of `cliftA2 id`

assumes `ElemCt f (b -> c)`

which we can never guarantee. There is no problem however defining `CMonad`

.

«tally»

```
class CApplicative f => CMonad f where
cbind :: (ElemCt f a, ElemCt f b) => (a -> f b) -> f a -> f b
```

With these type classes in place, we can rewrite the solution to todays problem once again:

«solution-day-6»

```
rules :: (CApplicative f, ElemCt f Int, Semigroup (f Int)) => Int -> f Int
rules fish| fish == 0 = cpure 8 <> cpure 6
| otherwise = cpure (fish - 1)
step :: (CMonad f, ElemCt f Int, Semigroup (f Int)) => f Int -> f Int
= cbind rules step
```

### Implementation for List

There is the little annoyance that we need to be able to signal an `Empty`

constraint:

«tally»

```
class EmptyCt a
instance EmptyCt a
```

We now need to implement `CMonad`

on lists and we should have our first naive implementation back in working order.

«tally»

```
instance CFunctor [] where
type ElemCt [] a = EmptyCt a
= fmap
cmap
instance CApplicative [] where
= pure
cpure = liftA2
cliftA2
instance CMonad [] where
= (=<<) cbind
```

This even means we could have `do`

notation on constraint monads without loss of generality!

### Implementation for `Tally`

«tally»

```
instance CFunctor Tally where
type ElemCt Tally a = Ord a
Tally a) = Map.foldMapWithKey (\k v -> Tally (Map.singleton (f k) v)) a
cmap f (
multiply :: Tally a -> Integer -> Tally a
Tally a) n = Tally (Map.map (* n) a)
multiply (
instance CApplicative Tally where
= Tally $ Map.singleton a 1
cpure a Tally a) b = Map.foldMapWithKey
cliftA2 f (-> multiply (cmap (f k) b) v) a
(\k v
instance CMonad Tally where
Tally a) = Map.foldMapWithKey (multiply . f) a cbind f (
```

Notice that the implementation of `cliftA2`

is as if the elements were all stored in a list. This is motivated by the linear property that `(f <*> a) <> (f <*> b) == f <*> (a <> b)`

. We don’t need `cliftA2`

in our problem, but I included it here for completeness.

«tally»

```
size :: Tally a -> Integer
Tally a) = sum $ Map.elems a
size (
singleton :: Ord a => a -> Tally a
= cpure
singleton
fromList :: Ord a => [a] -> Tally a
= foldMap cpure
fromList
distinct :: Ord a => Tally a -> [a]
Tally a) = Map.keys a distinct (
```

file:app/Tally.hs

```
module Tally where
import RIO
import qualified RIO.Map as Map
import Data.Constraint (Constraint)
<<tally>>
```

«imports-day-6»

```
import Tally (Tally, CFunctor(..), CApplicative(..), CMonad(..), ElemCt)
import qualified Tally
```

«solution-day-6»

```
solutionB :: [Int] -> Integer
= Tally.size . last . iterate 256 step . Tally.fromList solutionB
```

# Day 7: The Treachery of Whales

But I like whales! We need to minimize a cost function. We have a list of integers, so we can reuse the parser from Day 6.

file:app/Day07.hs

```
module Day07 where
import RIO
import RIO.List (sort)
import RIO.List.Partial ((!!))
import Parsing ( Parser, readInputParsing, sepEndBy1
, lexeme, char, integer)
<<parser-day-7>>
<<solution-day-7>>
<<run-solutions>>
```

«parser-day-7»

```
csvInts :: Parser [Int]
= sepEndBy1 integer (lexeme (char ','))
csvInts
readInput :: (HasLogFunc env) => RIO env [Int]
= readInputParsing "data/day07.txt" csvInts readInput
```

We minimize the function,

\[f_a(x) = \sum_{i=1}^N |c_i - x|.\]

We know that the solution should be translation invariant. For \(N=2\) the cost function is equal at any point in between, only for \(N=3\) do we start to get a minimum, at the center most point. That would suggest a median. If we remove the outer two most points, the answer stays the same, repeat and we arrive at the center most point. Proven! Since we’re only interested in the value attained at the minimum, it doesn’t matter if we take the upper or lower median for even length sequences.

«solution-day-7»

```
costFuncA :: [Int] -> Int -> Int
= sum (map (abs . (x -)) cs)
costFuncA cs x
median :: [Int] -> Int
= sort x !! (length x `div` 2)
median x
solutionA :: [Int] -> (Int, Int)
= (loc, costFuncA as loc)
solutionA as where loc = sort as !! (length as `div` 2)
```

For part B, we get a distance function that goes like \(\sum_{i=1}^d d = d (d + 1) / 2\), where \(d = |c_i - x|.\) We arrive at a minimum at the mean \(x = \langle c_i \rangle\), and I can prove it. The cost function now is,

\[f_b(x) = \sum_{i=1}^N |c_i - x| (|c_i -x| + 1) / 2 = \sum_{i=1}^N \frac{1}{2}(c_i - x)^2 + \frac{1}{2}|c_i - x|.\]

For the square part, we have that the minimum of \(\sum (c_i - x)^2\) is found at,

\[\partial_x \sum (c_i - x)^2 / 2 = \sum x - c_i = Nx - \sum c_i = 0,\]

so \(x = \sum c_i / N = \langle c_i \rangle\), which is where we actually found our answer. The residual term of

\[\sum |c_i - x| / 2\]

is not differentiable, but we know how fast it grows. Since we have increments of 1, the quadratic term always grows equal or faster. Again, we’re only interested in the value, not the location of the minimum, so there we have it.

«solution-day-7»

```
costFuncB :: [Int] -> Int -> Int
= sum (map f cs)
costFuncB cs x where f c = abs (x - c) * (abs (x - c) + 1) `div` 2
mean :: [Int] -> Int
= sum x `div` length x
mean x
solutionB :: [Int] -> (Int, Int)
= (loc, costFuncB x loc)
solutionB x where loc = mean x
```

# Day 8: Seven Segment Search

Oh boy. This was a really nice puzzle. I think I managed to put the solution into readable code also.

file:app/Day08.hs

```
module Day08 where
import RIO
import RIO.List (foldl, find)
import Data.Map.Lazy (Map, (!?))
import qualified Data.Map.Lazy as Map
import Data.Tuple (swap)
import qualified RIO.Set as Set
import qualified RIO.Text as Text
import Parsing ( Parser, readInputParsing, sepEndBy1
, lexeme, char, eol)import Text.Megaparsec (takeWhile1P)
<<data-types-day-8>>
<<parser-day-8>>
<<solution-day-8>>
<<run-solutions>>
```

I’ll define a `Digit`

as a `Set Char`

and add some operations. We get the number 8 for free, and we can use it to invert other digits.

«data-types-day-8»

```
newtype Digit = Digit { digitSet :: Set Char }
deriving (Show, Ord, Eq)
instance Semigroup Digit where
Digit a <> Digit b = Digit $ (a Set.\\ b) `Set.union` (b Set.\\ a)
instance Monoid Digit where
mempty = Digit mempty
eight :: Digit
= Digit $ Set.fromList ['a'..'g']
eight
(<<<) :: Digit -> Digit -> Bool
Digit a <<< Digit b = a `Set.isSubsetOf` b
:: Digit -> Digit -> Digit
(\\)Digit a \\ Digit b = Digit $ a Set.\\ b
invert :: Digit -> Digit
= (eight \\)
invert
numberOfSegments :: Digit -> Int
Digit a) = Set.size a
numberOfSegments (
data Line = Line
signalPattern :: [Digit]
{ outputValues :: [Digit]
,deriving (Show) }
```

Made a superfluous parser for the characters ‘a’ through ‘g’.

«parser-day-8»

```
word :: Parser Text
= lexeme $ takeWhile1P (Just "letter a-g") (\c -> c >= 'a' && c <= 'g')
word
charSet :: Parser Digit
= Digit . Set.fromList . Text.unpack <$> word
charSet
lineP :: Parser Line
= Line <$> some charSet <* lexeme (char '|') <*> some charSet
lineP
readInput :: (HasLogFunc env) => RIO env [Line]
= readInputParsing "data/day08.txt" (sepEndBy1 lineP eol) readInput
```

Part A is very simple.

«solution-day-8»

```
solutionA :: [Line] -> Int
= length . filter ((`elem` [2, 3, 4, 7]) . numberOfSegments)
solutionA . concatMap outputValues
```

Part B is not simple. To find the correct mapping we have to play around with deducing digits from the digits we already know. I used a **lazy** `Map Int (Maybe Digit)`

to represent the partially decoded map. In the end I call `Map.mapMaybe`

which is strict, because it needs to do pattern matching. In this lazy approach we need to make sure that all entries to the map are there, but the values are not evaluated until needed. We have a `match`

function that checks if a digit matches a certain number.

«solution-day-8»

```
type Decoding = Map Digit Int
invertMap :: (Ord k, Ord v) => Map k v -> Map v k
= Map.fromList . map swap . Map.toList
invertMap
generateMap :: (Ord k) => (k -> v) -> [k] -> Map k v
= Map.fromList . map (\k -> (k, f k))
generateMap f
decode :: [Digit] -> Decoding
= invertMap $ Map.mapMaybe id decodedMap
decode digits where decodedMap = generateMap (\i -> find (match i) digits) [0..9]
= join . (decodedMap !?)
getDigit
match i digit<<digit-decode-cases>>
| otherwise = False
where l = numberOfSegments digit
```

The easy cases were already pointed to in part A:

«digit-decode-cases»

```
| i == 1 = l == 2
| i == 4 = l == 4
| i == 7 = l == 3
| i == 8 = l == 7
| i `elem` [0, 6, 9] = l == 6 &&
<<digit-6-segments>>
| i `elem` [2, 3, 5] = l == 5 &&
<<digit-5-segments>>
```

In the case of five segments, i.e. numbers 2, 3 and 5, we can make the following deductions:

- digit 1 is a subset of 3 but not of 2 and 5
- digit 2 contains the segment that is not in 6
- digit 5 does not contain the segment that is not in 6

«digit-5-segments»

```
False ( do
fromMaybe <- getDigit 1
one <- getDigit 6
six return $ i == 3 && one <<< digit
|| i == 2 && invert six <<< digit
&& not (one <<< digit)
|| i == 5 && not (invert six <<< digit)
&& not (one <<< digit) )
```

In the case of six segments, i.e. numbers 0, 6 and 9, we can make the following deductions:

- the inverse of digit 0 (center segment) is in 4 and 1 is a subset of 0
- the inverse of digit 6 is in 1
- the digit 4 is a subset of digit 9

«digit-6-segments»

```
False ( do
fromMaybe <- getDigit 1
one <- getDigit 4
four return $ i == 0 && invert digit <<< four
&& one <<< digit
|| i == 6 && invert digit <<< one
|| i == 9 && four <<< digit )
```

Importantly, these deduction rules do not contain loops.

«solution-day-8»

```
decodeLine :: Line -> Int
Line{..} = fromDecimal $ mapMaybe (d !?) outputValues
decodeLine where d = decode signalPattern
= foldl (\a b -> a * 10 + b) 0
fromDecimal
solutionB :: [Line] -> Int
= sum . map decodeLine solutionB
```

# Day 9: Smoke Basin

Lava tubes and more hydrothermal vents! I’ll be doing this in `Massiv`

again. Here is a rendering of my input data.

file:app/Day09.hs

```
module Day09 where
import RIO
import RIO.List (nub, sortBy)
import RIO.Char (ord)
import RIO.State (State, evalState, modify, get)
import RIO.ByteString (putStr)
import qualified RIO.Text as Text
import Parsing (digitArray, readInputParsing)
import Data.Massiv.Array (Array, Ix2(..))
import qualified Data.Massiv.Array as A
import qualified Data.Massiv.Array.Stencil as A.Stencil
import Data.MultiSet (MultiSet)
import qualified Data.MultiSet as MultiSet
import System.Random (mkStdGen, genWord8)
<<parsing-day-9>>
<<solution-day-9>>
<<run-solutions>>
<<show-data-day-9>>
```

Today’s input data is given as digits between 0 and 9.

«digit-array-parser»

```
type Array2' r a = A.Array r A.Ix2 a
type Array2 a = Array2' A.U a
digitArray :: Parser (Array2 Int)
= sepEndBy1 (some digit) eol >>= toArray2
digitArray where toArray2 = failOnException . A.fromListsM A.Seq
```

«parsing-day-9»

```
type Array2' r a = A.Array r A.Ix2 a
type Array2 a = Array2' A.U a
readInput :: (HasLogFunc env) => RIO env (Array2 Int)
= readInputParsing "data/day09.txt" digitArray readInput
```

I’ll be using `Massiv`

s stencil interface to solve this. Each stencil works on a neighbourhood of four pixels directly north, south, west and east from current location:

«solution-day-9»

```
neighbours :: [Ix2]
= [-1 :. 0, 1 :. 0, 0 :. -1, 0 :. 1] neighbours
```

For part A, we need to find the minima in the data.

«solution-day-9»

```
findMinStencil :: A.Stencil Ix2 Int Int
= A.Stencil.makeStencil (A.Sz (3 :. 3)) (1 :. 1) go
findMinStencil where go get
| all ((value <) . get) neighbours = value + 1
| otherwise = 0
where value = get (0 :. 0)
solutionA :: Array2 Int -> Int
= A.sum b
solutionA a where b :: Array2 Int
= A.compute $ A.Stencil.mapStencil (A.Fill 10) findMinStencil a b
```

In part B, we need to compute the watershed of the height map.

- Mark minima.
- Grow to a neighbourhood around each minimum:
- stop when two patches meet
- otherwise, repeat

We start by marking all minima found in part A with a unique integer identifier. I use a monadic map to give each minimum a number > 0.

«solution-day-9»

```
markBasins :: Array2 Int -> Array2 Int
= evalState (A.mapM markNonZero a) 0
markBasins a where promise :: State Int (Array2 Int)
= A.mapM markNonZero a
promise markNonZero :: Int -> State Int Int
markNonZero x| x /= 0 = modify (+ 1) >> get
| otherwise = return 0
```

The second step, we paint a pixel if all descending pixels have the same color. If a pixel is already colored, we leave it alone.

«solution-day-9»

```
same :: (Eq a) => [a] -> Maybe a
:a2:as)
same (a1| a1 == a2 = same (a2:as)
| otherwise = Nothing
= Just a
same [a] = Nothing
same _
watershedStencil :: A.Stencil Ix2 (Int, Int) (Int, Int)
= A.Stencil.makeStencil (A.Sz (3 :. 3)) (1 :. 1) go
watershedStencil where go get
| snd value /= 0 = value
| otherwise = paint color
where value = get (0 :. 0)
= filter (\p -> fst p < fst value) (get <$> neighbours)
descending = same $ snd <$> descending
color Just c) = (fst value, c)
paint (= value paint _
```

We keep doing this, until the watershed doesn’t change anymore. Afterwards, we need to clear pixels where the value is 9, this only happens at the edges.

«solution-day-9»

```
watershed :: Array2 (Int, Int) -> Array2 (Int, Int)
= A.compute . A.Stencil.mapStencil (A.Fill (10, 0)) watershedStencil
watershed
fixedPoint :: (Eq a) => (a -> a) -> a -> a
fixedPoint f x| x == next = x
| otherwise = fixedPoint f next
where next = f x
computeWatershed :: Array2 Int -> Array2 Int
= A.compute $ A.map snd erase9
computeWatershed a where minima = A.compute $ A.Stencil.mapStencil (A.Fill 10) findMinStencil a
= fixedPoint watershed (A.compute $ A.zip a $ markBasins minima)
runWs = A.map (\(a, b) -> if a == 9 then (a, 0) else (a, b)) runWs erase9
```

To get our answer, we need to measure the size of each patch, and then find the three largest ones. On Day 6 we already saw the `MultiSet`

in use, now again so:

«solution-day-9»

```
count :: Array2 Int -> MultiSet Int
= A.foldMono MultiSet.singleton
count
solutionB :: Array2 Int -> Int
= product $ take 3 $ sortBy (flip compare)
solutionB a $ map snd $ filter ((/= 0) . fst)
$ MultiSet.toOccurList $ count
$ computeWatershed a
```

Here is my rendering of the resulting watershed:

# Day 10: Syntax Scoring

Yay! Parsing! We can do this really well. First I’ll do a really stupid thing, and solve this by looking at `ParserErrorBundle`

objects returned by `Megaparsec`

. This was a nice exercise but a really stupid way to solve this days problem. At the end I have a better solution, basically using a stack.

file:app/Day10.hs

```
module Day10 where
import RIO hiding (lines)
import RIO.List.Partial ((!!))
import RIO.List (sort, headMaybe, foldl)
import qualified RIO.Set as Set
import qualified RIO.Text as Text
import RIO.ByteString (readFile)
import RIO.Text (lenientDecode, decodeUtf8With, lines)
import Parsing (Parser, char, eol)
import Text.Megaparsec ( parse, ParseErrorBundle(..), ErrorItem(..)
ParseError(..))
,
<<parsing-day-10>>
<<solution-day-10>>
<<run-solutions>>
```

Parsing these sequences is what we have `Megaparsec`

for.

«parsing-day-10»

```
data Bracket = Round | Square | Curly | Angle
deriving (Show, Eq, Ord, Enum)
data Chunk = Chunk Bracket [Chunk]
deriving (Show)
openingBracket :: Parser Bracket
= char '(' $> Round
openingBracket <|> char '{' $> Curly
<|> char '[' $> Square
<|> char '<' $> Angle
closingBracket :: Bracket -> Parser ()
= (case b of
closingBracket b Round -> char ')'
Square -> char ']'
Curly -> char '}'
Angle -> char '>') $> ()
chunkP :: Parser Chunk
= do
chunkP <- openingBracket
opening <- many chunkP
content
closingBracket openingreturn $ Chunk opening content
parseLine :: Text -> Either (ParseErrorBundle Text Void) Chunk
= parse chunkP ""
parseLine
<<read-lines>>
readInput :: (MonadIO m) => m [Text]
= readLines readInput
```

«read-lines»

```
readLines :: (MonadIO m) => m [Text]
= Text.lines . Text.decodeUtf8With Text.lenientDecode
readLines <$> readFile "data/day10.txt"
```

For part A we need to look at the parser error that we get and extract the unexpected character. We can pattern match to get at the character and assume if it doesn’t match, we have unexpected end-of-input.

«solution-day-10»

```
illegalChar :: ParseErrorBundle Text Void -> Maybe Char
= case bundleErrors e of
illegalChar e TrivialError _ (Just (Tokens (c :| _))) _) :| _ -> Just c
(-> Nothing _
```

Completing the score,

«solution-day-10»

```
scoreA :: Char -> Int
')' = 3
scoreA ']' = 57
scoreA '}' = 1197
scoreA '>' = 25137
scoreA = 0
scoreA _
solutionA :: [Text] -> Int
= sum . map scoreA . mapMaybe illegalChar
solutionA . lefts . map parseLine
```

In part B we look at the characters we expected when encountering end-of-input. We need to take care here: opening brackets are always expected, so we filter on closing brackets.

«solution-day-10»

```
expectedChar :: ParseErrorBundle Text Void -> Maybe Char
= case bundleErrors e of
expectedChar e TrivialError _ (Just EndOfInput) exp) :| _ -> getExpected exp
(-> Nothing
_ where getExpected :: Set (ErrorItem Char) -> Maybe Char
= headMaybe $ concatMap getToken
getExpected s $ Set.toList s
Tokens (t :| ts)) = filter closingChar (t : ts)
getToken (= []
getToken _ = (`elem` [')', ']', '}', '>']) closingChar
```

To autocomplete, I keep re-parsing the string, adding characters at the end, until the parsing succeeds. In principle, this could be done nicer from the parser, by creating a sort of stack trace. However, that would polute the code for actually parsing the correct structure.

«solution-day-10»

```
autocomplete :: Text -> Maybe Text
= go ""
autocomplete orig where go suffix = either (complete suffix)
const $ Just suffix)
($ orig <> suffix)
(parseLine = do
complete suffix err <- expectedChar err
c <> Text.singleton c) go (suffix
```

For computing the score, we encounter our old friend the `median`

function again.

«median»

```
median :: [Int] -> Int
= sort x !! (length x `div` 2) median x
```

«solution-day-10»

```
<<median>>
scoreB :: Text -> Int
= foldl f 0 . Text.unpack
scoreB where f i c = i * 5 + s c
')' = 1
s ']' = 2
s '}' = 3
s '>' = 4
s = 0
s _
solutionB :: [Text] -> Int
= median . map scoreB . mapMaybe autocomplete solutionB
```

### Simpler solution

Ok, that was fun but way too much work. There should be a much simpler solution. We can keep a stack.

file:app/Day10Alt.hs

```
module Day10Alt where
import RIO
import RIO.List.Partial ((!!))
import RIO.List (sort, headMaybe, foldl)
import qualified RIO.Text as Text
import RIO.ByteString (readFile)
readInput :: (MonadIO m) => m [Text]
= Text.lines . Text.decodeUtf8With Text.lenientDecode
readInput <$> readFile "data/day10.txt"
data ParseResult = Unexpected Char | AutoComplete Text | Success Text
parse :: Text -> ParseResult
= go (Text.unpack inp) []
parse inp where go [] [] = Success inp
exp = AutoComplete (Text.pack exp)
go [] :cs) exp = fromMaybe (Unexpected c)
go (c:cs) exp <|> open (c:cs) exp)
(close (c
:cs) (e:exp)
close (c| c == e = Just $ go cs exp
| otherwise = Nothing
:cs) [] = Nothing
close (c
:cs) exp
open (c| c == '(' = Just $ go cs (')':exp)
| c == '[' = Just $ go cs (']':exp)
| c == '<' = Just $ go cs ('>':exp)
| c == '{' = Just $ go cs ('}':exp)
| otherwise = Nothing
solutionA :: [Text] -> Int
= sum . map (score . parse)
solutionA where score (Unexpected ')') = 3
Unexpected ']') = 57
score (Unexpected '}') = 1197
score (Unexpected '>') = 25137
score (= 0
score _
<<median>>
solutionB :: [Text] -> Int
= median . mapMaybe (score . parse)
solutionB where score (AutoComplete t) = Just $ foldl (\i c -> i * 5 + points c) 0 (Text.unpack t)
= Nothing
score _ ')' = 1
points ']' = 2
points '}' = 3
points '>' = 4
points = 0
points _
<<run-solutions>>
```

# Day 11: Dumbo Octopus

This is clearly inspired on this demo of spontaneously synchronising fireflies.

file:app/Day11.hs

```
module Day11 where
import RIO
import RIO.ByteString (putStr)
import qualified RIO.Text as Text
import RIO.State (evalStateT, evalState, execState, MonadState, modify, get, gets)
import Data.Massiv.Array (Ix2(..))
import qualified Data.Massiv.Array as A
import Parsing (digitArray, readInputParsing)
<<parser-day-11>>
<<solution-day-11>>
<<show-data-day-11>>
<<run-solutions>>
```

We can reuse the input parser from day 9.

«parser-day-11»

```
type Array2' r a = A.Array r A.Ix2 a
type Array2 a = Array2' A.U a
readInput :: (HasLogFunc env) => RIO env (Array2 Int)
= readInputParsing "data/day11.txt" digitArray readInput
```

Each iteration can be divided in three steps:

`clock`

: advance the cycle of every octopus by one`flash`

: resolve the flashing, marking flashed octopusses`reset`

: reset the counter for flashed octopusses

I put these steps into a state monad.

«solution-day-11»

```
step :: (MonadState (Array2 Int) m) => m Int
= clock >> flash >> reset step
```

The `clock`

advances every counter by one tick.

«solution-day-11»

```
clock :: (MonadState (Array2 Int) m) => m ()
= modify (A.compute . A.map (+ 1)) clock
```

To resolve the flashes, I use my friend the *stencil* again. I mark flashed octopusses by setting their counter to 1000. That way, they don’t get counted twice.

«solution-day-11»

```
home :: A.Ix2
= 0 :. 0
home
neighbours :: [A.Ix2]
= [ -1 :. -1, 0 :. -1, 1 :. -1
neighbours -1 :. 0, 1 :. 0
, -1 :. 1, 0 :. 1, 1 :. 1 ]
,
count :: (a -> Bool) -> [a] -> Int
= sum . map (\x -> if f x then 1 else 0)
count f
countArray :: (A.Unbox a) => (a -> Bool) -> Array2 a -> Int
= A.sum . A.map (\x -> if f x then 1 else 0)
countArray f
flashed :: Int -> Bool
= c > 9 && c < 1000
flashed c
flashStencil :: A.Stencil Ix2 Int Int
= A.makeStencil (A.Sz (3 :. 3)) (1 :. 1) go
flashStencil where go get = if flashed (get home) then 1000
else get home + count (flashed . get) neighbours
flash :: MonadState (Array2 Int) m => m ()
= do
flash <- gets $ countArray flashed
n if n == 0 then return ()
else modify go >> flash
where go :: Array2 Int -> Array2 Int
= A.compute . A.mapStencil (A.Fill 0) flashStencil go
```

At the `reset`

, I count how many values are larger than 1000, and set them back to 0.

«solution-day-11»

```
reset :: MonadState (Array2 Int) m => m Int
= do
reset <- gets $ countArray (>= 1000)
n $ A.compute . A.map (\x -> if x >= 1000 then 0 else x)
modify return n
```

I put everything in a state monad. The parts A and B have different stopping criteria.

«solution-day-11»

```
repeatM :: (Applicative m) => Int -> m a -> m [a]
= loop n
repeatM n a where loop n
| n <= 0 = pure []
| otherwise = liftA2 (:) a (loop (n - 1))
solutionA :: Array2 Int -> Int
= sum . evalState (repeatM 100 step)
solutionA
countRepeatUntilM :: (Monad m) => m Bool -> m Int
= go 1
countRepeatUntilM action where go n = do
<- action
stop if stop then return n else go (n + 1)
solutionB :: Array2 Int -> Int
= evalState $ countRepeatUntilM ((== 100) <$> step) solutionB
```

### Plots

Iteration 1 through 258 (my answer) of the Dumbo Octopusses. For a long time, there is a majority period of 7 cycles. The basin has a value of 6 then, but is triggered by some event at the boundary of the basin, creating a cascade. When all octopusses synchronize the period lengthens to 10.

# Day 12: Passage Pathing

Graphs! The fun times we live in :). We’re getting a map of caves. This is my input:

file:app/Day12.hs

```
{-# LANGUAGE TypeApplications #-}
module Day12 where
import RIO hiding (try)
import RIO.Map ((!?))
import RIO.Set ((\\))
import qualified RIO.Map as Map
import qualified RIO.Set as Set
import qualified RIO.Text as Text
import Parsing (Parser, string, char, eol, sepEndBy1, readInputParsing)
import RIO.Char (isLower, isUpper)
import Text.Megaparsec (takeWhile1P, try)
<<parser-day-12>>
<<solution-day-12>>
<<run-solutions>>
```

I distinguish the `Start`

, `End`

caves and `Big`

and `Small`

during parsing.

«parser-day-12»

```
data Cave = Start | End | Big Text | Small Text
deriving (Eq, Ord)
instance Show Cave where
show Start = "start"
show End = "end"
show (Big c) = Text.unpack c
show (Small c) = Text.unpack c
data Link = Link Cave Cave
deriving (Show, Eq, Ord)
caveP :: Parser Cave
= (Start <$ try (string "start"))
caveP <|> (End <$ try (string "end" ))
<|> (Big <$> takeWhile1P (Just "A-Z") isUpper)
<|> (Small <$> takeWhile1P (Just "a-z") isLower)
linkP :: Parser Link
= Link <$> caveP <* char '-' <*> caveP
linkP
readInput :: (HasLogFunc env) => RIO env [Link]
= readInputParsing "data/day12.txt" (sepEndBy1 linkP eol) readInput
```

From the list of `Link`

we can extract a `CaveMap`

.

«solution-day-12»

```
type CaveMap = Map Cave [Cave]
routing :: [Link] -> CaveMap
= Map.unionsWith (<>) . map linkToMap
routing where linkToMap (Link a b) = Map.fromList [(a, [b]), (b, [a])]
```

With part B in mind, we need to have an abstract `Cave`

container with two methods, `visit`

and `allowed`

.

«solution-day-12»

```
class CaveSet s where
visit :: Cave -> s -> s
allowed :: Cave -> s -> Bool
```

In part A, we can use a `Set Cave`

to keep track of all the caves we visited:

- A big cave is always allowed, so we do not enter it into the set.
- Any other cave is only allowed once.

«solution-day-12»

```
instance CaveSet (Set Cave) where
Big _) s = s
visit (= Set.insert c s
visit c s = Set.notMember allowed
```

I find all possible routes recursively, using `concatMap`

.

«solution-day-12»

```
findRoutesTo :: (CaveSet s) => CaveMap -> s -> Cave -> Cave -> [[Cave]]
findRoutesTo caveMap visited end start| start == end = [[end]]
| otherwise = map (start :) $ concatMap recur nextRooms
where visited' = visit start visited
= findRoutesTo caveMap visited' end
recur = filter (`allowed` visited')
nextRooms $ fromMaybe [] (caveMap !? start)
findRoutesA :: CaveMap -> [[Cave]]
= findRoutesTo caveMap (Set.empty @Cave) End Start
findRoutesA caveMap
solutionA :: [Link] -> Int
= length . findRoutesA . routing solutionA
```

Now for part B. We need a container that allows one item to appear twice. I call this `AugmentedSet`

. All I need to do is implement `CaveSet`

on this new container and we’re done!

«solution-day-12»

```
data AugmentedSet a = AugmentedSet (Set a) (Maybe a)
deriving (Show)
instance CaveSet (AugmentedSet Cave) where
Big _) s = s
visit (Small c) (AugmentedSet s Nothing)
visit (| Small c `Set.member` s = AugmentedSet s (Just (Small c))
| otherwise = AugmentedSet (Set.insert (Small c) s) Nothing
AugmentedSet s m)
visit c (| c `Set.member` s = error $ "Cave " <> show c <> " was already passed"
| otherwise = AugmentedSet (Set.insert c s) m
Small c) (AugmentedSet s Nothing) = True
allowed (AugmentedSet s _) = i `Set.notMember` s
allowed i (
findRoutesB :: CaveMap -> [[Cave]]
= findRoutesTo caveMap emptySet End Start
findRoutesB caveMap where emptySet = AugmentedSet @Cave Set.empty Nothing
solutionB :: [Link] -> Int
= length . findRoutesB . routing solutionB
```

# Day 13: Transparent Origami

We need to fold a piece of transparent paper with dots on it.

file:app/Day13.hs

```
module Day13 where
import RIO
import RIO.ByteString (putStr)
import RIO.List.Partial (head)
import qualified RIO.Text as Text
import qualified RIO.Set as Set
import Parsing (readInputParsing, Parser, string, sepEndBy1, eol, integer, char)
import Data.Massiv.Array (Ix2(..))
import Print ( printLn, printCoords )
<<parser-day-13>>
<<solution-day-13>>
```

As always, we have a parser:

«parser-day-13»

```
data Input = Input
inputCoordinates :: [Ix2]
{ foldInstructions :: [FoldInstruction] }
,deriving (Show)
data FoldInstruction = FoldInstruction Axis Int
deriving (Show)
data Axis = XAxis | YAxis deriving (Show)
inputP :: Parser Input
= Input <$> coordinatesP <* eol <*> foldInstructionsP
inputP
coordinatesP :: Parser [Ix2]
= sepEndBy1 ((:.) <$> integer <* char ',' <*> integer) eol
coordinatesP
foldInstructionsP :: Parser [FoldInstruction]
= sepEndBy1 foldInstructionP eol
foldInstructionsP where foldInstructionP = string "fold along " $> FoldInstruction
<*> axisP <* char '=' <*> integer
= (XAxis <$ char 'x')
axisP <|> (YAxis <$ char 'y')
readInput :: (HasLogFunc env) => RIO env Input
= readInputParsing "data/day13.txt" inputP readInput
```

For each fold we need to transform the coordinates.

«solution-day-13»

```
foldTransform :: FoldInstruction -> Ix2 -> Ix2
FoldInstruction XAxis loc) (x :. y)
foldTransform (| x > loc = 2 * loc - x :. y
| otherwise = x :. y
FoldInstruction YAxis loc) (x :. y)
foldTransform (| y > loc = x :. 2 * loc - y
| otherwise = x :. y
solutionA :: Input -> Int
Input{..} = Set.size
solutionA $ Set.map (foldTransform $ head foldInstructions)
$ Set.fromList inputCoordinates
```

Now we need to fold the folds.

«solution-day-13»

```
foldAllFolds :: Input -> [Ix2]
Input{..} = Set.toList $ foldl' makeFold
foldAllFolds
(Set.fromList inputCoordinates)
foldInstructionswhere makeFold s i = Set.map (foldTransform i) s
```

Apparently the answer is in visualizing the result, so I’ll print out the coordinates and plot them with Gnuplot.

«solution-day-13»

```
runA :: (HasLogFunc env) => RIO env ()
= do
runA <- readInput
inp $ "# " <> tshow (solutionA inp)
printLn
runB :: (HasLogFunc env) => RIO env ()
= do
runB <- readInput
inp printCoords (foldAllFolds inp)
```

# Day 14: Extended Polymerization

file:app/Day14.hs

```
module Day14 where
import RIO
import RIO.List (iterate, sortOn)
import RIO.List.Partial (tail, init, head, last, (!!))
import RIO.Map ((!?))
import qualified RIO.Map as Map
import qualified Data.Map.Lazy as LazyMap
import Parsing (Parser, readInputParsing, sepEndBy1, eol, string)
import Text.Megaparsec.Char (upperChar)
import Data.MultiSet (MultiSet, occur, findMin, findMax)
import qualified Data.MultiSet as MultiSet
type LazyMap = LazyMap.Map
<<parser-day14>>
<<solution-day14>>
<<run-solutions>>
```

«parser-day14»

```
data Input = Input
axiom :: [Char]
{ rules :: Map (Char, Char) Char
,deriving (Show)
}
axiomP :: Parser [Char]
= some upperChar <* eol
axiomP
ruleP :: Parser ((Char, Char), Char)
= (,) <$> ((,) <$> upperChar <*> upperChar)
ruleP <* string " -> " <*> upperChar
inputP :: Parser Input
= Input <$> axiomP <* eol <*> (Map.fromList <$> sepEndBy1 ruleP eol)
inputP
readInput :: (HasLogFunc env) => RIO env Input
= readInputParsing "data/day14.txt" inputP readInput
```

«solution-day14»

```
pairs :: [a] -> [(a, a)]
= []
pairs [] = zip xs (tail xs)
pairs xs
newtype GlueList a = GlueList { fromGlueList :: [a] }
instance Semigroup (GlueList a) where
GlueList (x:xs) <> GlueList (_:y) = GlueList $ (x:xs) <> y
GlueList x <> GlueList [] = GlueList x
GlueList [] <> GlueList y = GlueList y
instance Monoid (GlueList a) where
mempty = GlueList mempty
step :: Map (Char, Char) Char -> [Char] -> [Char]
= fromGlueList . foldMap insertChar . pairs
step rules where insertChar (a, b) = case rules !? (a, b) of
Nothing -> GlueList [a, b]
Just c -> GlueList [a, c, b]
countDiff :: [Char] -> Int
= 0
countDiff [] = snd (last counts) - snd (head counts)
countDiff cs where counts = sortOn snd $ MultiSet.toOccurList $ MultiSet.fromList cs
solutionA :: Input -> Int
Input {..} = countDiff $ (!! 10) $ iterate (step rules) axiom
solutionA
countMap :: Map (Char, Char) Char -> LazyMap ((Char, Char), Int) (MultiSet Char)
= m
countMap rules where m = LazyMap.fromList [ (((c1, c2), d), f c1 c2 d)
| c1 <- ['A'..'Z']
<- ['A'..'Z']
, c2 <- [0..40]]
, d f :: Char -> Char -> Int -> MultiSet Char
0 = MultiSet.singleton c1
f c1 _ = case rules !? (c1, c3) of
f c1 c3 d Nothing -> MultiSet.singleton c1
Just c2 -> m LazyMap.! ((c1, c2), d - 1)
<> m LazyMap.! ((c2, c3), d - 1)
solutionB :: Input -> Int
Input{..} = snd (last counts) - snd (head counts)
solutionB where counts = sortOn snd $ MultiSet.toOccurList
$ MultiSet.singleton (last axiom)
<> foldMap (\p -> m LazyMap.! (p, 40)) (pairs axiom)
= countMap rules m
```

# Day 15: Chiton

We are given a map and need to compute the shortest path from the top left to the right bottom. The algorithm to use here is Dijkstra’s algorithm.

I implemented two versions: one for abstract cases, and one on a grid.

file:app/Dijkstra.hs

```
{-# LANGUAGE TypeApplications #-}
module Dijkstra (minDist, minDistArray2) where
import RIO
import RIO.List.Partial (foldl1')
import qualified RIO.Set as Set
import RIO.Map ((!?))
import qualified RIO.Map as Map
import qualified Data.PQueue.Min as Q
<<dijkstra-imports>>
<<dijkstra-generic>>
<<dijkstra-array>>
```

To put elements on a priority-queue, I defined a `newtype`

that sorts on the second element of a tuple.

«dijkstra-generic»

```
newtype DistLoc i a = DistLoc (i, a)
deriving (Eq)
instance (Ord a, Eq i) => Ord (DistLoc i a) where
compare (DistLoc (_, x)) (DistLoc (_, y)) = compare x y
toLoc :: DistLoc i a -> i
DistLoc (l, _)) = l toLoc (
```

The generic algorithm looks rather horrible, I won’t bother you with it.

### Array version

For our case with path-finding on a grid. We can have a much more efficient implementation than the generic one.

«dijkstra-imports»

```
import Data.Massiv.Array (Ix2(..))
import qualified Data.Massiv.Array as A
```

The entire algorithm now runs in the `ST`

monad, so that we can do array mutation.

«dijkstra-array»

```
type Array2' r a = A.Array r Ix2 a
type Array2 a = Array2' A.U a
<<condM>>
minDistArray2 :: forall a. (Ord a, Num a, Bounded a, A.Unbox a, A.Manifest A.U a)
=> Array2 a -> (Ix2 -> [Ix2]) -> Ix2 -> Ix2 -> a
= runST go
minDistArray2 cost neighbours start end where go :: forall s. ST s a
= do
go <<dijkstra-array-init>>
let
<<dijkstra-array-distloc>>
<<dijkstra-array-recur>>
recur Q.empty startwhere size = A.size cost
```

#### Init

The algorithm is initialised with the `unvisited`

set, encoded as an array of bools, and the tentative distances, stored in another array (of int).

«dijkstra-array-init»

```
<- A.newMArray @A.U @Bool size True
unvisited <- A.newMArray @A.U @a size maxBound
dist 0 A.write_ dist start
```

#### Estimating distance

Distance is estimated as the minimum of the last known estimate and the distance from the current node plus the confirmed total distance to the current node.

«dijkstra-array-distloc»

```
distLoc :: Ix2 -> Ix2 -> ST s (DistLoc Ix2 a)
= do
distLoc i j <- A.readM dist j
v <- A.readM dist i
x return $ DistLoc (j, min v (x + (cost A.! j)))
```

#### Recursion

The recursion keeps the priority-queue of nodes to visit. There are three cases:

- The node is the end node: we’re done.
- The node was already visited: we can skip it.
- Otherwise, set the current node to visited, check the neighbours, compute distances for them, update the priority queue and recurse.

«dijkstra-array-recur»

```
recur :: Q.MinQueue (DistLoc Ix2 a) -> Ix2 -> ST s a
= condM
recur q pos pure $ pos == end, A.readM dist end)
[ (do
, (A.readM unvisited pos, False
A.write_ unvisited pos <- filterM (A.readM unvisited) (neighbours pos)
unvisitedNeighbours <- mapM (distLoc pos) unvisitedNeighbours
newDists mapM_ (\(DistLoc (i, x)) -> A.write_ dist i x) newDists
let q' = foldl' (flip Q.insert) (Q.deleteMin q) newDists
$ Q.findMin q'))
recur q' (toLoc do
, (otherwiseM, let q' = Q.deleteMin q
$ Q.findMin q')) ] recur q' (toLoc
```

Here `condM`

is a little helper function to write monadic conditions.

«condM»

```
condM :: (Monad m) => [(m Bool, m a)] -> m a
pred, action): cs) = do
condM ((<- pred
c if c then action else condM cs
= error "no matching conditions"
condM []
otherwiseM :: (Monad m) => m Bool
= pure True otherwiseM
```

### Solution

file:app/Day15.hs

```
module Day15 where
import RIO
import Data.Massiv.Array (Ix2(..))
import qualified Data.Massiv.Array as A
import Parsing (readInputParsing, digitArray)
import Dijkstra (minDistArray2, minDist)
<<parser-day15>>
<<solution-day15>>
<<run-solutions>>
```

We again reuse the parser from day 9.

«parser-day15»

```
type Array2' r a = A.Array r A.Ix2 a
type Array2 a = Array2' A.U a
readInput :: (HasLogFunc env) => RIO env (Array2 Int)
= readInputParsing "data/day15.txt" digitArray readInput
```

With Dijkstra’s algorithm in place, the solution is not too hard.

«solution-day15»

```
neighbours :: (A.Unbox a) => Array2 a -> Ix2 -> [Ix2]
= filter (isJust . (x A.!?)) $ map (+ i) n
neighbours x i where n = [-1 :. 0, 1 :. 0, 0 :. -1, 0 :. 1]
distance :: Array2 Int -> Ix2 -> Ix2 -> Maybe Int
= x A.!? i
distance x _ i
endPoint :: Array2 Int -> Ix2
= A.unSz (A.size x) - (1 :. 1)
endPoint x
solutionA :: Array2 Int -> Int
= minDistArray2 inp (neighbours inp) (0 :. 0) (endPoint inp)
solutionA inp
scaleUp :: Array2 Int -> Array2 Int
= stack 2 (stack 1 x)
scaleUp x where stack axis row = foldl' (\r t -> A.compute $ A.append' axis r t) row
$ map (\h -> A.map (inc h) row) [1..4]
= (x - 1 + h) `mod` 9 + 1
inc h x
solutionB :: Array2 Int -> Int
-- solutionB inp' = minDist (neighbours inp) (distance inp) (0 :. 0) (endPoint inp)
= minDistArray2 inp (neighbours inp) (0 :. 0) (endPoint inp)
solutionB inp' where inp = scaleUp inp'
```

# Day 16: Packet Decoder

Oh boy. I defined a `Stream`

instance for Megaparsec on the `Bitstream`

type from the `bitstreams`

package. This lets me define some elementary parsers.

file:app/Parsing/Binary.hs

```
{-# LANGUAGE UndecidableInstances #-}
module Parsing.Binary where
import RIO
import Data.Bits (Bits)
import Data.Vector.Storable (Vector)
import qualified Data.Vector.Storable as Vector
import qualified Data.Bitstream as BS
import Data.Bitstream.Packet (toOctet)
import qualified Data.Bitstream.Generic as BSG
import Text.Megaparsec (Parsec, Stream(..), takeP, anySingle)
instance (BSG.Bitstream (BS.Bitstream d)) => Stream (BS.Bitstream d) where
type Token (BS.Bitstream d) = Bool
type Tokens (BS.Bitstream d) = BS.Bitstream d
= BS.pack
tokensToChunk pxy = BS.unpack
chunkToTokens pxy = BS.length
chunkLength pxy = BS.null
chunkEmpty pxy
take1_ s| BS.null s = Nothing
| otherwise = Just (BS.head s, BS.tail s)
takeN_ n s| BS.length s < n = Nothing
| otherwise = Just (BS.take n s, BS.drop n s)
= BS.span
takeWhile_
type BitParser = Parsec Void (BS.Bitstream BS.Right)
intN :: (Integral n, Bits n) => Int -> BitParser n
= BS.toBits <$> takeP (Just $ show n <> " bit integer") n
intN n
bool :: BitParser Bool
= anySingle
bool
bit :: BitParser Word8
= intN 1
bit
skip :: Int -> BitParser ()
= void $ takeP (Just $ "skipping " <> show n <> " bits") n skip n
```

Now, I have a lot of imports.

file:app/Day16.hs

```
module Day16 where
import RIO hiding (bool, try)
import RIO.Char (ord)
import RIO.List.Partial (foldl1')
import RIO.Partial (toEnum)
import qualified RIO.Map as Map
import qualified RIO.ByteString as ByteString
import Data.Bitstream (Bitstream, Right)
import qualified Data.Bitstream as Bitstream
import Parsing (Parser, readInputParsing)
import Parsing.Binary (BitParser, intN, bool, skip, bit)
import Control.Monad (replicateM)
import Text.Megaparsec (parse, chunk, try, takeP)
import Text.Megaparsec.Char (hexDigitChar)
<<parser-day16>>
<<data-types-day16>>
<<bits-parser-day16>>
<<evaluator-day16>>
<<solution-day16>>
```

First we need to parse the hexadecimal notation to a `Bitstream Right`

object.

«parser-day16»

```
nibble :: Parser Word8
= hexDigitChar >>= toValue
nibble where toValue c
| '0' <= c && c <= '9' = return $ fromIntegral $ ord c - ord '0'
| 'a' <= c && c <= 'f' = return $ fromIntegral $ ord c - ord 'a' + 10
| 'A' <= c && c <= 'F' = return $ fromIntegral $ ord c - ord 'A' + 10
| otherwise = fail "not a hexadecimal character"
byte :: Parser Word8
= combine <$> nibble <*> nibble
byte where combine a b = a*16 + b
bitstream :: Parser (Bitstream Right)
= Bitstream.fromByteString . ByteString.pack <$> some byte bitstream
```

Then I parse directly to a single packet:

«parser-day16»

```
readBitstream :: (MonadReader env m, MonadIO m, HasLogFunc env)
=> Bitstream Right -> BitParser a -> m a
=
readBitstream b p either (\e -> do { logError $ display (tshow e); exitFailure })
return (parse p "-" b)
readInput :: (HasLogFunc env) => RIO env Packet
= do
readInput <- readInputParsing "data/day16.txt" bitstream
bits readBitstream bits packet
```

These are my data types: a `TypeId`

, a `Packet`

container and `PacketContent`

which is either a literal value or an operator.

«data-types-day16»

```
data TypeId
= SumId
| ProductId
| MinimumId
| MaximumId
| LiteralValueId
| GreaterThanId
| LessThanId
| EqualToId
deriving (Show, Eq, Ord, Enum)
data Packet = Packet
packetVersion :: Int
{ packetContent :: PacketContent
,deriving (Show)
}
data PacketContent
= LiteralValuePacket Int
| OperatorPacket TypeId [Packet]
deriving (Show)
```

So, now we need to parse the bit stream to a `Packet`

object. These are a quite direct translation of the problem text into code. The ugly bit is that inside `operatorPacket`

, we need to call the `parse`

function recursively.

«bits-parser-day16»

```
version :: BitParser Int
= intN 3
version
typeId :: TypeId -> BitParser ()
= void $ chunk (Bitstream.fromNBits 3 (fromEnum i))
typeId i
literalValuePacket :: BitParser PacketContent
= do
literalValuePacket LiteralValueId
typeId 0
loop where loop n = do
<- bool
continue <- intN 4
nib let n' = n * 16 + nib
if continue then loop n'
else return $ LiteralValuePacket n'
operatorPacket :: BitParser PacketContent
= do
operatorPacket <- toEnum <$> intN @Int 3
typeId <- bit
lengthType if lengthType == 0 then do
<- intN 15
l <- takeP (Just "sub-packets") l
subbits <- either (fail . show) return
subpkts $ parse (some packet) "-" subbits
return $ OperatorPacket typeId subpkts
else do
<- intN 11
l OperatorPacket typeId <$> replicateM l packet
packet :: BitParser Packet
= do
packet <- version
packetVersion <- try literalValuePacket
packetContent <|> operatorPacket
return $ Packet {..}
```

To solve part A, we need to sum all version numbers.

«solution-day16»

```
getVersions :: Packet -> [Int]
Packet {..} = [packetVersion] <> versions packetContent
getVersions where versions (OperatorPacket _ p) = concatMap getVersions p
= []
versions _
solutionA :: Packet -> Int
= sum . getVersions
solutionA
solutionB :: Packet -> Int
= evalPacket
solutionB
<<run-solutions>>
```

For part B, we need to evaluate the computation that is contained in the message.

«evaluator-day16»

```
evalPacket :: Packet -> Int
Packet{..} = eval packetContent
evalPacket where eval (LiteralValuePacket i) = i
OperatorPacket op p) = eval' op (map evalPacket p)
eval (SumId p = sum p
eval' ProductId p = product p
eval' MinimumId p = foldl1' min p
eval' MaximumId p = foldl1' max p
eval' GreaterThanId [a, b] = if a > b then 1 else 0
eval' LessThanId [a, b] = if a < b then 1 else 0
eval' EqualToId [a, b] = if a == b then 1 else 0
eval' = error "illegal expression" eval' _ _
```

So this code is still full of partial functions, which is not so nice, but it’s getting late.

# Day 17: Trick Shot

Today we need to do some math. The first part, we can even compute by hand! We are given a target area for a probe. Starting at position \((0,0)\), and an unknown initial velocity, we are given a rectangular area to hit. The probe lives in the weird integer arithmetic universe that we’ve come to love from Advent of Code

file:app/Day17.hs

```
module Day17 where
import RIO
import Parsing (Parser, readInputParsing, string, integer, lexeme, char)
import Linear.V2 (V2(..))
import Print ( printLn )
<<data-types-day17>>
<<parser-day17>>
<<solution-day17>>
<<run-solutions>>
```

«data-types-day17»

```
data Area = Area
minX :: Int
{ maxX :: Int
, minY :: Int
, maxY :: Int
,deriving (Show)
}
data PhaseSpace = PhaseSpace
position :: V2 Int
{ velocity :: V2 Int
,deriving (Show) }
```

But first, parsing! (I know, overkill)

«parser-day17»

```
areaP :: Parser Area
= Area <$ string "x=" <*> integer <* rangeSep <*> integer
areaP <* listSep
<* string "y=" <*> integer <* rangeSep <*> integer
where rangeSep = lexeme (string "..")
= lexeme (char ',')
listSep
readInput :: (HasLogFunc env) => RIO env Area
= readInputParsing "data/day17.txt" (string "target area: " *> areaP) readInput
```

The rules are that each timestep:

- position increases with velocity
- the velocity in x-direction decreases in magnitude due to drag
- the velocity in y-direction increases in negative direction by one due to gravity

«solution-day17»

```
step :: PhaseSpace -> PhaseSpace
PhaseSpace position velocity@(V2 vx vy)) = PhaseSpace
step (= position + velocity
{ position = V2 (vx - signum vx) (vy - 1)
, velocity }
```

We need to see if the probe hits the target area, but also if it definitely missed it.

«solution-day17»

```
hit :: Area -> PhaseSpace -> Bool
Area{..} (PhaseSpace (V2 x y) _) = minX <= x && x <= maxX
hit && minY <= y && y <= maxY
miss :: Area -> PhaseSpace -> Bool
Area{..} (PhaseSpace (V2 _ y) (V2 _ dy)) = y < minY && dy < 0 miss
```

The key is now to find the maximum velocity upward. The point being that the probe always returns to level 0, with negative that velocity. If that velocity will make the probe overshoot, than we definetly miss target. The minimum velocity is \(y_{\rm min}\), so the maximum velocity is \(-y_{\rm min} - 1\).

The height attained at the maximum y velocity is \((v_y (v_y + 1)) / 2\).

For the velocity in the X direction, the final X position we reach is \((v_x (v_x + 1))/2\), so the minimum velocity is \(\lfloor \sqrt{2 x_{\rm min}} \rfloor\). The maximum velocity is \(x_{\rm max}\).

«solution-day17»

```
velocityBounds :: Area -> (V2 Int, V2 Int)
Area{..} = (V2 minvx minvy, V2 maxvx maxvy)
velocityBounds where minvy = minY
= (-minY) - 1
maxvy = floor (sqrt (fromIntegral $ minX * 2))
minvx = maxX
maxvx
data Outcome = Hit | Miss deriving (Eq)
iterateUntil :: (a -> a) -> (a -> Bool) -> a -> a
init
iterateUntil f p | p init = init
| otherwise = iterateUntil f p (f init)
outcome :: Area -> V2 Int -> Outcome
= if hit a last then Hit else Miss
outcome a v where last = iterateUntil step (\x -> hit a x || miss a x)
PhaseSpace (V2 0 0) v) (
```

For part B we actually need to compute.

«solution-day17»

```
solutionA :: Area -> Int
Area{..} = maxv * (maxv + 1) `div` 2
solutionA where maxv = (- minY) - 1
solutionB :: Area -> Int
= length [ V2 vx vy
solutionB a | vx <- [minvx .. maxvx]
<- [minvy .. maxvy]
, vy V2 vx vy) == Hit ]
, outcome a (where (V2 minvx minvy, V2 maxvx maxvy) = velocityBounds a
```

If I plot the time of impact for every initial velocity, a structure to the solution appears, which makes me think there should be a nicer solution to this problem than brute forcing.

We have an initial set of trivial solutions, reaching the target area in one time step. From that we may be able to derive a set of solutions that reach the same target in two steps, and so on.

Given a point \(p = (p_x, p_y)\), we may reach this point in one step if the initial velocity \(v(0) = p\). We can compute the effect of two time steps.

\[x(2) = v_x(0) + v_x(1) = 2 v_x(0) - 1\] \[y(2) = v_y(0) + v_y(1) = 2 v_y(0) + 1\]

In general we can say,

\[x(t) = \min (t * v_x(0) - \Delta(t - 1), \Delta(v_x(0))),\] \[y(t) = t * v_y(0) - \Delta(t - 1),\]

where \(\Delta(t) = t(t+1)/2.\) Now the question is, can we invert those to solve \(v(0)\) from \(x(t)\)? The \(y\) component is not too hard:

\[v_y(0) = (y(t) + \Delta(t - 1)) / t = y(t) / t + (t - 1) / 2,\]

noting that we’re still limited to integer solutions; \(y(t) \mod t = 0\) if \(t\) is odd and \(y(t) \mod t = t/2\) if \(t\) is even.

The \(x\) velocity is a bit more tricky. If \(t \le v_x(0)\), then the equation is the same as for \(y\). If \(t > v_x(0)\) then

\[x(t) = v_x(0) (v_x(0) + 1) / 2,\]

So the equation can only be solved if \(x(t)\) is a triangular number, and then,

\[v_x(0) = \lfloor \sqrt{2 x(t)} \rfloor.\]

We can plot the resulting boxes for each time \(t\).

«solution-day17»

```
invertArea :: Area -> Int -> Area
Area{..} t = Area minX' maxX' minY' maxY'
invertArea where invertDelta x = floor (sqrt (fromIntegral $ 2 * x))
invertQuadratic :: Int -> Float
= fromIntegral x / fromIntegral t
invertQuadratic x + (fromIntegral t - 1) / 2
= max (invertDelta minX) (ceiling $ invertQuadratic minX)
minX' = floor (invertQuadratic maxX)
maxX' = ceiling (invertQuadratic minY)
minY' = floor (invertQuadratic maxY)
maxY'
printArea :: Area -> IO ()
Area{..} = do
printArea $ tshow minX <> " " <> tshow minY
printLn $ tshow maxX <> " " <> tshow minY
printLn $ tshow maxX <> " " <> tshow maxY
printLn $ tshow minX <> " " <> tshow maxY
printLn $ tshow minX <> " " <> tshow minY
printLn
showData2 :: IO ()
= do
showData2 <- runSimpleApp readInput
area mapM_ (\t -> printArea (invertArea area t) >> printLn "\n")
0 .. 2 * negate (minY area)] [
```

# Day 18: Snailfish

Today we’re walking trees. I spent most of my time reading the instructions. My solution is based on clever (if I can say so myself) combination of `Alternative`

and continuation passing style.

file:app/Day18.hs

```
module Day18 where
import RIO
import RIO.List.Partial (foldl1', maximum)
import Parsing (Parser, readInputParsing, char, integer, eol, sepEndBy1)
<<parser-day18>>
<<solution-day18>>
<<run-solutions>>
```

We have snailfish “numbers” that are represented by pairs of snailfish “numbers”.

«parser-day18»

```
data Number a
= Regular a
| Snailfish (Number a) (Number a)
deriving (Eq)
instance (Show a) => Show (Number a) where
show (Regular a) = show a
show (Snailfish a b) = "[" <> show a <> "," <> show b <> "]"
snailfishP :: Parser (Number Int)
= Snailfish <$ char '[' <*> exprP <* char ',' <*> exprP <* char ']'
snailfishP
exprP :: Parser (Number Int)
= (Regular <$> integer) <|> snailfishP
exprP
readInput :: (HasLogFunc env) => RIO env [Number Int]
= readInputParsing "data/day18.txt" (snailfishP `sepEndBy1` eol) readInput
```

We are told that numbers are added by creating a new pair and then reducing.

«solution-day18»

```
instance Semigroup (Number Int) where
Regular 0 <> b = b
<> Regular 0 = a
a <> b = reduce $ Snailfish a b
a
instance Monoid (Number Int) where
mempty = Regular 0
```

To reduce a number, we either explode or split. It took me a long time to understand that we don’t split unless there’s nothing to explode.

«solution-day18»

```
reduce :: Number Int -> Number Int
= maybe a reduce (reduceExplode a <|> reduceSplit a) reduce a
```

The idea of `Alternative Maybe`

and CPS is best explained on `reduceSplit`

. Once we found a number to split, we should stop scanning for other numbers to split. This means we have to represent upper levels of the tree in terms of what happens somewhere down in the walk. Instead of waiting for a function to return, I pass it a continuation (think a template) that we may use **if and only if** we want to change something in the tree. The continuation should be a function that, when given a node, reconstructs the entire tree.

Calling the continuation will result in a `Just`

that already contains the entire tree. If the continuation is not called, the result is a `Nothing`

, telling the `Alternative`

class that we’re not done yet.

«solution-day18»

```
reduceSplit :: Number Int -> Maybe (Number Int)
= walk Just
reduceSplit where walk cc (Snailfish a b)
= walk (\n -> cc $ Snailfish n b) a
<|> walk (\n -> cc $ Snailfish a n) b
Regular x)
walk cc (| x >= 10 = cc $ split x
| otherwise = Nothing
where split x = Snailfish (Regular $ floor (fromIntegral x / 2))
Regular $ ceiling (fromIntegral x / 2)) (
```

The same principle applies on the `reduceExplode`

function. However, now it is more complicated. Next to replacing the current node with `Regular 0`

, we need to add numbers to the left and right. If a sub-tree is unmodified, we may decide to add `0`

after all.

«solution-day18»

```
reduceExplode :: Number Int -> Maybe (Number Int)
= walk 0 (\_ x _ -> Just x)
reduceExplode where walk 4 explode (Snailfish (Regular a) (Regular b))
= explode a (Regular 0) b
Snailfish a b)
walk depth explode (= walk (depth+1) explodeLeft a
<|> walk (depth+1) explodeRight b
where explodeLeft x n y =
Snailfish n (addToLeftMost b y)) 0
explode x (=
explodeRight x n y 0 (Snailfish (addToRightMost a x) n) y
explode Regular _) = Nothing walk _ _ (
```

The `addToLeftMost`

and `addToRightMost`

functions to a normal recursive decent, optimising for the common case of adding `0`

.

«solution-day18»

```
addToLeftMost :: Number Int -> Int -> Number Int
0 = a
addToLeftMost a = go a
addToLeftMost a x where go (Snailfish a b) = Snailfish (go a) b
Regular y) = Regular (x + y)
go (
addToRightMost :: Number Int -> Int -> Number Int
0 = a
addToRightMost a = go a
addToRightMost a x where go (Snailfish a b) = Snailfish a (go b)
Regular y) = Regular (x + y) go (
```

With all that in place, the rest of the exercise is not too hard.

«solution-day18»

```
magnitude :: Number Int -> Int
Regular x) = x
magnitude (Snailfish a b) = magnitude a * 3 + magnitude b * 2
magnitude (
solutionA :: [Number Int] -> Int
= magnitude . fold
solutionA
solutionB :: [Number Int] -> Int
= maximum [ magnitude (a <> b)
solutionB inp | a <- inp, b <- inp, a /= b]
```

# Day 19: Beacon Scanner

Boy, this was a hard one.

file:app/Day19.hs

```
module Day19 where
import RIO hiding (try)
import RIO.List (sortBy, find, sort, headMaybe)
import RIO.List.Partial (head, last, maximum)
import qualified RIO.Map as Map
import qualified Data.Set as Set
import qualified Data.Map.Lazy as LazyMap
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Parsing (Parser, readInputParsing, string, integer, char, eol, sepEndBy1, dropUntilEol)
import Text.Megaparsec (try)
import Linear.Matrix ( M33, (!*), (!!*), (!*!), transpose, det33 )
import Linear.V3 ( V3(..), _x, _y, _z )
import Linear.Vector ( negated )
<<data-types-day19>>
<<parser-day19>>
<<solution-day19>>
<<run-solutions>>
```

For this problem I use the `Linear`

module quite a lot: `V3 Int`

for coordinates, `V3 (V3 Int)`

for rotating and reflecting the coordinates. I defined my own `Affine`

type here, I know `Linear`

also has one, but this kind of grew and I don’t know if it is used in a similar way. The `Affine`

type combines a coordinate transformation and an offset. I implemented `Monoid`

to get the `<>`

operator to combine `Affine`

transformations.

«data-types-day19»

```
type Pt = V3 Int
type Scan = [Pt]
type Transform = M33 Int
data Affine = Affine Transform Pt
deriving (Show)
instance Semigroup Affine where
Affine t p <> Affine u q = Affine (t !*! u) (t !* q + p)
instance Monoid Affine where
mempty = Affine (V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1))
V3 0 0 0)
(
invert :: Affine -> Affine
Affine t p) = Affine (transpose t) (negated p)
invert (
applyAffine :: Affine -> Pt -> Pt
Affine t p) q = t !* q + p applyAffine (
```

«parser-day19»

```
inputP :: Parser Scan
= string "---" >> dropUntilEol
inputP >> (V3 <$> integer <* char ',' <*> integer <* char ',' <*> integer) `sepEndBy1` eol
readInput :: (HasLogFunc env) => RIO env (Vector Scan)
= readInputParsing "data/day19.txt" (Vector.fromList <$> inputP `sepEndBy1` eol) readInput
```

To find if two scans have matching points, I try all transpositions and reflections of coordinates. This may not be the most compact way of writing these down, but it works. At first I didn’t read well enough and did too many transformations. I fixed it by filtering on ones that have determinant of one.

«solution-day19»

```
allTransforms :: [Transform]
= [ p * s | p <- permutations (V3 1 0 0) (V3 0 1 0) (V3 0 0 1)
allTransforms <- signatures
, s * s) == 1 ]
, det33 (p where
= [ V3 a b c, V3 a c b, V3 b a c
permutations a b c V3 b c a, V3 c a b, V3 c b a ]
, = [ V3 1 1 1, V3 1 1 (-1)
signatures V3 1 (-1) 1, V3 1 (-1) (-1)
, V3 (-1) 1 1, V3 (-1) 1 (-1)
, V3 (-1) (-1) 1, V3 (-1) (-1) (-1) ] ,
```

At first, I had a terribly complicated method here to detect the relative offsets of two scans. I happened across a solution by someone else that is much more elegant.

«solution-day19»

```
matchScans :: [Pt] -> [Pt] -> Maybe Pt
= headMaybe $ Map.keys $ Map.filter (>= 12) $ count diffs
matchScans a b where diffs = (-) <$> a <*> b
= Map.fromListWith (+) . map (,1) count
```

We still have to try this for every rotation and reflection of one of the scans.

«solution-day19»

```
match :: [Pt] -> [Pt] -> Maybe Affine
= asum (go <$> allTransforms)
match a b where go t = Affine t <$> matchScans a (map (t !*) b)
```

I build an index of `Affine`

transformations. Starting with scan 0, I find the first remaining scan that produces a match, add that to the map and repeat. This could be sped up by memoizing matches we already know to fail; for me this gives a factor 60 speedup.

«solution-day19»

```
memoizeMatch :: Vector Scan -> Int -> Int -> Maybe Affine
= lookup
memoizeMatch s where lookup i j = join $ LazyMap.lookup (i, j) cache
= LazyMap.fromList [ ((i, j), match (s Vector.! i) (s Vector.! j))
cache | i <- [0 .. Vector.length s - 1]
<- [0 .. Vector.length s - 1]
, j /= j ]
, i
buildMap :: (Int -> Int -> Maybe Affine) -> Int -> Map Int Affine -> Maybe (Map Int Affine)
buildMap f n m| Map.size m == n = Just m
| otherwise = asum matches >>= insert >>= buildMap f n
where insert (i, j, aff) = do { a <- m Map.!? i;
return $ Map.insert j (a <> aff) m }
= [ (i, j,) <$> f i j
matches | i <- Map.keys m
<- [0..(n - 1)]
, j `Map.notMember` m ] , j
```

That was the hard bit. This code runs in about 15 seconds on my laptop.

«solution-day19»

```
mergeScans :: Vector Scan -> Map Int Affine -> Set Pt
= Map.foldMapWithKey (\i a -> Set.fromList $ map (applyAffine a) (s Vector.! i))
mergeScans s
solutionA :: Vector Scan -> Maybe Int
= Set.size . mergeScans inp
solutionA inp <$> buildMap (memoizeMatch inp) (Vector.length inp)
0 mempty)
(Map.singleton
maxDist :: Map Int Affine -> Int
= maximum [dist a b | a <- Map.elems m, b <- Map.elems m]
maxDist m where dist (Affine _ a) (Affine _ b) = sum (abs (a - b))
solutionB :: Vector Scan -> Maybe Int
= maxDist
solutionB inp <$> buildMap (memoizeMatch inp) (Vector.length inp)
0 mempty) (Map.singleton
```

# Day 20: Trench Map

It’s game of life time!

file:app/Day20.hs

```
module Day20 where
import RIO
import RIO.List (iterate)
import RIO.List.Partial ((!!))
import Data.Massiv.Array (Ix1, Ix2(..), U, Sz(..))
import qualified Data.Massiv.Array as A
import Parsing (Parser, readInputParsing, char, failOnException, sepEndBy1, eol)
<<parser-day20>>
<<solution-day20>>
<<run-solutions>>
```

«parser-day20»

```
type Array1 a = A.Array U Ix1 a
type Array2 a = A.Array U Ix2 a
type Input = (Array1 Int, Array2 Int)
lineP :: Parser [Int]
= some ((char '.' $> 0) <|> (char '#' $> 1))
lineP
rulesP :: Parser (Array1 Int)
= A.fromList A.Seq . join <$> (lineP `sepEndBy1` eol)
rulesP
gridP :: Parser (Array2 Int)
= failOnException . A.fromListsM A.Seq =<< (lineP `sepEndBy1` eol)
gridP
readInput :: (HasLogFunc env) => RIO env Input
= readInputParsing "data/day20.txt"
readInput <$> rulesP <* eol <*> gridP) ((,)
```

Little comment needed. Take care with the value at infinity!

«solution-day20»

```
patch :: [Ix2]
= [i :. j | i <- [(-1)..1], j <- [(-1)..1]]
patch
fromBinary :: [Int] -> Int
= go 0
fromBinary where go n (b:bs) = go (2*n + b) bs
= n
go n []
ruleStencil :: Array1 Int -> A.Stencil Ix2 Int Int
= A.makeStencil (Sz $ 3 :. 3) (1 :. 1) go
ruleStencil rules where go get = rules A.! idx
where idx = fromBinary (map get patch)
growBorder :: Array2 Int -> Int -> Array2 Int
= A.makeArrayR A.U A.Seq (A.liftSz (+ 2) (A.size src))
growBorder src inf -> fromMaybe inf $ src A.!? (ix - (1 :. 1)))
(\ix
step :: Array1 Int -> (Array2 Int, Int) -> (Array2 Int, Int)
= (tgt, inf')
step rules (src, inf) where tgt = A.compute $ A.mapStencil (A.Fill inf) (ruleStencil rules) (growBorder src inf)
= if inf == 0 then rules A.! 0 else rules A.! 511
inf'
solutionA :: Input -> Int
= A.sum $ fst $ step' $ step' (src, 0)
solutionA (rules, src) where step' = step rules
solutionB :: Input -> Int
= A.sum $ fst $ (!! 50) $ iterate (step rules) (src, 0) solutionB (rules, src)
```

# Day 21: Dirac Dice

I reused the `Tally`

structure that I made on day 6, and extended it such that `Tally Int`

supports numeric operations. This way I computed the answer using distributions of integers, and distributions of game states.

What I started with, was writing a monadic type class for playing the game. Considering that the game is independent for both players, I tried to solve this by simulation each player separately, but I got stuck in the bookkeeping. Then decided that keeping tally of numbers of game states was easier.

file:app/Day21.hs

```
module Day21 where
import RIO
import RIO.List (find, cycle, iterate, scanl')
import RIO.State (MonadState, State, get, gets, put, modify, execState)
import Parsing (readInputParsing, string, integer, eol)
import Lens.Micro.Platform ((&), (<%~), use, (%=), (.=), (<%=), (<<%=))
import qualified Tally
import Tally (Tally)
<<parser-day21>>
<<abstract-day21>>
<<game-state-day21>>
<<solution-day21>>
<<run-solutions>>
```

Obligatory parser of the day:

«parser-day21»

```
type Input = (Int, Int)
= (,) <$ string "Player 1 starting position: " <*> integer <* eol
inputP <* string "Player 2 starting position: " <*> integer <* eol
readInput :: (HasLogFunc env) => RIO env Input
= readInputParsing "data/day21.txt" inputP readInput
```

## Abstract implementation

Specifying game rules is often cleanest using a monadic type class. Here I have an associated type that gives the equivalent of a scalar (so `Int`

for part A, and `Tally Int`

for part B).

«abstract-day21»

```
data Player = Player1 | Player2
deriving (Show, Eq, Ord)
class Monad m => Game m where
type Dist m :: *
roll :: m (Dist m)
move :: Player -> Dist m -> m ()
stop :: m Bool
turn :: (Game m, Num (Dist m)) => Player -> m ()
= do
turn p <- roll
a <- roll
b <- roll
c + b + c)
move p (a
runUntilM :: (Monad m) => (a -> m Bool) -> [a] -> m ()
= return ()
runUntilM _ [] :xs) = do
runUntilM p (x<- p x
q
unless q (runUntilM p xs)
play :: (Game m, Num (Dist m)) => m ()
= runUntilM (\x -> turn x >> stop) (cycle [Player1, Player2]) play
```

## Game data

To encode the game state, I have two data types `PlayerData`

and `GameData`

. Then some lenses to ease into manipulating these types. To be honest, I don’t like lenses. There are too many operators and combinators making the code start to look like APL or J (yes, that’s a bad thing).

«game-state-day21»

```
data PlayerData = PlayerData
_playerPos :: Int
{ _playerScore :: Int
,deriving (Show, Eq, Ord)
}
pos :: Lens' PlayerData Int
= lens _playerPos (\p x -> p{_playerPos = x})
pos score :: Lens' PlayerData Int
= lens _playerScore (\p x -> p{_playerScore = x})
score
data GameData = GameData
_die100 :: Int
{ _player1 :: PlayerData
, _player2 :: PlayerData
,deriving (Show, Eq, Ord)
}
die100 :: Lens' GameData Int
= lens _die100 (\g d -> g{_die100 = d})
die100 player1 :: Lens' GameData PlayerData
= lens _player1 (\g p -> g{_player1 = p})
player1 player2 :: Lens' GameData PlayerData
= lens _player2 (\g p -> g{_player2 = p}) player2
```

Now we can define some helper functions to do moving and scoring.

«game-state-day21»

```
Player1 = player1
select Player2 = player2
select
gmove :: Player -> Int -> GameData -> GameData
=
gmove player step state & select player . pos
state %~ (\x -> (x + step - 1) `mod` 10 + 1)
gscore :: Player -> GameData -> GameData
=
gscore player state & select player . score
state %~ (+ state ^. select player . pos)
```

## Part A

Now to solve part A, we run the game in a `State`

monad.

«solution-day21»

```
newtype GameA a = GameA { gameStateA :: State GameData a }
deriving (Functor, Applicative, Monad, MonadState GameData)
instance Game GameA where
type Dist GameA = Int
= do x <- use die100
roll %= (+ 1)
die100 return $ x `mod` 100 + 1
= modify (gscore p . gmove p i)
move p i
= do
stop <- use $ player1 . score
p1 <- use $ player2 . score
p2 return (p1 >= 1000 || p2 >= 1000)
runGameA :: Input -> GameData
= execState (gameStateA play)
runGameA (p1, p2) $ GameData 0 (PlayerData p1 0) (PlayerData p2 0)
= output . runGameA
solutionA where output g = min (g ^. player1 . score)
^. player2 . score)
(g * (g ^. die100)
```

## Part B

For part B we can reuse everything we already have, replacing the normal integers with a `Tally Int`

, and keeping game state in a `Tally GameState`

.

### Calculating with distributions

Implementing `Num`

on `Tally n`

. It is interesting to note that multiplication in this space is not the same as repeated addition. This makes sense though. Doing

```
>>> let a = fromList [1, 2, 3]
>>> 3 * a
3, 1), (6, 1), (9, 1)]
[(>>> a + a + a
3, 1), (4, 3), (5, 6), (6, 7), (7, 6), (8, 3), (9, 1)] [(
```

Given the overengineered solution of day 6, implementing `Num`

is straight forward.

«tally»

```
instance (Integral n) => Num (Tally n) where
+) = cliftA2 (+)
(-) = cliftA2 (-)
(*) = cliftA2 (*)
(negate = cmap negate
abs = cmap abs
fromInteger = singleton . fromInteger
signum = cmap signum
```

### Game state

The `GameState`

now includes a state that tells if a player has alread won. The `gwin`

function (monadic on `Either Player a`

) determines if the game state should switch to one of the players winning.

«solution-day21»

```
type GameState = Either Player GameData
gwin :: Player -> GameData -> GameState
=
gwin player gameData if gameData ^. select player . score >= 21
then Left player else Right gameData
```

With it comes a new `tmove`

action that is monadic over `Tally a`

. It’s almost a shame that I have to enter explicitely that further dice throws can be ignored after a player has won. Maybe there is a way to use the monadic action over `Either Player a`

to stop the game when its over, but I haven’t found it.

«solution-day21»

```
tmove :: Player -> Tally Int -> GameState -> Tally GameState
@(Left _) = Tally.singleton g
tmove _ _ gRight gameData) =
tmove player step (-> gwin player $ gscore player
Tally.cmap (\i $ gmove player i gameData) step
```

### Running the game

Considering the increase of complexity, it is amazing how little work we needed to do to solve part B now. (Of course, this is a cleaned up version, and it took me ages to figure out this solution.)

«solution-day21»

```
newtype GameB a = GameB { gameStateB :: State (Tally GameState) a }
deriving (Functor, Applicative, Monad, MonadState (Tally GameState))
instance Game GameB where
type Dist GameB = Tally Int
= return $ Tally.fromList [1, 2, 3]
roll = modify (Tally.cbind (tmove p i))
move p i = gets (all isLeft . Tally.distinct)
stop
runGameB :: Input -> Tally GameState
= execState (gameStateB play)
runGameB (p1, p2) $ Tally.singleton $ Right
$ GameData 0 (PlayerData p1 0) (PlayerData p2 0)
= runGameB solutionB
```

# Day 22: Reactor Reboot

For today’s puzzle it is immediately clear what the second part is about. We need to find the number of lights turned on in a crazy large space.

file:app/Day22.hs

```
module Day22 where
import RIO
import qualified RIO.Map as Map
import Linear.V3 (V3(..), _x, _y, _z)
import Parsing
Parser, integer, lexeme, readInputParsing, eol, string, sepEndBy1 )
(
<<parser-day22>>
<<solution-day22>>
<<run-solutions>>
```

Obligatory parser of the day:

«parser-day22»

```
type V3Range = (V3 Int, V3 Int)
data Command = CommandOn | CommandOff deriving (Show, Eq, Ord, Bounded, Enum)
type Input = [(Command, V3Range)]
intRangeP :: Parser (Int, Int)
= (,) <$> integer <* string ".." <*> integer
intRangeP
rangeP :: Parser (Command, V3Range)
= (,) <$> lexeme (CommandOn <$ string "on" <|> (CommandOff <$ string "off"))
rangeP <*> (do (xmin, xmax) <- string "x=" *> intRangeP
","
string <- string "y=" *> intRangeP
(ymin, ymax) ","
string <- string "z=" *> intRangeP
(zmin, zmax) return (V3 xmin ymin zmin, V3 xmax ymax zmax))
inputP :: Parser Input
= rangeP `sepEndBy1` eol
inputP
readInput :: (HasLogFunc env) => RIO env Input
= readInputParsing "data/day22.txt" inputP readInput
```

I define a class `Range`

on which an `intersection`

and `area`

are defined. This has a rather straight forward implementation on `(Int, Int)`

.

«solution-day22»

```
class Range a where
intersect :: a -> a -> Maybe a
area :: a -> Int
instance Range (Int, Int) where
intersect (a1, a2) (b1, b2)| b1 > a2 || a1 > b2 = Nothing
| otherwise = Just (max a1 b1, min a2 b2)
= a2 - a1 + 1 area (a1, a2)
```

Now, for `(V3 Int, V3 Int)`

it is just the combination of the integer intersections.

«solution-day22»

```
instance Range (V3 Int, V3 Int) where
= do
intersect (a1, a2) (b1, b2) <- (a1 ^. _x, a2 ^. _x) `intersect` (b1 ^. _x, b2 ^. _x)
(x1, x2) <- (a1 ^. _y, a2 ^. _y) `intersect` (b1 ^. _y, b2 ^. _y)
(y1, y2) <- (a1 ^. _z, a2 ^. _z) `intersect` (b1 ^. _z, b2 ^. _z)
(z1, z2) return (V3 x1 y1 z1, V3 x2 y2 z2)
= product (b - a + 1) area (a, b)
```

Now a `[(r, Int)]`

type is giving a list of ranges and their multiplicity. If a range of lights is turned off, we find the intersection with all current ranges and stack those with opposite sign.

«solution-day22»

```
(=-=) :: Range r => [(r, Int)] -> r -> [(r, Int)]
=-= r = mapMaybe isect m <> m
m where isect (s, m) = (, negate m) <$> (s `intersect` r)
```

To switch lights on, first switch them off, and then add to the list.

«solution-day22»

```
(=+=) :: Range r => [(r, Int)] -> r -> [(r, Int)]
=+= r = (r, 1) : (m =-= r)
m
runCommands :: Input -> Int
= totalArea . foldl' switch []
runCommands where switch m (CommandOn, r) = m =+= r
CommandOff, r) = m =-= r
switch m (= sum . map (\(r, s) -> area r * s)
totalArea
solutionA :: Input -> Int
= runCommands . filter (small . snd)
solutionA where small (a, b) = all ((<=50) . abs) a && all ((<=50) . abs) b
solutionB :: Input -> Int
= runCommands solutionB
```

# Day 23: Amphipod

file:app/Day23.hs

```
module Day23 where
import RIO
import RIO.List (find)
import RIO.List.Partial (tail)
import qualified RIO.Map as Map
import qualified RIO.Text as Text
import RIO.State (State(..), evalState, get, modify)
import Data.Tuple (swap)
import Text.Megaparsec (ParsecT(..), ParseErrorBundle, errorBundlePretty, runParserT, sepEndBy1)
import Text.Megaparsec.Char (char, eol)
import Linear.V2 (V2(..))
import Dijkstra (minDist)
data AmphipodType
= Amber | Bronze | Copper | Desert
deriving (Show, Eq, Ord)
data Tile
= Wall
| Amphipod AmphipodType
| Empty
deriving (Show, Eq, Ord)
isAmphipod :: Tile -> Bool
Amphipod _) = True
isAmphipod (= False
isAmphipod _
amphipodType :: Tile -> Maybe AmphipodType
Amphipod x) = Just x
amphipodType (= Nothing
amphipodType _
type World = Map (V2 Int) Tile
type Parser a = ParsecT Void Text (State (V2 Int)) a
tileP :: Parser Tile
= (char '#' $> Wall)
tileP <|> (char 'A' $> Amphipod Amber)
<|> (char 'B' $> Amphipod Bronze)
<|> (char 'C' $> Amphipod Copper)
<|> (char 'D' $> Amphipod Desert)
<|> (char '.' $> Empty)
newlineP :: Parser ()
= eol >> modify (\(V2 x y) -> V2 0 (y+1))
newlineP
cellP :: Parser (Maybe (V2 Int, Tile))
= do
cellP <- (Just <$> tileP) <|> (Nothing <$ char ' ')
tile <- get
loc <|> modify (+ V2 1 0)
newlineP return $ (loc,) <$> tile
inputP :: Parser World
= Map.fromList . catMaybes <$> some cellP
inputP
instance Display (ParseErrorBundle Text Void) where
= Text.pack . errorBundlePretty
textDisplay
readInput :: (HasLogFunc env) => RIO env World
= do
readInput <- readFileUtf8 "data/day23.txt"
txt either (\e -> do { logError $ display e; exitFailure })
return $ evalState (runParserT inputP "data/day23.txt" txt)
V2 0 0)
(
energyPerMove :: Map AmphipodType Int
= Map.fromList
energyPerMove Amber, 1), (Bronze, 10), (Copper, 100), (Desert, 1000)]
[(
neighbours :: V2 Int -> [V2 Int]
= (p +) <$> [V2 (-1) 0, V2 1 0, V2 0 (-1), V2 0 1]
neighbours p
destination :: Map AmphipodType [V2 Int]
= Map.fromList
destination Amber, [V2 3 5, V2 3 4, V2 3 3, V2 3 2])
[(Bronze, [V2 5 5, V2 5 4, V2 5 3, V2 5 2])
,(Copper, [V2 7 5, V2 7 4, V2 7 3, V2 7 2])
,(Desert, [V2 9 5, V2 9 4, V2 9 3, V2 9 2])]
,(
inside :: [V2 Int]
= join $ Map.elems destination
inside
outside :: [V2 Int]
= [V2 1 1, V2 2 1, V2 4 1, V2 6 1, V2 8 1, V2 10 1, V2 11 1]
outside
pathOut :: (V2 Int, V2 Int) -> [V2 Int]
V2 x y, V2 u v) = up <> side
pathOut (where up = [V2 x y' | y' <- [y, y-1 .. v+1]]
= [V2 x' v | x' <- [x, x + signum (u - x) .. u]]
side
pathIn :: (V2 Int, V2 Int) -> [V2 Int]
= reverse . pathOut . swap
pathIn
pathFree :: World -> [V2 Int] -> Bool
= all ((== Just Empty) . (world Map.!?)) . tail
pathFree world
roomAvailable :: World -> AmphipodType -> Maybe (V2 Int)
= do
roomAvailable world amph <- destination Map.!? amph
cells let occupants = filter isAmphipod $ mapMaybe (world Map.!?) cells
if all (== Amphipod amph) occupants
then find ((== Just Empty) . (world Map.!?)) cells
else Nothing
legalMoveIn :: World -> [(V2 Int, V2 Int)]
= filter (pathFree world . pathIn) candidates
legalMoveIn world where candidates = [(src, tgt) | src <- outside
maybe False isAmphipod (world Map.!? src)
, <- maybeToList (roomAvailable world
, tgt =<< amphipodType =<< world Map.!? src)]
legalMoveOut :: World -> [(V2 Int, V2 Int)]
= filter (pathFree world . pathOut) candidates
legalMoveOut world where candidates = [(src, tgt) | src <- inside
maybe False isAmphipod (world Map.!? src)
, <- outside
, tgt Map.!? tgt == Just Empty]
, world
cost :: World -> (V2 Int, V2 Int) -> Maybe Int
= do
cost world (src, tgt) <- amphipodType =<< world Map.!? src
amph <- energyPerMove Map.!? amph
gpm let dist = sum (abs (tgt - src))
return $ dist * gpm
legalMoves :: World -> [((V2 Int, V2 Int), Int)]
= mapMaybe addCost $ legalMoveIn w <> legalMoveOut w
legalMoves w where addCost m = (m,) <$> cost w m
applyMove :: World -> (V2 Int, V2 Int) -> World
= Map.update (\_ -> world Map.!? src) tgt
applyMove world (src, tgt) $ Map.insert src Empty world
solutionA :: World -> Maybe Int
= minDist legalMoves applyMove world goal
solutionA world where goal = Map.fromList (foldMap (\(a, cs) -> (,Amphipod a) <$> cs)
<> world
(Map.toList destination))
= const 0
solutionB
<<run-solutions>>
```

# Day 24: Arithmetic Logic Unit

file:app/Day24.hs

```
module Day24 where
import RIO
import Parsing (Parser, string, char, integer, readInputParsing, sepEndBy1, eol, lexeme)
import Text.Megaparsec.Char (lowerChar)
import Tally (Tally(..))
data Var = W | X | Y | Z deriving (Show, Eq, Ord, Enum)
data Val = Ref Var | Lit Int deriving (Show, Eq, Ord)
data Instr
= Inp Var
| Add Var Val
| Mul Var Val
| Div Var Val
| Mod Var Val
| Eql Var Val
deriving (Show, Eq, Ord)
type Memory n = Maybe (n, n, n, n)
W = _1
var X = _2
var Y = _3
var Z = _4
var
read :: (MonadState (Memory n) m) => Var -> m n
read a = use (var a)
write :: (MonadState (Memory n) m) => Var -> n -> m ()
= ((var a) .=)
write a
modify :: (MonadState (Memory n) m) => Var -> (n -> n) -> m ()
= ((var a) %=)
modify a
resolve :: (MonadState (Memory n) m, Num n) => Val -> m n
Var a) = read a
resolve (Lit a) = fromInteger a
resolve (
varP :: Parser Var
= lexeme ( (char 'w' $> W)
varP <|> (char 'x' $> X)
<|> (char 'y' $> Y)
<|> (char 'z' $> Z))
valP :: Parser Val
= lexeme $ (Ref <$> varP) <|> (Lit <$> integer)
valP
instrP :: Parser Instr
= (lexeme (string "inp") $> Inp <*> varP)
instrP <|> (lexeme (string "add") $> Add <*> varP <*> valP)
<|> (lexeme (string "mul") $> Mul <*> varP <*> valP)
<|> (lexeme (string "div") $> Div <*> varP <*> valP)
<|> (lexeme (string "mod") $> Mod <*> varP <*> valP)
<|> (lexeme (string "eql") $> Eql <*> varP <*> valP)
readInput :: (HasLogFunc env) => RIO env [Instr]
= readInputParsing "data/day24.txt" (instrP `sepEndBy1` eol)
readInput
eval :: (MonadState Memory m, MonadReader n m, Num n) => Instr -> m ()
Inp a) = ask >>= write a
eval (Add a b) = resolve b modify a
eval (
= id
solutionA = const 0
solutionB
<<run-solutions>>
```

# Appendix: Boiler plate

«run-solutions»

```
runA :: (HasLogFunc env) => RIO env ()
= readInput >>= logInfo . display . tshow . solutionA
runA
runB :: (HasLogFunc env) => RIO env ()
= readInput >>= logInfo . display . tshow . solutionB runB
```

# Appendix: Output

RIO is missing easy functions for standard output, it’s a bit principled in that regard.

file:app/Print.hs

```
module Print where
import RIO
import qualified RIO.Text as Text
import RIO.ByteString (putStr)
import Data.Massiv.Array (Ix2(..))
print :: (MonadIO m) => Text -> m ()
print = putStr . Text.encodeUtf8
printLn :: (MonadIO m) => Text -> m ()
= print . (<> "\n")
printLn
printCoords :: MonadIO m => [Ix2] -> m ()
= mapM_ (\(x :. y) -> printLn $ tshow x <> " " <> tshow y) printCoords
```

# Appendix: Parsing

file:app/Parsing.hs

```
module Parsing
Parser, hspace, string, char, readInputParsing, lexeme
(
, integer, eol, sepEndBy1, sepBy1, failOnException, digit
, digitArray, dropUntilEol )where
import RIO
import RIO.Char (ord, GeneralCategory(LineSeparator), generalCategory)
import qualified RIO.Set as Set
import qualified RIO.Text as Text
import Text.Megaparsec
ParseErrorBundle, Parsec, parse, errorBundlePretty, sepEndBy1
( ErrorFancy(..), takeWhileP )
, sepBy1, fancyFailure, import Text.Megaparsec.Char (hspace, string, char, eol)
import qualified Text.Megaparsec.Char as C
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Data.Massiv.Array as A
type Parser = Parsec Void Text
instance Display (ParseErrorBundle Text Void) where
= Text.pack . errorBundlePretty
textDisplay
failOnException :: (Exception e) => Either e a -> Parser a
= either convertError return
failOnException where convertError = fancyFailure . Set.singleton
. ErrorFail . displayException
readInputParsing :: (MonadReader env m, MonadIO m, HasLogFunc env)
=> FilePath -> Parser a -> m a
= do
readInputParsing file p <- parse p file <$> readFileUtf8 file
x either (\e -> do { logError $ display e; exitFailure })
return x
lexeme :: Parser a -> Parser a
= L.lexeme hspace
lexeme
integer :: Parser Int
= do
integer <- maybe 1 (const (-1)) <$> optional (char '-')
sign_ <- lexeme L.decimal
abs_ return (sign_ * abs_)
digit :: Parser Int
= toValue <$> C.digitChar
digit where toValue c = ord c - ord '0'
dropUntilEol :: Parser ()
= void $ takeWhileP (Just "reading to eol")
dropUntilEol /= '\n')
(>> eol
<<digit-array-parser>>
```