Days 16 & 17 - My Brain Hurts
Subscribe to Monday Morning Haskell!
The last couple days (Day 16 & Day 17) have been extremely rough. I finally got working solutions but my code is still quite messy and inefficient, especially for Day 16 part 2. So I won't be doing detailed write-ups until I get a chance to try optimizing those. I'll share some insights for each problem though.
Day 16 Insights
This is a graph problem, and my immediate thought was, of course, to use Dijkstra's algorithm. It's a bit odd though. I treated the "cost" of each step through time as the sum of the unreleased pressure. Thus our search should be incentivized to turn off higher pressure valves as quickly as possible.
At first, I tried generating new graph states for each timestep. But this ended up being waaay too slow on the larger input graph. So I simplified to pre-calculating all distances between nodes (using Floyd Warshall) and limiting the search space to only those nodes with non-zero flow. This worked well enough for Part 1.
However, this solution appears to break completely in Part 2, where we add a second actor to the search. Each actor takes a different amount of time to reach their nodes, so running a simultaneous search is extremely difficult; there are dozens of cases and branches because of the possibility of an actor being "in between" nodes while the other reaches its valve, and I wasn't confident I could make it work.
What ultimately got me the answer was the suggestion to bisect the nodes into two disjoint sets. Each actor will then try to maximize their score on one of the sets, and we'll add them together. This sounds problematic because we need to then consider an exponential number of possible bisections. However, the number of non-zero flow nodes is only 15.
We can then exclude half the bisections, because it doesn't matter which player goes after which set of nodes. For example, if we divide them into {A, B} and {C, D}, we'll get the same result no matter if Player 1 is assigned {A,B} or if Player 2 (the elephant) is assigned {A, B}.
This leaves about 16000 options, which is large but not intractable. My final solution ran in about 30 minutes, which is very far from ideal.
On reddit I saw other people claiming to do exhaustive searches instead of using Dijkstra, which seemed strange to me. Perhaps I missed certain opportunities to prune my search; I'm not sure.
This is also a very reward-driven problem, so machine learning could definitely be used in some capacity.
Day 17 Insights
This problem involved writing a sort of Tetris simulator, as blocks fall and are blown by jets until they land on top of one another. The first part was tricky, with lots of possible logic errors, but I eventually got it working, correctly simulating the height of 2022 blocks falling.
Then in part 2, we need the height for one trillion blocks. Not only is this too many iterations to run through a simulator doing collision checking, it's too many to iterate through in any sense.
The trick is to look for some way to find a cycle in the resulting structure. Then you can use some math to figure out what the final height will be. I naively thought that the structure would be kind enough to reset at some point to a "flat" surface like the beginning in conjunction with a reset of the pieces and a reset of the jet directions (a trillion iterations seemed like a lot of opportunities for that to happen!).
However, the secret was to look for the pattern in the delta of the maximum height with each block. So I ran about one hundred thousand iterations, got all these values, and deployed a cycle finding algorithm on the results. This algorithm is a variation on the "tortoise and hare" approach to finding a cycle in a link list. Within the first few thousand iterations, it found a cycle that lasted about 1900 blocks. So I ended up getting the right answer after a lot of math.
Conclusion
As I said, I'll try to do more detailed write-ups once I take another look at optimizing these problems. But for now I have to focus my time on solving the newer problems!
Day 15 - Beacons and Scanners
Unfortunately this solution took me quite a while to complete (I spent a while on an infeasible solution), so I don't have as much time for details on the writeup.
Subscribe to Monday Morning Haskell!
Problem Overview
Solution Approach and Insights
My initial approach would effectively count every square that would be excluded, but this isn't feasible because the grid size is "millions by millions" for the large input.
If you actually consider the question being asked in the first part, then things become a bit easier. You can count the number of excluded spaces on single row by using arithmetic to gather a series of exclusion intervals. You can then sort and merge these, which allows you to count the number of excluded items very quickly.
Then in the second part, it is not prohibitive to go through this process for each of the 4 million rows until you find an interval list that has a gap.
Relevant Utilities
Manhattan distance:
type Coord2 = (Int, Int)
manhattanDistance :: Coord2 -> Coord2 -> Int
manhattanDistance (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1)Get neighbors in each direction:
getNeighbors4Unbounded :: Coord2 -> [Coord2]
getNeighbors4Unbounded (x, y) =
[ (x + 1, y)
, (x, y + 1)
, (x - 1, y)
, (x, y - 1)
]Parsing the Input
Here's a sample input:
Sensor at x=2, y=18: closest beacon is at x=-2, y=15
Sensor at x=9, y=16: closest beacon is at x=10, y=16
Sensor at x=13, y=2: closest beacon is at x=15, y=3
Sensor at x=12, y=14: closest beacon is at x=10, y=16
Sensor at x=10, y=20: closest beacon is at x=10, y=16
Sensor at x=14, y=17: closest beacon is at x=10, y=16
Sensor at x=8, y=7: closest beacon is at x=2, y=10
Sensor at x=2, y=0: closest beacon is at x=2, y=10
Sensor at x=0, y=11: closest beacon is at x=2, y=10
Sensor at x=20, y=14: closest beacon is at x=25, y=17
Sensor at x=17, y=20: closest beacon is at x=21, y=22
Sensor at x=16, y=7: closest beacon is at x=15, y=3
Sensor at x=14, y=3: closest beacon is at x=15, y=3
Sensor at x=20, y=1: closest beacon is at x=15, y=3Simple line-by-line stuff, combining keywords and numbers.
type InputType = [LineType]
type LineType = (Coord2, Coord2)
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput =
sepEndBy1 parseLine eol
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
string "Sensor at x="
i <- parseSignedInteger
string ", y="
j <- parseSignedInteger
string ": closest beacon is at x="
k <- parseSignedInteger
string ", y="
l <- parseSignedInteger
return ((i, j), (k, l))Part 1
To exclude coordinates on a particular row, determine if the distance from the sensor to that row is less than the manhattan distance to its nearest beacon. Whatever distance is leftover can be applied in both directions from the x coordinate (a column in this problem), giving an interval.
excludedCoords :: (MonadLogger m) => Int -> (Coord2, Coord2) -> m (Maybe Interval)
excludedCoords rowNum (sensor@(sx, sy), beacon) = do
let dist = manhattanDistance sensor beacon
let distToRow = abs (sy - rowNum)
let leftoverDist = dist - distToRow
if leftoverDist < 0
then return Nothing
else return $ Just (sx - leftoverDist, sx + leftoverDist)Intervals should be sorted and merged together, giving a disjoint set of intervals covering the whole row.
mergeIntervals :: (MonadLogger m) => [Interval] -> m [Interval]
mergeIntervals [] = return []
mergeIntervals intervals = do
let sorted = sort intervals
mergeTail [] (head sorted) (tail sorted)
where
mergeTail :: (MonadLogger m) => [Interval] -> Interval -> [Interval] -> m [Interval]
mergeTail accum current [] = return $ reverse (current : accum)
mergeTail accum current@(cStart, cEnd) (first@(fStart, fEnd) : rest) = if fStart > cEnd
then mergeTail (current : accum) first rest
else mergeTail accum (cStart, max cEnd fEnd) restNow let's count the total size of the intervals. In part 1, we have to be careful to exclude the locations of beacons themselves. This makes the operation quite a bit more difficult, introducing an extra layer of complexity to the recursion.
countIntervalsExcludingBeacons :: (MonadLogger m) => [Interval] -> [Int] -> m Int
countIntervalsExcludingBeacons intervals beaconXs = countTail 0 intervals (sort beaconXs)
where
countTail :: (MonadLogger m) => Int -> [Interval] -> [Int] -> m Int
countTail accum [] _ = return accum
countTail accum ((next1, next2) : rest) [] = countTail (accum + (next2 - next1 + 1)) rest []
countTail accum ints@((next1, next2) : restInts) beacons@(nextBeaconX : restBeacons)
| nextBeaconX < next1 = countTail accum ints restBeacons
| nextBeaconX > next2 = countTail (accum + (next2 - next1)) restInts restBeacons
| otherwise = countTail (accum - 1) ints restBeaconsNow combine all these together to get a final count of the excluded cells in this row. Note we need an extra parameter to these functions (the size) because the small input and large input use different row numbers on which to evaluate the excluded locations (10 vs. 2000000).
type EasySolutionType = Int
processInputEasy :: (MonadLogger m) => InputType -> Int -> m EasySolutionType
processInputEasy inputs size = do
resultingIntervals <- mapM (excludedCoords size) inputs
mergedIntervals <- mergeIntervals (catMaybes resultingIntervals)
let beacons = nub $ filter (\c@(_, y) -> y == size) (snd <$> inputs)
countIntervalsExcludingBeacons mergedIntervals (fst <$> beacons)
solveEasy :: FilePath -> Int -> IO (Maybe Int)
solveEasy fp size = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input sizePart 2
In part 2, we need one extra helping function. This finds a "hole" in a series of intervals, as long as that hold comes before the "max" column.
findHole :: (MonadLogger m) => [Interval] -> Int -> m (Maybe Int)
findHole [] _ = return Nothing
findHole [(start, end)] maxCol
| start > 0 = return (Just (start - 1))
| end < maxCol = return (Just (end + 1))
| otherwise = return Nothing
findHole ((start1, end1) : (start2, end2) : rest) maxCol = if end1 + 1 < start2 && (end1 + 1) >= 0 && (end1 + 1) <= maxCol
then return (Just (end1 + 1))
else findHole ((start2, end2) : rest) maxColThe rest of the solution for part 2 involves combining our old code for a evaluating a single row, just done recursively over all the rows until we find one that has a hole.
processInputHard :: (MonadLogger m) => InputType -> Int -> m HardSolutionType
processInputHard inputs maxDimen = evaluateRow 0
where
evaluateRow :: (MonadLogger m) => Int -> m (Maybe Coord2)
evaluateRow row = if row > maxDimen then return Nothing
else do
resultingIntervals <- mapM (excludedCoords row) inputs
mergedIntervals <- mergeIntervals (catMaybes resultingIntervals)
result <- findHole mergedIntervals maxDimen
case result of
Nothing -> evaluateRow (row + 1)
Just col -> return $ Just (col, row)Notice again we have an extra input, this time for the maxDimen, which is 20 for the small input and 4 million for the large part.
solveHard :: FilePath -> Int -> IO (Maybe Integer)
solveHard fp size = runStdoutLoggingT $ do
input <- parseFile parseInput fp
result <- processInputHard input size
findHardSolution resultVideo
Day 14 - Crushed by Sand?
Subscribe to Monday Morning Haskell!
Problem Overview
We're in a cave and sand is pouring on top of us! Not so great. Because sand is rough, and coarse, and irritating, and it gets everywhere.
But as long as we can calculate how many grains of sand will actually pour into the cave, I guess it's all right. Here's a diagram of the empty cave, with rock lines (#) that can catch grains of sand. The sand is falling in from the + position, with coordinates (500, 0). Note that y values increase as we go down into the cave.
4 5 5
9 0 0
4 0 3
0 ......+...
1 ..........
2 ..........
3 ..........
4 ....#...##
5 ....#...#.
6 ..###...#.
7 ........#.
8 ........#.
9 #########.As the sand pours in, it eventually falls into an abyss off the edge (at least in part 1).
.......+...
.......~...
......~o...
.....~ooo..
....~#ooo##
...~o#ooo#.
..~###ooo#.
..~..oooo#.
.~o.ooooo#.
~#########.
~..........
~..........
~..........Parsing the Input
Our actual puzzle input (not the diagram) is laid out line-by-line, where each line has a variable number of coordinates:
498,4 -> 498,6 -> 496,6
503,4 -> 502,4 -> 502,9 -> 494,9These coordinates give us the locations of the "rock lines" in the cave, denoted by # in the images above. The spaces between each input coordinate are filled out.
Parsing this isn't too hard. We use sepBy1 and a parser for the arrow in between, and then parse two comma separated numbers. Easy stuff with Megaparsec:
parseLine :: Monad m => ParsecT Void Text m [Coord2]
parseLine = sepBy1 parseNumbers (string " -> ")
where
parseNumbers = do
i <- parsePositiveNumber
char ','
j <- parsePositiveNumber
return (i, j)Getting all these lines line-by-line isn't a challenge. What's a little tricky is taking the coordinates and building out our initial set of all the coordinates covered by rocks. This should take a nested list of coordinates and return our final set.
type InputType = HS.HashSet Coord2
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
coordLines <- sepEndBy1 parseLine eol
lift $ buildInitialMap coordLines
buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
...How does this function work? Well first we need a function that will take two coordinates and fill in the missing coordinates between them. We have the horizontal and vertical cases. List comprehensions are our friend here (and tuple sections!). We just need to get the direction right so the comprehension goes the correct direction. We'll have one error case if the line isn't perfectly horizontal or vertical.
makeLine :: (MonadLogger m) => Coord2 -> Coord2 -> m [Coord2]
makeLine a@(a1, a2) b@(b1, b2)
| a1 == b1 = return $ map (a1,) (if a2 >= b2 then [b2,(b2+1)..a2] else [a2,(a2+1)..b2])
| a2 == b2 = return $ map (,b2) (if a1 >= b1 then [b1,(b1+1)..a1] else [a1,(a1+1)..b1])
| otherwise = logErrorN ("Line is neither horizontal nor vertical: " <> (pack . show $ (a, b))) >> return []Now the rest of buildInitialMap requires a loop. We'll go through each coordinate list, but use recursion in such a way that we're always considering the front two elements of the list. So length 0 and length 1 are base cases.
buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
buildInitialMap = foldM f HS.empty
where
f :: (MonadLogger m) => HS.HashSet Coord2 -> [Coord2] -> m (HS.HashSet Coord2)
f prevSet [] = return prevSet
f prevSet [_] = return prevSet
f prevSet (firstCoord : secondCoord : rest) = ...And the recursive case isn't too hard either. We'll get the new coordinates with makeLine and then use another fold to insert them into the set. Then we'll recurse without removing the second coordinate.
buildInitialMap :: (MonadLogger m) => [[Coord2]] -> m (HS.HashSet Coord2)
buildInitialMap = foldM f HS.empty
where
f :: (MonadLogger m) => HS.HashSet Coord2 -> [Coord2] -> m (HS.HashSet Coord2)
f prevSet [] = return prevSet
f prevSet [_] = return prevSet
f prevSet (firstCoord : secondCoord : rest) = do
newCoords <- makeLine firstCoord secondCoord
f (foldl (flip HS.insert) prevSet newCoords) (secondCoord : rest)So now we've got a hash set with all the "blocked" coordinates. How do we solve the problem?
Getting the Solution
The key to this problem is writing a function to drop a single grain of sand and take that to its logical conclusion. We need to determine if it either comes to rest (adding a new location to our hash set) or if it falls into the abyss (telling us that we're done).
This is easy as long as we can wrap our heads around the different cases. Most importantly, there's the end condition. When do we stop counting? Well once a grain falls below the maximum y-value of our walls, there will be nothing to stop it. So let's imagine we're taking this maxY value as a parameter.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces = ...Now there are several cases here that we'll evaluate in order:
- Grain is past maximum y
- Space below the grain is empty
- Space below and left of the grain is empty
- Space below and right of the grain is empty
- All three spaces are blocked.
We can describe all these cases using guards:
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = ...
| not (HS.member (x, y + 1) filledSpaces) = ...
| not (HS.member (x - 1, y + 1) filledSpaces) = ...
| not (HS.member (x + 1, y + 1) filledSpaces) = ...
| otherwise = ...The first case is our base case. We'll return False without inserting anything.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = return (filledSpaces, False)
...In the next three cases, we'll recurse, imagining this grain falling to the coordinate in question.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = return (filledSpaces, False)
| not (HS.member (x, y + 1) filledSpaces) = dropSand maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand maxY (x + 1, y + 1) filledSpaces
...In the final case, we'll insert the coordinate into the set, and return True.
dropSand :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand maxY (x, y) filledSpaces
| y > maxY = return (filledSpaces, False)
| not (HS.member (x, y + 1) filledSpaces) = dropSand maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand maxY (x + 1, y + 1) filledSpaces
| otherwise = return (HS.insert (x, y) filledSpaces, True)Now we just need to call this function in a recursive loop. We drop a grain of sand from the starting position. If it lands, we recurse with the updated set and add 1 to our count. If it doesn't land, we return the number of grains we've stored.
evolveState :: (MonadLogger m) => Int -> (HS.HashSet Coord2, Int) -> m Int
evolveState maxY (filledSpaces, prevSands) = do
(newSet, landed) <- dropSand maxY (500, 0) filledSpaces
if landed
then evolveState maxY (newSet, prevSands + 1)
else return prevSandsAnd all that's left is to call this with an initial value, including grabbing the maxY parameter from our initial hash set:
type EasySolutionType = Int
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputWalls = do
let maxY = maximum $ snd <$> HS.toList inputWalls
evolveState maxY (inputWalls, 0)Part 2
Part 2 is not too different. Instead of imagining the sand falling into the abyss, we actually have to imagine there's an infinite horizontal line two levels below the maximum y-value.
...........+........
....................
....................
....................
.........#...##.....
.........#...#......
.......###...#......
.............#......
.............#......
.....#########......
....................
<-- etc #################### etc -->This means the sand will eventually stop flowing once we have three grains below our starting location. We'll place one final grain at the start location, and then we'll be done.
............o............
...........ooo...........
..........ooooo..........
.........ooooooo.........
........oo#ooo##o........
.......ooo#ooo#ooo.......
......oo###ooo#oooo......
.....oooo.oooo#ooooo.....
....oooooooooo#oooooo....
...ooo#########ooooooo...
..ooooo.......ooooooooo..
#########################The approach stays mostly the same, so we'll make a copy of our dropSand function, except with an apostrophe to differentiate it (dropSand'). We just have to tweak the end conditions in this function a little bit.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)Our first condition of y > maxY should now work the same as the previous otherwise case, because all grains should come to rest once they hit maxY + 1. We'll insert the coordinate into our set and return True.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
| y > maxY = return (HS.insert (x, y) filledSpaces, True)
...The middle conditions don't change at all.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
| y > maxY = return (HS.insert (x, y) filledSpaces, True)
| not (HS.member (x, y + 1) filledSpaces) = dropSand' maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand' maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand' maxY (x + 1, y + 1) filledSpaces
...Now we need our otherwise case. In this case, we've determined that our grain is blocked on all three spaces below it. Generally, we still want to insert it into our set. However, if the location we're inserting is the start location (500, 0), then we should return False to indicate it's time to stop recursing! Otherwise we return True as before.
dropSand' :: (MonadLogger m) => Int -> Coord2 -> HS.HashSet Coord2 -> m (HS.HashSet Coord2, Bool)
dropSand' maxY (x, y) filledSpaces
| y > maxY = return (HS.insert (x, y) filledSpaces, True)
| not (HS.member (x, y + 1) filledSpaces) = dropSand' maxY (x, y + 1) filledSpaces
| not (HS.member (x - 1, y + 1) filledSpaces) = dropSand' maxY (x - 1, y + 1) filledSpaces
| not (HS.member (x + 1, y + 1) filledSpaces) = dropSand' maxY (x + 1, y + 1) filledSpaces
| otherwise = return (HS.insert (x, y) filledSpaces, (x, y) /= (500, 0))The rest of the code for part 2 stays basically the same!
evolveState' :: (MonadLogger m) => Int -> StateType -> m Int
evolveState' maxY (filledSpaces, prevSands) = do
(newSet, landed) <- dropSand' maxY (500, 0) filledSpaces
if landed
then evolveState' maxY (newSet, prevSands + 1)
else return (prevSands + 1)
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputWalls = do
let maxY = maximum $ snd <$> HS.toList inputWalls
evolveState' maxY (inputWalls, 0)Answering the Question
And now we're able to solve both parts by combining our code.
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputThis gives us our final answer, so we're done! This is another case where some better abstracting could save us from copying code. But when trying to write a solution as quickly as possible, copying old code is often the faster approach!
Video
Day 13 - Sorting Nested Packets
Subscribe to Monday Morning Haskell!
Problem Overview
For today's problem, we're parsing and comparing packets, which appear as integers in lists with potentially several levels of nesting. In part 1, we'll consider the packets 2-by-2 and determine how many pairs are already ordered correctly. Then in part 2, we'll sort all the packets and determine the right place to insert a couple new packets.
Solution Approach and Insights
Haskell works very well for this problem! The ability to use a sum type, simple recursive parsing, and easy ordering mechanism make this a smooth solution.
Parsing the Input
Here's a sample input:
[1,1,3,1,1]
[1,1,5,1,1]
[[1],[2,3,4]]
[[1],4]
[9]
[[8,7,6]]
[[4,4],4,4]
[[4,4],4,4,4]
[7,7,7,7]
[7,7,7]
[]
[3]
[[[]]]
[[]]
[1,[2,[3,[4,[5,6,7]]]],8,9]
[1,[2,[3,[4,[5,6,0]]]],8,9]Once again, we have blank line separation. Another noteworthy factor is that the empty list [] is a valid packet.
So let's start with a simple sum type to represent a single packet:
data Packet =
IntPacket Int |
ListPacket [Packet]
deriving (Show, Eq)To parse an individual packet, we have two cases. The IntPacket case is easy:
parsePacket :: (MonadLogger m) => ParsecT Void Text m Packet
parsePacket = parseInt <|> parseList
where
parseInt = parsePositiveNumber <&> IntPacket
parseList = ...To parse a list, we'll of course need to account for the bracket characters. But we'll also want to use sepBy (not sepBy1 since an empty list is valid!) in order to recursively parse the subpackets of a list.
parsePacket :: (MonadLogger m) => ParsecT Void Text m Packet
parsePacket = parseInt <|> parseList
where
parseInt = parsePositiveNumber <&> IntPacket
parseList = do
char '['
packets <- sepBy parsePacket (char ',')
char ']'
return $ ListPacket packetsAnd now to complete the parsing, we'll parse two packets together in a pair:
parsePacketPair :: (MonadLogger m) => ParsecT Void Text m (Packet, Packet)
parsePacketPair = do
p1 <- parsePacket
eol
p2 <- parsePacket
eol
return (p1, p2)And then return a whole list of these pairs:
type InputType = [(Packet, Packet)]
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parsePacketPair eolGetting the Solution
The core of the solution is writing a proper ordering on the packets. By using an Ordering instead of simply a Bool when comparing two packets, it will be easier to use this function recursively. We'll need to do this when comparing packet lists! So let's start with the type signature:
evalPackets :: Packet -> Packet -> OrderingThere are several cases that we can handle 1-by-1. First, to compare two IntPacket values, we just compare the underlying numbers.
evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
...Now we have two cases where one value is an IntPacket and the other is a ListPacket. In these cases, we promote the IntPacket to a ListPacket with a singleton. Then we can recursively evaluate them.
evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
evalPackets (IntPacket a) b@(ListPacket _) = evalPackets (ListPacket [IntPacket a]) b
evalPackets a@(ListPacket _) (IntPacket b) = evalPackets a (ListPacket [IntPacket b])
...Now for the case of two ListPacket inputs. Once again, we have to do some case analysis depending on if the lists are empty or not. If both are empty, the packets are equal (EQ).
evalPackets :: Packet -> Packet -> Ordering
...
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
([], []) -> EQ
...If only the first packet is empty, we return LT. Conversely, if the second list is empty but the first is non-empty, we return GT.
evalPackets :: Packet -> Packet -> Ordering
...
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
([], []) -> EQ
([], _) -> LT
(_, []) -> GT
...Finally, we think about the case where both have at least one element. We start by comparing these two front packets. If they are equal, we must recurse on the remainder lists. If not, we can return that result.
evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
evalPackets (IntPacket a) b@(ListPacket _) = evalPackets (ListPacket [IntPacket a]) b
evalPackets a@(ListPacket _) (IntPacket b) = evalPackets a (ListPacket [IntPacket b])
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
([], []) -> EQ
([], _) -> LT
(_, []) -> GT
(a : rest1, b : rest2) ->
let compareFirst = evalPackets a b
in if compareFirst == EQ
then evalPackets (ListPacket rest1) (ListPacket rest2)
else compareFirstWith this function in place, the first part is quite easy. We loop through the list of packet pairs with a fold. We'll zip with [1,2..] in order to match each pair to its index.
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = foldM foldLine initialFoldV (zip [1,2..] inputs)
type FoldType = Int
initialFoldV :: FoldType
foldLine :: (MonadLogger m) => FoldType -> (Int, (Packet, Packet)) -> m FoldTypeThe FoldType value is just our accumulated score. Each time the packets match, we add the index to the score.
initialFoldV :: FoldType
initialFoldV = 0
foldLine :: (MonadLogger m) => FoldType -> (Int, (Packet, Packet)) -> m FoldType
foldLine prev (index, (p1, p2)) = do
let rightOrder = evalPackets p1 p2
return $ if rightOrder == LT then prev + index else prevAnd that gets us our solution to part 1!
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy inputPart 2
Part 2 isn't much harder. We want to sort the packets using our ordering. But first we should append the two divider packets [[2]] and [[6]] to that list.
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
let divider1 = ListPacket [ListPacket [IntPacket 2]]
divider2 = ListPacket [ListPacket [IntPacket 6]]
newInputs = (divider1, divider2) : inputs
...Now we concatenate the pairs together, sort the list with the ordering, and find the locations of our two divider packets in the resulting list!
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
let divider1 = ListPacket [ListPacket [IntPacket 2]]
divider2 = ListPacket [ListPacket [IntPacket 6]]
newInputs = (divider1, divider2) : inputs
sortedPackets = sortBy evalPackets $ concat (pairToList <$> newInputs)
i1 = elemIndex divider1 sortedPackets
i2 = elemIndex divider2 sortedPackets
...As long as we get two Just values, we'll multiply them together (except we need to add 1 to each index). This gives us our answer!
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
let divider1 = ListPacket [ListPacket [IntPacket 2]]
let divider2 = ListPacket [ListPacket [IntPacket 6]]
newInputs = (divider1, divider2) : inputs
sortedPackets = sortBy evalPackets $ concat (pairToList <$> newInputs)
i1 = elemIndex divider1 sortedPackets
i2 = elemIndex divider2 sortedPackets
case (i1, i2) of
(Just index1, Just index2) -> return $ (index1 + 1) * (index2 + 1)
_ -> return (-1)
where
pairToList (a, b) = [a, b]
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputAnd now we're done with Day 13, and have just passed the halfway mark!
Video
Day 12 - Taking a Hike
Subscribe to Monday Morning Haskell!
Problem Overview
For today's problem we're hiking through a trail represented with a 2D height map. We're given a start point (at low elevation) and an endpoint (at high elevation). We want to find the shortest path from start to end, but we can't increase our elevation by more than 1 with each step.
For the second part, instead of fixing our start position, we'll consider all the different positions with the lowest elevation. We'll see which one of these has the shortest path to the end!
Solution Approach and Insights
We can turn this into a graph problem, and because every "step" has the same cost, this is a textbook BFS problem! We'll be able to apply this bfsM function from the Algorithm.Search library.
Relevant Utilities
There are a few important pre-existing (or mostly pre-existing) utilities for 2D grids that will help with this problem.
Recall from Day 8 that we could use these functions to parse a 2D digit grid into a Haskell Array.
I then adapted the digit parser to also work with characters, resulting in this function.
Another useful helper is this function getNeighbors, which gives us the four neighbors (up/down/left/right) of a coordinate in a 2D grid, while accounting for bounds checking.
Parsing the Input
So given a sample input:
Sabqponm
abcryxxl
accszExk
acctuvwj
abdefghiIt's easy to apply the first step and get the digits into an array with our helper from above.
type InputType = (Grid2 Char, Coord2, Coord2)
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
charArray <- parse2DCharacterArray
...However, we want to do a bit of post-processing. As you can see from my input type definition, we want to include the start and end coordinates of the grid as well. We'll also want to substitute the correct height values for those ('a' for 'S' and 'z' for 'E') back into the grid.
We start by finding the 'S' and 'E' characters and asserting that they exist.
postProcessGrid :: (MonadLogger m) => Grid2 Char -> m InputType
postProcessGrid parsedChars = do
let allAssocs = A.assocs parsedChars
start = find (\(c, v) -> v == 'S') allAssocs
end = find (\(c, v) -> v == 'E') allAssocs
case (start, end) of
(Just (s, _), Just (e, _)) -> ...
_ -> logErrorN "Couldn't find start or end!" >> return (parsedChars, (0, 0), (0, 0))Now in the case they do, we just use the Array // operator to make the substitution and create our new grid.
postProcessGrid :: (MonadLogger m) => Grid2 Char -> m InputType
postProcessGrid parsedChars = do
let allAssocs = A.assocs parsedChars
start = find (\(c, v) -> v == 'S') allAssocs
end = find (\(c, v) -> v == 'E') allAssocs
case (start, end) of
(Just (s, _), Just (e, _)) -> do
let newGrid = parsedChars A.// [(s, 'a'), (e, 'z')]
return (newGrid, s, e)
_ -> logErrorN "Couldn't find start or end!" >> return (parsedChars, (0, 0), (0, 0))So our final parsing function looks like this:
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
charArray <- parse2DCharacterArray
lift $ postProcessGrid charArrayGetting the Solution
Now we'll fill in processInputEasy to get our first solution.
type EasySolutionType = Int
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = ...To get the solution, we'll apply the bfsM function mentioned above. We need three items:
- The function to determine the neighboring states
- The end condition
- The start value
For the purposes of our Breadth First Search, we'll imagine that our "state" is just the current coordinate. So the start value and end condition are given immediately.
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = do
result <- bfsM (...) (\c -> return (c == end)) start
...Now we need a function to calculate the neighbors. This will, of course, incorporate the getNeighbors helper above. It will also take our grid as a constant parameter:
validMoves :: (MonadLogger m) => Grid2 Char -> Coord2 -> m [Coord2]
validMoves grid current = do
let neighbors = getNeighbors grid current
...We now need to filter these values to remove neighbors that we can't move too because they are too high. This just requires comparing each new height to the current height using Data.Char.ord, and ensuring this difference is no greater than 1.
validMoves :: (MonadLogger m) => Grid2 Char -> Coord2 -> m [Coord2]
validMoves grid current = do
let neighbors = getNeighbors grid current
currentHeight = grid A.! current
return $ filter (neighborTest currentHeight) neighbors
where
neighborTest currentHeight newCoord =
let newHeight = grid A.! newCoord
in ord newHeight - ord currentHeight <= 1And now we can fill in our definition for bfsM!
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = do
result <- bfsM (validMoves parsedGrid) (\c -> return (c == end)) start
...The last touch is to check the result because we want its size. If it's Nothing, we'll return maxBound as an error case. Otherwise, we'll take the length of the path.
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (parsedGrid, start, end) = do
result <- bfsM (validMoves parsedGrid) (\c -> return (c == end)) start
case result of
Nothing -> return maxBound
Just path -> return (length path)Part 2
Now we need the "hard" solution for part 2. For this part, we take the same input but ignore the given start. Instead, we'll filter the array to find all positions with height a.
type HardSolutionType = EasySolutionType
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard (parsedGrid, _, end) = do
let allStarts = fst <$> filter (\(_, h) -> h == 'a') (A.assocs parsedGrid)
...Now we can map through each of these starts, and use our easy solution function to get the shortest path length! Then we'll take the minimum of these to get our answer.
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard (parsedGrid, _, end) = do
let allStarts = fst <$> filter (\(_, h) -> h == 'a') (A.assocs parsedGrid)
results <- mapM (\start -> processInputEasy (parsedGrid, start, end)) allStarts
return $ minimum resultsNote: while this solution for part 2 was the first solution I could think of and took the least additional code to write, we could optimize this part by reversing the search! If we start at the end point and search until we find any a elevation point, we'll solve this with only a single BFS instead of many!
Answering the Question
Nothing more is needed to calculate the final answers! We just parse the input and solve!
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputAnd we're done with Day 12, and almost halfway there!
Video
Day 11 - Monkeying Around
Today's problem was definitely the trickiest so far. It was the most complicated input format yet, and the part 2 twist definitely threw a wrench in the works. I also didn't get started until almost midnight, rather than the usual 9pm pacific time, which made things interesting.
Subscribe to Monday Morning Haskell!
Problem Overview
Monkeys have stolen our things and are throwing them around playing keep away. Apparently they can tell how worried we are about losing our items, and will throw the items to different monkeys depending on these numbers. Generally, we decide we'll track down the two monkeys who throw the most items.
In part 1, we'll simulate 20 rounds of the monkeys throwing and determine who threw the most items. In part 2 though, we encounter significant scaling problems. Our "worry" value for each item changes each round, often multiplicatively. Part 2 removes a feature that lets us divide the value back down each time. We also run 10000 rounds, so the size of these values will get out of control if we're not careful!
Solution Approach and Insights
Overall, this is a state evolution problem. We run a certain number of steps, and evolve our state each time. Folding mechanics will also play into this.
The key trick for part 2 lies in how we use the "worry" values. What happens each time a monkey inspects an item is that a divisibility check is performed, and the new monkey to get the item depends on the outcome of this check.
But since this is the only use for the worry value, instead of storing the value itself, we'll store a mapping of its modulus with respect to all the divisibility check values.
Parsing the Input
The input is quite intricate. We've taken a lot of "notes" on the monkeys' behavior. So we can parse the "worry" values of the items they start with. But we also note an "operation", which is how much the worry value rises each time that monkey inspects an item.
Finally, there is a "test" for each monkey. It will tell us a number to divide by. If the worry value is divisible by that number, it will throw to the first monkey on the following line. Otherwise, the item is thrown to the monkey on the "false" line.
Here's a sample input:
Monkey 0:
Starting items: 79, 98
Operation: new = old * 19
Test: divisible by 23
If true: throw to monkey 2
If false: throw to monkey 3
Monkey 1:
Starting items: 54, 65, 75, 74
Operation: new = old + 6
Test: divisible by 19
If true: throw to monkey 2
If false: throw to monkey 0We'll need a MonkeyRule type that tracks the rules for each monkey telling us the operation performed on the worry value, the divisibility check number, and the monkeys we might throw to. From perusing the input files, we can see that the possible operations are 1.) adding a number, 2.) multiplying by a number and 3.) squaring the old number. So capture these in an Operation type.
data MonkeyRule = MonkeyRule
{ mrOperation :: Operation
, testDivisible :: Int
, throwTrue :: Int
, throwFalse :: Int
} deriving (Show)
data Operation =
Addx Int |
Multx Int |
Square
deriving (Show)Now the rules themselves are static, so we can capture those in an Array. But we'll also want to track the sequence of items a monkey has. This will be dynamic, so it will live in a different HashMap structure.
type MonkeyRules = A.Array Int MonkeyRule
type MonkeyItems = HM.HashMap Int (Seq.Seq Int)
type InputType = (MonkeyItems, MonkeyRules)Now let's parse the input! Essentially, we want one parser for each of the types of lines in our input. These follow the patterns we've generally seen, with string signifiers and then some numbers. Parsing an operation is a little tricky because of the old * old possibility, but alternatives still make this easy.
parseStartingItems :: (MonadLogger m) => ParsecT Void Text m [Int]
parseStartingItems = do
string " Starting items: "
nums <- sepBy1 parsePositiveNumber (string ", ")
eol
return nums
parseOperation :: (MonadLogger m) => ParsecT Void Text m Operation
parseOperation = do
string " Operation: new = old "
op <- try addOp <|> try multOp <|> squareOp
eol
return op
where
addOp = string "+ " >> parsePositiveNumber >>= return . Addx
multOp = string "* " >> parsePositiveNumber >>= return . Multx
squareOp = string "* old" >> return Square
parseTest :: (MonadLogger m) => ParsecT Void Text m Int
parseTest = do
string " Test: divisible by "
i <- parsePositiveNumber
eol
return i
parseThrow :: (MonadLogger m) => ParsecT Void Text m Int
parseThrow = do
string " If "
string "true" <|> string "false"
string ": throw to monkey "
i <- parsePositiveNumber
eol
return iAnd now we combine all these together to parse a single Monkey. We'll return two tuples - one matching the monkey index to its sequence of items, and another to its rule.
parseMonkey :: (MonadLogger m) => ParsecT Void Text m ((Int, Seq.Seq Int), (Int, MonkeyRule))
parseMonkey = do
string "Monkey "
i <- parsePositiveNumber
char ':'
eol
startingNums <- parseStartingItems
op <- parseOperation
test <- parseTest
true <- parseThrow
false <- parseThrow
eol
return ((i, Seq.fromList startingNums), (i, MonkeyRule op test true false))The index is repeated because this makes it easier for us to construct our final types from the accumulation of monkey notes.
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
monkeys <- some parseMonkey
let indices = fst . snd <$> monkeys
return (HM.fromList (fst <$> monkeys), A.array (minimum indices, maximum indices) (snd <$> monkeys))Getting the Solution
So with each "round", we loop through the monkeys. Each monkey processes all their items. And in processing each item, we update our state, which is the mapping from monkeys to the items they hold. We will play a total of 20 rounds.
With these rules in mind, we can start writing our solution outline. We'll define our state type with the items map, as well as an occurrence map for the number of times a monkey inspects an item (this will help us get our answer).
type StateType = (MonkeyItems, OccMap Int)
initialStateV :: MonkeyItems -> StateType
initialStateV i = (i, emptyOcc)Now we'll have functions for 1.) running the full round, 2.) processing each monkey and 3.) processing each item.
playRound :: (MonadLogger m) => MonkeyRules -> StateType -> m StateType
playMonkey :: (MonadLogger m) => MonkeyRules -> StateType -> Int -> m StateType
playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateTypeWe'll write our solveStateN function, which will call playRound the given number of times, recursing with n - 1 until it reaches 0.
solveStateN :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> m StateType
solveStateN _ 0 st = return st
solveStateN rules n st = do
st' <- playRound rules st
solveStateN rules (n - 1) st'Playing a full round is a simple fold through the monkeys. We use the "rules" array as the source of truth for all the indices we want to loop through, and to make sure we loop through them in order.
-- Play a full round (all monkeys)
playRound :: (MonadLogger m) => MonkeyRules -> StateType -> m StateType
playRound rules st = foldM (playMonkey rules) st (Ix.range (A.bounds rules))Processing a monkey is also a simple fold loop through the items, with the added part that we set the monkey's own item list to empty after it's done. This spares us the trouble of making two map updates each time we process an item.
-- Process all the items a single monkey has
playMonkey :: (MonadLogger m) => MonkeyRules -> StateType -> Int -> m StateType
playMonkey rules st monkey = do
(newItems, newOcc) <- foldM (playItem rules monkey) st (fst st HM.! monkey)
return (HM.insert monkey Seq.empty newItems, newOcc)Processing one item is where most of the core logic happens. To do the core processing, we first have to think about "applying" an operation. For part 1, this is simple, because our worry values are just Int values.
applyOp :: Operation -> Int -> Int
applyOp (Addx x) a = x + a
applyOp (Multx x) a = x * a
applyOp Square a = a * aNow that we can apply the operation to our worry values, we can use the rules correctly. We start by incrementing the counter for the monkey processing the item, and fetching its rule from the array.
playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
let occ2 = incKey occ1 monkey
rule = rules A.! monkey
...Now we update the worry value. First, we apply the operation. Then, just for part 1, we divide it by 3.
playItem rules monkey (items, occ1) item = do
let occ2 = incKey occ1 monkey
rule = rules A.! monkey
worry1 = applyOp (mrOperation rule) item
worry2 = worry1 `quot` 3
...Now we perform the throw check to determine which monkey we're throwing to.
playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
let occ2 = incKey occ1 monkey
rule = rules A.! monkey
worry1 = applyOp (mrOperation rule) item
worry2 = worry1 `quot` 3
throwTo = if worry2 `mod` testDivisible rule == 0
then throwTrue rule else throwFalse rule
...Finally, we gather the pre-existing items sequence for the new monkey, insert the appended sequence into our state, and then return the updated state.
playItem :: (MonadLogger m) => MonkeyRules -> Int -> StateType -> Int -> m StateType
playItem rules monkey (items, occ1) item = do
let occ2 = incKey occ1 monkey
rule = rules A.! monkey
worry1 = applyOp (mrOperation rule) item
worry2 = worry1 `quot` 3
throwTo = if worry2 `mod` testDivisible rule == 0
then throwTrue rule else throwFalse rule
currentThrowToSeq = items HM.! throwTo
newItems = HM.insert throwTo (currentThrowToSeq Seq.|> worry2) items
return (newItems, occ2)This is all our core logic code for part 1. Before we combine everything and get our solution, let's see how the problem changes in part 2.
Part 2
In part 2 we no longer divide by 3, and we run 10000 rounds. This means our worry values will get too big. So instead of treating each item as an Int, we'll track its modulus with respect to all the divisibility check values in the rules, calling this a ModulusHash. Our stateful type will map monkey indices to sequences of this type instead of Int. Here's how we initialize this type given our starting values:
type ModuloHash = HM.HashMap Int Int
type StateType2 = (HM.HashMap Int (Seq.Seq ModuloHash), OccMap Int)
initialStateHard :: (MonkeyItems, MonkeyRules) -> StateType2
initialStateHard (items, rules) = (HM.map (fmap mkModuloHash) items, emptyOcc)
where
allDivisibles = testDivisible <$> A.elems rules
mkModuloHash x = HM.fromList (map (\d -> (d, x `mod` d)) allDivisibles)Applying an operation now looks a little different. The keys in this map are all the divisors for the different monkeys and their divisibility checks. The values in the map tell us the existing moduluses (moduli?) for each key. If we add a value to the modulus and re-take the modulus, the resulting modulus is the same as if we were just tracking the original number. Same with multiplication. We can use mapWithKeys to capture the idea of modifying each value, but using the key to help with this process.
applyOpHard :: Operation -> ModuloHash -> ModuloHash
applyOpHard (Addx x) modHash = HM.mapWithKey (\k v1 -> (v1 + x) `mod` k) modHash
applyOpHard (Multx x) modHash = HM.mapWithKey (\k v1 -> (v1 * x) `mod` k) modHash
applyOpHard Square modHash = HM.mapWithKey (\k v1 -> (v1 * v1) `mod` k) modHashThe inner parentheses on each line (as in (v1 + x)) are necessary! Otherwise x mod k takes precedence and you'll get the wrong result!
But now we can rewrite playItem to work with this function. It looks very similar, except without division by 3.
playItemHard :: (MonadLogger m) => MonkeyRules -> Int -> StateType2 -> ModuloHash -> m StateType2
playItemHard rules monkey (items, occ1) item = do
let occ2 = incKey occ1 monkey
rule = rules A.! monkey
worry1 = applyOpHard (mrOperation rule) item
throwTo = if worry1 HM.! testDivisible rule == 0
then throwTrue rule else throwFalse rule
currentThrowToSeq = items HM.! throwTo
newItems = HM.insert throwTo (currentThrowToSeq Seq.|> worry1) items
return (newItems, occ2)And now I found the perfect way to generalize this idea across part 1 and part 2.
Just kidding.
It was 1:30am at this point so I just copied most of my part 1 code over and tweaked the types a bit.
solveStateNHard :: (MonadLogger m) => MonkeyRules -> Int -> StateType2 -> m StateType2
solveStateNHard _ 0 st = return st
solveStateNHard rules n st = do
st' <- playRoundHard rules st
solveStateNHard rules (n - 1) st'
playRoundHard :: (MonadLogger m) => MonkeyRules -> StateType2 -> m StateType2
playRoundHard rules st = foldM (playMonkeyHard rules) st (Ix.range (A.bounds rules))
playMonkeyHard :: (MonadLogger m) => MonkeyRules -> StateType2 -> Int -> m StateType2
playMonkeyHard rules st monkey = do
(newItems, newOcc) <- foldM (playItemHard rules monkey) st (fst st HM.! monkey)
return (HM.insert monkey Seq.empty newItems, newOcc)Answering the Question
At long last we're ready to answer the question. For part 1, we run solveStateN 20 times and take the snd value, which is the occurrence map.
type EasySolutionType = OccMap Int
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (initialItems, rules) = snd <$> solveStateN rules 20 (initialStateV initialItems)Then we sort its elements, take the highest 2, and multiply them.
findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe Int)
findEasySolution finalOccMap = do
let results = take 2 . reverse . sort $ M.elems finalOccMap
return $ Just $ fromIntegral $ product resultsPart 2 is similar, but we run 10000 rounds:
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard input@(_, rules) = snd <$> solveStateNHard rules 10000 (initialStateHard input)And then before multiplying our top 2 values, we use fmap fromIntegral to convert them to Integer values, because the product will go beyond the Word limit.
findHardSolution :: (MonadLogger m) => HardSolutionType -> m (Maybe Integer)
findHardSolution finalOccMap = do
let results = fmap fromIntegral . take 2 . reverse . sort $ M.elems finalOccMap
return $ Just $ product resultsAnd now we can combine our pieces!
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
result <- processInputEasy input
findEasySolution result
solveHard :: FilePath -> IO (Maybe Integer)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
result <- processInputHard input
findHardSolution resultPerhaps it was just the result of doing this late at night, but this problem was a definite marathon for me, and there are still 14 days left! So plenty of time for problems to get even harder. At some point next year I'll come back to this problem and clean up the abstraction.
Video
Day 10 - Instruction Processing
Subscribe to Monday Morning Haskell!
Problem Overview
Today we're processing some very simple machine instructions. The only instructions we have are "noop" (which does nothing) and "addx", which adds (or subtracts) an integer to a single register value.
In the first part, we'll deal with the "signal strength", which multiplies the cycle number by the current register value at certain cycles.
In the second part, we'll actually render a message using the register value in a very interesting way! The full instructions for this are a bit intricate. But essentially, depending on the register value and the cycle number, we either render a light bit # or a dark bit ., and then rearrange these bits in a 40-column by 6-row grid.
Solution Approach and Insights
The main thing here is determining how to handle the cycle updates. The stateful nature of the problem makes it a bit tricky - off-by-one issues are lurking everywhere! But if the cycle update is correct, the rest of the problem is pretty simple.
Relevant Utilities
In this problem, we're parsing integers, but they can be positive or negative. So here's a utility parser that can handle that:
parseSignedInteger :: (Monad m) => ParsecT Void Text m Int
parseSignedInteger = parsePositiveNumber <|> parseNegativeNumber
parseNegativeNumber :: (Monad m) => ParsecT Void Text m Int
parseNegativeNumber = do
char '-'
((-1) *) <$> parsePositiveNumber
parsePositiveNumber :: (Monad m) => ParsecT Void Text m Int
parsePositiveNumber = read <$> some digitCharParsing the Input
Now, let's parse our problem input. Here's a small sample:
noop
addx 3
addx -5We have "no-op" commands and "add" commands with a number. We start with an Instruction type to represent these:
data Instruction =
Noop |
Addx Int
deriving (Show)
type InputType = [LineType]
type LineType = InstructionAnd parsing each line is a simple alternative.
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = (string "noop" >> return Noop) <|> do
string "addx "
Addx <$> parseSignedInteger
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eolGetting the Solution
This will be another folding solution, where we process a single instruction at a time. So we need a stateful type to capture all the information we need about the problem. We'll track the following fields:
- The cycle number
- The register value
- The accumulated signal strength - this is our answer for part 1.
- The accumulated render string - this will give us the answer for part 2.
Here's what the type looks like, along with its initial value.
initialMachineState :: MachineState
initialMachineState = MachineState 1 1 0 ""
data MachineState = MachineState
{ cycleNum :: Int
, registerValue :: Int
, accumSignalStrength :: Int
, renderedString :: String
}So the question becomes…how do we process a single instruction?
processInstruction :: (MonadLogger m) => MachineState -> Instruction -> m MachineStateThis is a little tricky because the no-op instruction only takes one cycle, while the add instruction takes two cycles. And it's only at the end of those two cycles that the register value is updated. So the key to this is another helper that bumps the cycle values without worrying about adding.
bumpCycle :: (MonadLogger m) => MachineState -> m MachineStateHere's how we apply this function within processInstruction:
processInstruction :: (MonadLogger m) => MachineState -> Instruction -> m MachineState
processInstruction ms Noop = bumpCycle ms
processInstruction ms0 (Addx i) = do
ms1 <- bumpCycle ms0
ms2 <- bumpCycle ms1
return $ ms2 { registerValue = registerValue ms0 + i}A no-op does nothing except bump the cycle. For adding, we bump twice and then update the register value using the instruction.
So what actually happens when we bump the cycle? Well most obviously, we increment the cycle number and keep the register value the same.
bumpCycle :: (MonadLogger m) => MachineState -> m MachineState
bumpCycle (MachineState cNum regVal accumSignal render) = do
...
return $ MachineState (cNum + 1) regVal (...) (...)So what happens with the other values? First let's think about the signal strength. At certain cycles (20, 60, 100, 140, 180, 220), we multiply the register value by the cycle number, and add this to the previous signal strength value.
bumpCycle :: (MonadLogger m) => MachineState -> m MachineState
bumpCycle (MachineState cNum regVal accumSignal render) = do
let maybeAccum = if HS.member cNum signalCycles
then regVal * cNum
else 0
...
return $ MachineState (cNum + 1) regVal (accumSignal + maybeAccum) (...)
signalCycles :: HS.HashSet Int
signalCycles = HS.fromList [20, 60, 100, 140, 180, 220]And now for the second part, we need to render the right character. First, we need the "column" for the cycle number. We subtract 1 and mod by 40. Then we want to check if that value is equal to the register value (+/- 1). If it is, we'll use a "light" bit #. Otherwise, it's a "dark" bit .. And this completes our function!
bumpCycle :: (MonadLogger m) => MachineState -> m MachineState
bumpCycle (MachineState cNum regVal accumSignal render) = do
let maybeAccum = if HS.member cNum signalCycles
then regVal * cNum
else 0
let newChar = if ((cNum - 1) `mod` 40) `elem` [regVal - 1, regVal, regVal + 1] then '#' else '.'
return $ MachineState (cNum + 1) regVal (accumSignal + maybeAccum) (newChar : render)Answering the Question
For the "easy" part, we fold the instructions and collect the accumulated signal strength:
type EasySolutionType = Int
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = accumSignalStrength <$> foldM processInstruction initialMachineState inputsFor the "hard" part, we instead reverse the rendered string.
type HardSolutionType = String
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = reverse . renderedString <$> foldM processInstruction initialMachineState inputsAnd now we're basically done! The only wrinkle is that you'll want to print the final string properly in order to see what the letters are! You'll want to use chunksOf 40.
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe String)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
result <- processInputHard input
mapM_ (logErrorN . pack) (chunksOf 40 result)
return $ Just resultAnd that's all!
Video
Day 9 - Knot Tracing
Subscribe to Monday Morning Haskell!
Problem Overview
For this problem, we're tracking the movement of a rope with knots in it as it moves through a 2D grid. Our input is a series of "moves" (up/right/down/left) with numbers attached for the times we move in that direction. The move tells us how the "head" of the rope moves. The "tail" (or tails) follow the head in a particular fashion.
In the first part, we only have two knots. We move the head knot, and then one tail knot follows. In the second part, we have 10 total knots. Each tail knot follows the knot ahead of it. In each case, our final answer is the number of unique coordinates traveled by the final knot in the rope.
Parsing the Input
This is mostly a line-by-line parsing problem, but we'll have a slight change.
All we're parsing in the input is the list of moves, each with a direction character and a number of moves.
R 4
U 4
L 3
D 1
R 4
D 1
L 5
R 2We'll start with a type to represent the moves:
data Move = UpMove | RightMove | DownMove | LeftMove
deriving (Show)Parsing one line into a list of moves is pretty easy. We'll replicate the move using the number.
type LineType = [Move]
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
move <- up <|> right <|> down <|> left
char ' '
i <- parsePositiveNumber
return $ replicate i move
where
up = char 'U' >> return UpMove
right = char 'R' >> return RightMove
down = char 'D' >> return DownMove
left = char 'L' >> return LeftMoveAnd to combine this, we'll just concat the lines together.
type InputType = [Move]
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = concat <$> sepEndBy1 parseLine eolGetting the Solution
There are basically three parts to this solution.
- One function to move the head knot based on the move
- One function to determine how a tail knot follows a head
- Write a recursive loop function to move a whole list of knots to follow each other, and use this to fold over the moves.
The first function is an easy case statement.
nextHead :: Coord2 -> Move -> Coord2
nextHead (headX, headY) move = case move of
UpMove -> (headX + 1, headY)
RightMove -> (headX, headY + 1)
DownMove -> (headX - 1, headY)
LeftMove -> (headX, headY - 1)Now for the knot-following logic. This has many cases. Note: the last 4 deal with the Cartesian Quadrants.
- The tail is within 1 space (including diagonally) of the head. In this case the knot doesn't move.
- Head and tail are in the same row. Tail moves one space horizontally towards the head.
- Head and tail are in the same column. Tail moves one space vertically towards the head.
- The head is in Quadrant 1 compared to the tail. Move tail up and right.
- The head is in Quadrant 2. Move tail up and left..
- The head is in Quadrant 3. Move tail down and left.
- Otherwise (should be Quadrant 4), move tail down and right.
We can start with the "don't move" logic.
nextTail :: Coord2 -> Coord2 -> Coord2
nextTail head@(headX, headY) tail@(tailX, tailY)
| dontMove = tail
...
where
dontMove = abs (headX - tailX) <= 1 && abs (headY - tailY) <= 1
...Next, consider the "same row" or "same column" logic. We need if-statements within these for the distinction of left/right or up/down.
nextTail :: Coord2 -> Coord2 -> Coord2
nextTail head@(headX, headY) tail@(tailX, tailY)
| dontMove = tail
| headX == tailX = (tailX, if tailY < headY then tailY + 1 else tailY - 1)
| headY == tailY = (if tailX > headX then tailX - 1 else tailX + 1, tailY)
...
where
dontMove = abs (headX - tailX) <= 1 && abs (headY - tailY) <= 1
...And finally, we handle the quadrants.
nextTail :: Coord2 -> Coord2 -> Coord2
nextTail head@(headX, headY) tail@(tailX, tailY)
| dontMove = tail
| headX == tailX = (tailX, if tailY < headY then tailY + 1 else tailY - 1)
| headY == tailY = (if tailX > headX then tailX - 1 else tailX + 1, tailY)
| q1 = (tailX + 1, tailY + 1)
| q2 = (tailX + 1, tailY - 1)
| q3 = (tailX - 1, tailY - 1)
| otherwise = (tailX - 1, tailY + 1)
where
dontMove = abs (headX - tailX) <= 1 && abs (headY - tailY) <= 1
q1 = headX > tailX && headY > tailY
q2 = headX > tailX && headY < tailY
q3 = headX < tailX && headY < tailYNow for the final step. We'll fold through the moves, and keep an updated set of the coordinates where the tail has been, as well as the list of the knot locations. We'll parameterize by the number of knots.
type FoldType = (S.Set Coord2, [Coord2])
initialFoldV :: Int -> FoldType
initialFoldV n = (S.empty, replicate n (0, 0))Now for the folding function itself. First let's handle an invalid case of empty knots.
foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = if null knots then logErrorN "Invalid case, empty knots list!" >> return (prevSet, knots)
else do
...Then we'll have a recursive helper within this function that will gradually accumulate the new knots from the old locations. So the first argument is the accumulator of new locations, and the second argument is the remaining knots to shift. So let's write the base case first.
foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = if null knots then logErrorN "Invalid case, empty knots list!" >> return (prevSet, knots)
else do
...
where
hardFoldTail :: (MonadLogger m) => [Coord2] -> [Coord2] -> m [Coord2]
hardFoldTail [] _ = logErrorN "Invalid case!" >> return []
hardFoldTail done [] = return done
...In the first case, we never expect the accumulated list to be empty, since we'll give it one to start. For the second case, we have no more remaining knots, so we return our list.
In the recursive case, we'll use our nextTail function based on the most recent knot in the first list. We'll add this new location to the front of the list and then recurse on the rest.
foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = ...
where
hardFoldTail :: (MonadLogger m) => [Coord2] -> [Coord2] -> m [Coord2]
hardFoldTail [] _ = logErrorN "Invalid case!" >> return []
hardFoldTail done [] = return done
hardFoldTail done@(head : _) (next : rest) = hardFoldTail (nextTail head next : done) restFinally, we launch into this recursive call by first getting the nextHead of the top of the input list. Then we'll add the final knot's location to our accumulated set. Because we accumulated in reverse, this is currently on top of our resulting list. But then we'll reverse it when we return.
foldMove :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldMove (prevSet, knots) move = if null knots then logErrorN "Invalid case, empty knots list!" >> return (prevSet, knots)
else do
newLocations <- hardFoldTail [nextHead (head knots) move] (tail knots)
return (S.insert (head newLocations) prevSet, reverse newLocations)
where
hardFoldTail :: (MonadLogger m) => [Coord2] -> [Coord2] -> m [Coord2]
hardFoldTail [] _ = logErrorN "Invalid case!" >> return []
hardFoldTail done [] = return done
hardFoldTail done@(head : _) (next : rest) = hardFoldTail (nextTail head next : done) restAnswering the Question
Pulling the rest of this together is easy! We just use different parameters for the initial fold value in the easy and hard solution. (Admittedly, I did the first part a slightly different way before I knew what the second part was and refactored after).
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = do
(finalSet, _) <- foldM foldMove (initialFoldV 2) inputs
return $ S.size finalSet
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
(finalSet, _) <- foldM foldMove (initialFoldV 10) inputs
return $ S.size finalSet
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
logErrorN (pack . show $ input)
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputAnd this will give us our answer!
Video
Day 8 - Scenic Tree Visibility
Subscribe to Monday Morning Haskell!
Problem Overview
Today is our first 2D grid problem of the year. We're looking at a forest, and each number in the grid is the height of a particular tree. We want to answer two different questions about the grid. First, how many trees are "visible" from the outside of the grid? We'll imagine we walk around the grid from all four sides and look at each row and column until we hit a tree that is too tall to see any other trees behind.
For the second part, we'll consider each individual location inside the grid and determine how many trees are visible from that location.
Solution Approach and Insights
There's nothing too clever about my solution. Our scale is still small enough that we can more or less do brute force explorations as long as we're using an array.
Parsing the Input
So today's input is a 2D array of single-digit integers.
30373
25512
65332
33549
35390From last year, I had a utility for this exact case: parse2DDigitArray.
type Coord2 = (Int, Int)
type Grid2 a = Array Coord2 a
-- Only single digit numbers
parse2DDigitArray :: (Monad m) => ParsecT Void Text m (Grid2 Int)
parse2DDigitArray = digitsToArray <$> sepEndBy1 parseDigitLine eol
digitsToArray :: [[Int]] -> Grid2 Int
digitsToArray inputs = A.listArray ((0, 0), (length inputs - 1, length (head inputs) - 1)) (concat inputs)
parseDigitLine :: ParsecT Void Text m [Int]
parseDigitLine = fmap digitToInt <$> some digitCharSo we can pull it into our solution like so:
type InputType = Grid2 Int
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = parse2DDigitArrayGetting the Solution
For part 1, we need to consider each column from two directions and each row from two directions, and count the number of visible trees going down the line. Let's start with a function to do this in the vertical direction.
Instead of returning a raw count, we'll write this function to be used with a fold. It will take a Set of visible coordinates and return a modified set. This will prevent us from counting the same location twice from different directions. It will have two preliminary arguments - the grid and the list of row indices.
countVisibleVertical :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleVertical treeGrid rows prev col = ...Within this function, we'll fold through the row indices. However, in addition to using the Set within our folding type, we'll also keep track of the highest tree we've seen so far. If the next tree height is larger than the highest tree we've seen so far, we insert this new item into the visited set and update the height. Otherwise, neither changes.
countVisibleVertical :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleVertical treeGrid rows prev col = ...
where
assessRow :: (S.Set Coord2, Int) -> Int -> (S.Set Coord2, Int)
assessRow (prevSet, highestSeen) row =
let nextHeight = treeGrid A.! (row, col)
in if nextHeight > highestSeen then (S.insert (row, col) prevSet, nextHeight) else (prevSet, highestSeen)And now we complete the function by performing the fold (we start with our initial set and a minimum height of -1) and then only return the set.
countVisibleVertical :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleVertical treeGrid rows prev col = return $ fst $ foldl assessRow (prev, -1) rows
where
assessRow :: (S.Set Coord2, Int) -> Int -> (S.Set Coord2, Int)
assessRow (prevSet, highestSeen) row =
let nextHeight = treeGrid A.! (row, col)
in if nextHeight > highestSeen then (S.insert (row, col) prevSet, nextHeight) else (prevSet, highestSeen)We can do the same thing in the horizontal direction. This function looks very similar, just reversing rows and columns.
countVisibleHorizontal :: (MonadLogger m) => Grid2 Int -> [Int] -> S.Set Coord2 -> Int -> m (S.Set Coord2)
countVisibleHorizontal treeGrid columns prev row = return $ fst $ foldl assessColumn (prev, -1) columns
where
assessColumn :: (S.Set Coord2, Int) -> Int -> (S.Set Coord2, Int)
assessColumn (prevSet, highestSeen) col =
let nextHeight = treeGrid A.! (row, col)
in if nextHeight > highestSeen then (S.insert (row, col) prevSet, nextHeight) else (prevSet, highestSeen)Now we just have to run these functions in turn. Twice with horizontal, twice with vertical, and passing the resulting set each time.
type EasySolutionType = Int
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy treeGrid = do
let rows = [0..(fst . snd . A.bounds $ treeGrid)]
let cols = [0..(snd . snd . A.bounds $ treeGrid)]
s1 <- foldM (countVisibleHorizontal treeGrid cols) S.empty rows
s2 <- foldM (countVisibleHorizontal treeGrid (reverse cols)) s1 rows
s3 <- foldM (countVisibleVertical treeGrid rows) s2 cols
S.size <$> foldM (countVisibleVertical treeGrid (reverse rows)) s3 colsPart 2
In part 2, we just have to loop through each possible index in our grid. Then we'll apply a function to assess the scenic score at that location. We just have to look in each direction.
assessScenicScore :: (MonadLogger m) => Grid2 Int -> Coord2 -> m HardSolutionType
assessScenicScore treeGrid (row, col) = return $ lookUp * lookLeft * lookDown * lookRight
heightHere = treeGrid A.! (row, col)
(maxRow, maxCol) = snd (A.bounds treeGrid)
lookUp = ...
lookLeft = ...
lookDown = ...
lookRight = ...Within each case, we have to have a special case of 0 when we're at the edge. Then we'll use takeWhile to find the number of indices that are smaller than our present height. After that, there's one more edge case if we count all the trees in that direction. Here's the "up" case:
assessScenicScore :: (MonadLogger m) => Grid2 Int -> Coord2 -> m HardSolutionType
assessScenicScore treeGrid (row, col) = return $ lookUp * lookLeft * lookDown * lookRight
heightHere = treeGrid A.! (row, col)
(maxRow, maxCol) = snd (A.bounds treeGrid)
lookUp = if row == 0 then 0
else
let smallerTrees = length $ takeWhile (\r -> treeGrid A.! (r, col) < heightHere) [(row - 1),(row - 2)..0]
in if smallerTrees == row then smallerTrees else smallerTrees + 1
lookLeft = ...
lookDown = ...
lookRight = ...And here's the full function:
type HardSolutionType = EasySolutionType
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard treeGrid = maximum <$> mapM (assessScenicScore treeGrid) (A.indices treeGrid)
assessScenicScore :: (MonadLogger m) => Grid2 Int -> Coord2 -> m HardSolutionType
assessScenicScore treeGrid (row, col) = return $ lookUp * lookLeft * lookDown * lookRight
where
heightHere = treeGrid A.! (row, col)
(maxRow, maxCol) = snd (A.bounds treeGrid)
lookUp = if row == 0 then 0
else
let smallerTrees = length $ takeWhile (\r -> treeGrid A.! (r, col) < heightHere) [(row - 1),(row - 2)..0]
in if smallerTrees == row then smallerTrees else smallerTrees + 1
lookLeft = if col == 0 then 0
else
let smallerTrees = length $ takeWhile (\c -> treeGrid A.! (row, c) < heightHere) [(col - 1),(col-2)..0]
in if smallerTrees == col then smallerTrees else smallerTrees + 1
lookDown = if row == maxRow then 0
else
let smallerTrees = length $ takeWhile (\r -> treeGrid A.! (r, col) < heightHere) [(row + 1)..maxRow]
in if smallerTrees + row == maxRow then smallerTrees else smallerTrees + 1
lookRight = if col == maxCol then 0
else
let smallerTrees = length $ takeWhile (\c -> treeGrid A.! (row, c) < heightHere) [(col + 1)..maxCol]
in if smallerTrees + col == maxCol then smallerTrees else smallerTrees + 1And doing the full processing is easy! Just map this function over all the indices:
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard treeGrid = maximum <$> mapM (assessScenicScore treeGrid) (A.indices treeGrid)Answering the Question
There's no additional processing for this problem. We just have the two steps.
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputSo this gives us our complete solution!
Video
Day 7 - File System Shaving
Subscribe to Monday Morning Haskell!
Problem Overview
Our input is a series of file system commands that list the directories and files (with their sizes) on a computer. In the first part, we'll find every directory whose size is less than 100000 bytes and add their sizes. In the second part, we'll determine the smallest directory we need to delete to free up enough space to perform an update.
Solution Approach and Insights
As we loop through the different commands and outputs that are run, we want to track the current directory as a list of sub-directories. Then we can add each file's size to all directories along that tree. But we need to make sure our representation for each directory incorporates its full path as a list, and not just the top level.
Relevant Utilities
Once again, we're using OccMap, but this time it will be the OccMapBig alias that uses an unbounded Integer instead of Word, just because the sum of file sizes might get a bit large.
Parsing the Input
Here's a sample input:
$ cd /
$ ls
dir a
14848514 b.txt
8504156 c.dat
dir d
$ cd a
$ ls
dir e
29116 f
2557 g
62596 h.lst
$ cd e
$ ls
584 i
$ cd ..
$ cd ..
$ cd d
$ ls
4060174 j
8033020 d.log
5626152 d.ext
7214296 kIt contains four kinds of lines:
- Change Directory commands (
cd) - List directory commands (
ls) - A directory listed by
ls(stars withdir) - A file listed by
ls(starts with a file size)
We treat each line as its own kind of "command" (even the outputs, which aren't technically commands). We'll make this data type to represent the idea:
type InputType = [LineType]
type LineType = Command
data Command =
ChangeDirectoryCommand String |
ListDirectoryCommand |
ListedDirectory String |
ListedFile Integer String
deriving (Show)The parsing code isn't too hard. The main thing is we want an alternative parser for each command type.
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = parseCD <|> parseLS <|> parseDir <|> parseFile
where
parseCD = ...
parseLS = ...
parseDir = ...
parseFile = ...Within these parsers, we'll also have some other alternatives, but nothing it too tricky. For instance, the cd parser has to account for cd .., cd / and then using a normal directory name.
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = parseCD <|> parseLS <|> parseDir <|> parseFile
where
parseCD = do
string "$ cd "
dir <- (unpack <$> string "..") <|> (unpack <$> string "/") <|> some letterChar
return $ ChangeDirectoryCommand dir
parseLS = ...
parseDir = ...
parseFile = ...Here's the complete parser, which we apply line-by-line.
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eol
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = parseCD <|> parseLS <|> parseDir <|> parseFile
where
parseCD = do
string "$ cd "
dir <- (unpack <$> string "..") <|> (unpack <$> string "/") <|> some letterChar
return $ ChangeDirectoryCommand dir
parseLS = string "$ ls" >> return ListDirectoryCommand
parseDir = do
string "dir "
dir <- some letterChar
return $ ListedDirectory dir
parseFile = do
fileSize <- fromIntegral <$> parsePositiveNumber
char ' '
fileName <- some (letterChar <|> char '.')
return $ ListedFile fileSize fileNameGetting the Solution
As we loop through different commands, we need to track the current directory we're in, as well as the sizes for each directory based on the files we've seen so far. Note we have to use the full path as the key. There are some duplicately named sub-directories, so we can't just use the relative name in our map!
data FSState = FSState
{ currentDirectory :: [String]
, directoryMap :: OccMapBig [String]
} deriving (Show)So let's set up a fold to go through each line. Ultimately the directoryMap is the only item we need to solve the problem.
type EasySolutionType = OccMapBig [String]
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = directoryMap <$> solveFold inputs
solveFold :: (MonadLogger m) => [LineType] -> m FSState
solveFold = foldM foldLine initialFoldV
initialFoldV :: FSState
initialFoldV = FSState [] M.empty
foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine = ...Now we have to determine how each command modifies the state. However, only two commands actually change the state. Changing the directory will obviously modify our current directory, and reading a file with its size will modify our map. But reading the list command and reading a new directory name that is listed don't actually modify our state. So we can set up this template.
foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine prevState command = case command of
ChangeDirectoryCommand dir -> ...
ListedFile size _ -> ...
_ -> return prevStateChanging directory has three cases. If we change to "..", we remove a level from our hierarchy with tail. If we change to "/", we reset the hierarchy to just have this root element. Otherwise, we append the new directory to the front of the hierarchy.
foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine prevState command = case command of
ChangeDirectoryCommand dir -> if dir == ".."
then return $ prevState { currentDirectory = tail (currentDirectory prevState)}
else if dir == "/"
then return $ prevState { currentDirectory = ["/"]}
else return $ prevState { currentDirectory = dir : currentDirectory prevState}
ListedFile size _ -> ...
_ -> return prevStateWhen we list a file, we have to go through all the subdirectories and add its size to their stored value. But remember, each subdirectory contains the full list. So we need the tails function in order to properly enumerate these. Here's a quick example of tails:
tails [1, 2, 3] = [[1, 2, 3], [2, 3], [3], []]Then we need init on that result to exclude the empty list from tails. We fold through these options and use addKey with our occupancy map.
Here is the complete function:
foldLine :: (MonadLogger m) => FSState -> LineType -> m FSState
foldLine prevState command = case command of
ChangeDirectoryCommand dir -> if dir == ".."
then return $ prevState { currentDirectory = tail (currentDirectory prevState)}
else if dir == "/"
then return $ prevState { currentDirectory = ["/"]}
else return $ prevState { currentDirectory = dir : currentDirectory prevState}
ListedFile size _ -> do
let allDirs = currentDirectory prevState
let newDirMap = foldl (\mp d -> addKey mp d size) (directoryMap prevState) (init $ tails allDirs)
return $ prevState { directoryMap = newDirMap}
_ -> return prevStateNow we'll have the mapping from directory paths to sizes, so we can start answering the questions!
Answering the Question
For the first part, we filter the directory sizes by only looking for those under 100000 bytes. Then we take the sum of these.
findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe Integer)
findEasySolution dirMap = do
let largePairs = filter (<= 100000) (M.elems dirMap)
return $ Just $ sum largePairsFor the second part, we sort the directory sizes and find the first one that will give us the desired unused space.
findHardSolution :: (MonadLogger m) => HardSolutionType -> m (Maybe Integer)
findHardSolution dirMap = do
let allDirSizes = sort (M.elems dirMap)
let usedSpace = last allDirSizes
let currentUnusedSpace = 70000000 - usedSpace
return $ find (\i -> currentUnusedSpace + i >= 30000000) allDirSizesObserve how we use the last element for the total "used" size. The largest size in our map should always be the root element, which contains all files! We don't want to sum the values in this list since otherwise we'd be double-counting files!
Now we just combine our functions and get our answers!
solveEasy :: FilePath -> IO (Maybe Integer)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
result <- processInputEasy input
findEasySolution result
solveHard :: FilePath -> IO (Maybe Integer)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
result <- processInputEasy input
findHardSolution resultAnd we're done!
Video
Day 6 - Parsing Unique Characters
Subscribe to Monday Morning Haskell!
Problem Overview
With today's problem, we're looping through a string and searching for the first sequence of a certain length with unique characters. For part 1, we have to find the index where our 4 most recent characters are all unique. For part 2, this number gets bumped to 14.
Relevant Utilities
This will be the first time we use an Occurrence Map (OccMap) this year. A lot of problems rely on counting the occurrences of particular values. So I added a few wrappers and helpers to make this easy. So by using incKey, we can bump up the stored value up by 1.
type OccMap a = OccMapI a Word
type OccMapI a i = Map a i
emptyOcc :: OccMap a
emptyOcc = M.empty
incKey :: (Ord a, Integral i) => OccMapI a i -> a -> OccMapI a i
incKey prevMap key = addKey prevMap key 1
decKey :: (Ord a, Integral i) => OccMapI a i -> a -> OccMapI a i
decKey prevMap key = case M.lookup key prevMap of
Nothing -> prevMap
Just 0 -> M.delete key prevMap
Just 1 -> M.delete key prevMap
Just x -> M.insert key (x - 1) prevMap
addKey :: (Ord a, Integral i) => OccMapI a i -> a -> i -> OccMapI a i
addKey prevMap key count = case M.lookup key prevMap of
Nothing -> M.insert key count prevMap
Just x -> M.insert key (x + count) prevMapIn this solution, we'll also use decKey. Note that we delete the key if the count gets down to 0. This will be important in our problem!
Solution Approach and Insights
When I initially approached this problem, I made a custom data type and stored the different characters as individual elements. This worked fine for 3 characters, but it was cumbersome for 14. So I rewrote the solution more generically. We track the most recent characters we've seen in two different structures simultaneously.
First, we use a sequence to track the order we received them, so that with each iteration, we'll drop one character from the front and add a new one to the back.
We'll also use an occurrence map to track the counts for each character type in the last 4 (or 14). We'll increment a character's key when it is added, and decrement when it is removed from the front. If at any point we have 14 keys in our occurrence map, we're done!
Parsing the Input
Today we're only parsing a string:
mjqjpqmgbljsphdztnvjfqwrcgsmlbSo the parser is trivial:
type InputType = String
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = some letterCharGetting the Solution
To solve our problem, we're going to need one primary function to process the characters. We'll parameterize this by the number of characters we need for a unique code. If we don't have enough characters to reach the unique number, we'll log an error and return the max integer.
processChars :: (MonadLogger m) => Int -> [Char] -> m Int
processChars numCharsNeeded input = if length input < numCharsNeeded
then logErrorN "Not enough chars!" >> return maxBound
else ...Now we need to initialize our structures. We'll split the input string into its first part (up to the number of unique characters) and the rest. The first characters will go into a sequence as well as our occurrence map.
processChars :: (MonadLogger m) => Int -> [Char] -> m Int
processChars numCharsNeeded input = if length input < numCharsNeeded
then logErrorN "Not enough chars!" >> return maxBound
else do
let (firstChars, rest) = splitAt (numCharsNeeded - 1) input
seq = Seq.fromList firstChars
occ = foldl incKey emptyOcc firstChars
...Now we need our recursive helper. This function will also be parameterized by the number of characters needed. The "state" for the helper will have an Int for the current index we're at in the string. We'll also have the current queue of characters, as well as the occurrence map for the counts of each character.
Now for implementation, starting with the "base" case. This function should never reach the end of the input. If it does, we'll handle this error case in the same way as above.
processTail :: (MonadLogger m) => Int -> (Int, Seq.Seq Char, OccMap Char) -> [Char] -> m Int
processTail _ _ [] = logErrorN "No remaining chars!" >> return maxBound
processTail numCharsNeeded (count, seq, occ) (c : cs) = ...Now break off the first piece of the sequence using Seq.viewl so that we'll be able to modify the sequence later. We have another error case that should never be tripped.
processTail numCharsNeeded (count, seq, occ) (c : cs) = case Seq.viewl seq of
Seq.EmptyL -> logErrorN "Sequence is empty!" >> return maxBound
(first Seq.:< rest) -> do
...Here's where we do the calculation. First, increment the value for our new character c. At this point, we can check the size of our occurrence map. If it equals the number of characters we need, we're done! We can return the current count value.
Otherwise we'll recurse. We add the new character to the end of the queue and we decrement the occurrence map for the character we removed.
processTail :: (MonadLogger m) => Int -> (Int, Seq.Seq Char, OccMap Char) -> [Char] -> m Int
processTail _ _ [] = logErrorN "No remaining chars!" >> return maxBound
processTail numCharsNeeded (count, seq, occ) (c : cs) = case Seq.viewl seq of
Seq.EmptyL -> logErrorN "Sequence is empty!" >> return maxBound
(first Seq.:< rest) -> do
let occ' = incKey occ c
if M.size occ' == numCharsNeeded
then return count
else processTail numCharsNeeded (count + 1, rest Seq.|> c, decKey occ' first) csAnd now we just plug in the call to this helper into our original function!
processChars :: (MonadLogger m) => Int -> [Char] -> m Int
processChars numCharsNeeded input = if length input < numCharsNeeded
then logErrorN "Not enough chars!" >> return maxBound
else do
let (firstChars, rest) = splitAt (numCharsNeeded - 1) input
seq = Seq.fromList firstChars
occ = foldl incKey emptyOcc firstChars
processTail numCharsNeeded (numCharsNeeded, seq, occ) restAnswering the Question
Now answering the questions is quite easy. We parameterize the calls with the different length values.
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy = processChars 4
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard = processChars 14
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputAnd we're done!
Video
Day 5 - Crate Stacks
Today could be considered the first intermediate puzzle of the year so far. At the very least, the input parsing is quite a bit more complicated than previous days. The algorithm portion is still pretty easy once you wrap your head around it.
Subscribe to Monday Morning Haskell!
Problem Overview
In today's problem, we are tracking the movement of crates being shifted around by a crane. It's easiest to explain just by looking at the input:
[D]
[N] [C]
[Z] [M] [P]
1 2 3
move 1 from 2 to 1
move 3 from 1 to 3
move 2 from 2 to 1
move 1 from 1 to 2The first portion shows the initial state of the crates. Each crate has a lettered identifier, and they sit in stacks. Then below we see a series of commands telling us to move a certain number of crates from one stack to another.
In part 1 of the problem, the crane only moves one crate at a time. So the top crate from a stack gets moved, and then the next one is placed on top of it.
In part 2, the crane can carry many crates at once. So the crates appear in the destination stack in the same order, rather than the reverse order.
In both cases, our final output is a string formed from the top crate in each stack.
Solution Approach and Insights
After a trickier parsing phase to get our initial state, this is still essentially a folding problem, looping through the moves and modifying our stack each time. This will be our first problem this year with a post-processing step to get the string from the final crate stack.
Relevant Utilities
Once again, we'll use parsePositiveNumber from our utilities.
Parsing the Input
Let's recall the sample input:
[D]
[N] [C]
[Z] [M] [P]
1 2 3
move 1 from 2 to 1
move 3 from 1 to 3
move 2 from 2 to 1
move 1 from 1 to 2We have two phases: the initial stack of crates and then the list of moves. We can represent these phases with two type definitions:
type CrateStacks = HashMap Int [Char]
data Move = Move
{ numCrates :: Int
, sourceStack :: Int
, destStack :: Int
} deriving (Show)
type InputType = (CrateStacks, [Move])Let's write this code from the top-down. First, our primary function breaks the parsing into these two parts:
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = do
crateStack <- parseCrateStack
eol
moves <- sepEndBy1 parseMove eol
return (crateStack, moves)
parseCrateStack :: (MonadLogger m) => ParsecT Void Text m CrateStacks
parseMove :: (MonadLogger m) => ParsecT Void Text m MoveParsing the Crate Stack
Parsing the crate stack is a bit tricky because we don't know the number of columns before-hand. The small sample has 3, the larger sample has 9. Also, we have to factor in empty spaces on stacks. We'll make it so that we parse each crate as a Maybe value, so that we're always getting the same number of items for each line of input.
So at a high level, we have three steps:
- Parse the crate lines as a list of
Maybe Charvalues. - Parse the column numbers line and ignore it.
- Build our initial mapping of crate stacks based on the nested list of crate identifiers.
Continuing our top-down approach, we make the following definitions for this 3-step process:
parseCrateStack :: (MonadLogger m) => ParsecT Void Text m CrateStacks
parseCrateStack = do
crateLines <- sepEndBy1 parseCrateLine eol
parseCrateNumbers
lift $ buildCrateStack (reverse crateLines)
parseCrateLine :: (MonadLogger m) => ParsecT Void Text m [Maybe Char]
buildCrateStack :: (MonadLogger m) => [[Maybe Char]] -> m CrateStacksTo parse the crate lines, we first write a parser for the Maybe Char. Either we have the character within brackets or we have three blank spaces.
parseCrateChar :: (MonadLogger m) => ParsecT Void Text m (Maybe Char)
parseCrateChar = crate <|> noCrate
where
crate = do
char '['
c <- letterChar
char ']'
return $ Just c
noCrate = string " " >> return NothingNow we parse a full line with sepEndBy1, only using a blank space as our separator instead of eol like we often do with this helper.
parseCrateLine :: (MonadLogger m) => ParsecT Void Text m [Maybe Char]
parseCrateLine = sepEndBy1 parseCrateChar (char ' ')Next, we parse the column numbers line. We don't actually need the numbers, so this is easy:
parseCrateNumbers :: (MonadLogger m) => ParsecT Void Text m ()
parseCrateNumbers = void $ some (digitChar <|> char ' ') >> eolThen building our initial CrateStacks hash map is done with nested folds. The inner fold adds a single crate to a single stack. If it's Nothing, of course we return the original.
addCrate :: CrateStacks -> (Int, Maybe Char) -> CrateStacks
addCrate prev (_, Nothing) = prev
addCrate prev (i, Just c) =
let prevStackI = fromMaybe [] (HM.lookup i prev)
in HM.insert i (c : prevStackI) prevThen here's how we do the nested looping. Notice the enumeration with zip [1,2..] to assign indices to each crate value for the stack number.
buildCrateStack :: (MonadLogger m) => [[Maybe Char]] -> m CrateStacks
buildCrateStack crateLines = return $ foldl addCrateLine HM.empty crateLines
where
addCrateLine :: CrateStacks -> [Maybe Char] -> CrateStacks
addCrateLine prevStacks lineChars = foldl addCrate prevStacks (zip [1,2..] lineChars)And now we've filled in all the gaps for parsing the stack itself. But we still have to parse the numbers!
Parsing Moves
There's nothing too hard with parsing each Move line. Just a combination of strings and numbers:
parseMove :: (MonadLogger m) => ParsecT Void Text m Move
parseMove = do
string "move "
numCrates <- parsePositiveNumber
string " from "
sourceIndex <- parsePositiveNumber
string " to "
destIndex <- parsePositiveNumber
return $ Move numCrates sourceIndex destIndexGetting the Solution
We can still follow the general folding solution approach that worked for the first few problems. Only now instead of tracking an accumulated value, we're tracking the state of our CrateStacks.
type EasySolutionType = CrateStacks
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy (stacks, moves) = solveFold stacks moves
solveFold :: (MonadLogger m) => CrateStacks -> [Move] -> m EasySolutionType
solveFold = foldM foldLine
type FoldType = CrateStacks
foldLine :: (MonadLogger m) => FoldType -> Move -> m FoldTypeThe foldLine function will perform the move, shifting crates from one stack to another. To start this process, we need the current state of the "source" and "destination" stacks. If the source stack is empty, we'll log an error, but return the previous state.
foldLine :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldLine crateStacks (Move num src dst) = do
let sourceStack = fromMaybe [] (HM.lookup src crateStacks)
destStack = fromMaybe [] (HM.lookup dst crateStacks)
if null sourceStack
then logErrorN ("Tried to pull from empty stack: " <> (pack . show $ src)) >> return crateStacks
else ...Assuming we actually have crates to pull, all we have to do is perform nested updates to our hash map. We get the new value in the "source" stack by using drop num. Then to update the destination stack, we take num from the source, reverse them, and append to the front of the existing destination stack.
foldLine :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldLine crateStacks (Move num src dst) = do
let sourceStack = fromMaybe [] (HM.lookup src crateStacks)
destStack = fromMaybe [] (HM.lookup dst crateStacks)
if null sourceStack
then logErrorN ("Tried to pull from empty stack: " <> (pack . show $ src)) >> return crateStacks
else do
return $ HM.insert dst (reverse (take num sourceStack) ++ destStack) (HM.insert src (drop num sourceStack) crateStacks)Applying this function over all our moves will give us our final stack state!
Part 2
Part 2 is identical, except that we do not reverse the crates at the final step.
foldLineHard :: (MonadLogger m) => FoldType -> Move -> m FoldType
foldLineHard crateStacks (Move num s d) = do
let sourceStack = fromMaybe [] (HM.lookup s crateStacks)
destStack = fromMaybe [] (HM.lookup d crateStacks)
if null sourceStack
then logErrorN ("Tried to pull from empty stack: " <> (pack . show $ s)) >> return crateStacks
else do
{- Do not reverse the stack! -}
return $ HM.insert d (take num sourceStack ++ destStack) (HM.insert s (drop num sourceStack) crateStacks)Answering the Question
We have to do some post-processing once we've applied the moves. We need to find the top character in each stack. This isn't too bad. First we get the items out of our hash map and sort them by the index.
type EasySolutionType = CrateStacks
findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe String)
findEasySolution crateStacks = do
let sortedResults = sort (HM.toList crateStacks)
return $ Just $ map safeHead (snd <$> sortedResults)We want to get the top character, but it's good to define a "safe" function to return an empty character in case we end up with an empty list. Then we can just take the "head" from every stack!
findEasySolution :: (MonadLogger m) => EasySolutionType -> m (Maybe String)
findEasySolution crateStacks = do
let sortedResults = sort (HM.toList crateStacks)
return $ Just $ map safeHead (snd <$> sortedResults)
safeHead :: [Char] -> Char
safeHead [] = ' '
safeHead (c : _) = cAnd now to tie everything together, our top-level solve functions use 3-steps instead of 2 for the first time.
solveEasy :: FilePath -> IO (Maybe String)
solveEasy fp = runStdoutLoggingT $ do
-- 1. Parse Input
input <- parseFile parseInput fp
-- 2. Process input to get final stack state
result <- processInputEasy input
-- 3. Get "answer" from final stack state
findEasySolution result
solveHard :: FilePath -> IO (Maybe String)
solveHard fp = runStdoutLoggingT $ do
-- 1. Parse Input
input <- parseFile parseInput fp
-- 2. Process input to get final stack state
result <- processInputHard input
-- 3. Get "answer" from final stack state
findEasySolution resultJust note that we can use the same findEasySolution for part 2. And that's all the code we need! Definitely a heftier solution than days 1-4. So we'll see how the challenges keep developing!
Video
Day 4 - Overlapping Ranges
Subscribe to Monday Morning Haskell!
Problem Overview
For today's problem, our elf friends are dividing into pairs and cleaning sections of the campsite. Each individual elf is then assigned a range of sections of the campsite to clean. Our goal is to figure out redundant work.
In part 1, we want to calculate the number of pairs where one range is fully contained within the other. In part 2, we'll figure out how many pairs of ranges have any overlap.
Relevant Utilities
We'll be parsing a lot of numbers for this puzzle, so we'll need a handy function for that. Here's parsePositiveNumber:
parsePositiveNumber :: (Monad m) => ParsecT Void Text m Int
parsePositiveNumber = read <$> some digitCharParsing the Input
Now let's look at the sample input:
2-4,6-8
2-3,4-5
5-7,7-9
2-8,3-7
6-6,4-6
2-6,4-8Again, we parse this line-by-line. And each line just consists of a few numbers interspersed with other characters.
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput =
sepEndBy1 parseLine eol
type InputType = [LineType]
type LineType = ((Int, Int), (Int, Int))
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
a1 <- parsePositiveNumber
char '-'
a2 <- parsePositiveNumber
char ','
b1 <- parsePositiveNumber
char '-'
b2 <- parsePositiveNumber
return ((a1, a2), (b1, b2))Getting the Solution
In part 1, we count the number of lines where one range fully contains another. In the example above, these two lines satisfy this condition:
2-8,3-7
6-6,4-6So we start with a function to evaluate this:
rangeFullyContained :: ((Int, Int), (Int, Int)) -> Bool
rangeFullyContained ((a1, a2), (b1, b2)) =
a1 <= b1 && a2 >= b2 ||
b1 <= a1 && a2 <= b2And now we use the same folding pattern that's served us for the last couple days! If the condition is satisfied, we add one to the previous score, otherwise no change.
processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy = foldM foldLine initialFoldV
type FoldType = Int
initialFoldV :: FoldType
initialFoldV = 0
foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prev range = if rangeFullyContained range
then return $ prev + 1
else return prevPart 2
Part 2 is virtually identical, only with a different condition. In the above example, here are the examples with any overlap in the ranges:
5-7,7-9
2-8,3-7
6-6,4-6
2-6,4-8So here's our new condition:
rangePartiallyContained :: ((Int, Int), (Int, Int)) -> Bool
rangePartiallyContained ((a1, a2), (b1, b2)) = if a1 <= b1
then b1 <= a2
else a1 <= b2And the application of this condition is virtually identical to part 1.
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard = foldM foldPart2 0
findHardSolution :: (MonadLogger m) => HardSolutionType -> m (Maybe Int)
findHardSolution _ = return Nothing
foldPart2 :: (MonadLogger m) => Int -> LineType -> m Int
foldPart2 prev range = if rangePartiallyContained range
then return $ prev + 1
else return prevAnswering the Question
Nothing has changed from our previous examples in terms of post-processing.
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputAnd this means we're done!
Video
Day 3 - Rucksacks and Badges
Subscribe to Monday Morning Haskell!
Problem Overview
Today's problem is essentially a deduplication problem. Each input line is a series of letters. For part 1, we're deduplicating within lines, finding one character that is in both sides of the word. For part 2, we're dividing the inputs into groups of 3, and then finding the only letter common to all three strings.
To "answer the question", we have to provide a "score" for each of the unique characters. The lowercase letters get the scores 1-26. Uppercase letters get the scores 27-52. Then we'll take the sum of the scores from each line or group.
Solution Approach and Insights
This is quite straightforward if you know your list library functions! We'll use filter, elem, chunksOf and nub!
Parsing the Input
Here's a sample input
vJrwpWtwJgWrhcsFMMfFFhFp
jqHRNqRjqzjGDLGLrsFMfFZSrLrFZsSL
PmmdzqPrVvPwwTWBwg
wMqvLMZHhHMvwLHjbvcjnnSBnvTQFn
ttgJtRGJQctTZtZT
CrZsJsPPZsGzwwsLwLmpwMDw
```:
Nothing tricky about the parsing code, since it's all just strings with only letters!
```haskell
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eol
type InputType = [LineType]
type LineType = String
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = some letterCharGetting the Solution
We'll start with our scoring function. Of course, we'll use the ord function to turn each character into its ASCII number. By then we have to subtract the right amount so that lowercase 'a' (ASCII 97) gets a score of 1 and uppercase 'A' (ASCII 65) gets the score of 27:
scoreChar :: Char -> Int
scoreChar c = if isUpper c
then ord c - 38
else ord c - 96The rest of the solution involves the same folding pattern from Day 2. As a reminder, here's the setup code (I'll omit this in future examples):
solveFold :: (MonadLogger m) => [LineType] -> m EasySolutionType
solveFold = foldM foldLine initialFoldV
type FoldType = Int
initialFoldV :: FoldType
initialFoldV = 0
foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine = ...So the only challenge is filling out the folding function. First, we divide our word into the first half and the second half.
foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prevScore inputLine = ...
where
compartmentSize = length inputLine `quot` 2
(firstHalf, secondHalf) = splitAt compartmentSize inputLineThen we find the only character in both halves by filtering the first half based on being an elem of the second half. We also use nub to get rid of duplicates. We break this up with a case statement. If there's only one (as we expect), then we'll take its score and add it to the previous score. Otherwise we'll log an error message and return the previous score.
foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prevScore inputLine = do
case charsInBoth of
[c] -> return (prevScore + scoreChar c)
cs -> logErrorN ("Invalid chars in both sides! " <> (pack . show $ cs)) >> return prevScore
where
compartmentSize = length inputLine `quot` 2
(firstHalf, secondHalf) = splitAt compartmentSize inputLine
charsInBoth = nub $ filter (`elem` secondHalf) firstHalfAnd that's all for part 1!
Part 2
For part 2, we want to divide the input lines into groups of 3, and then find the common letter among them. Once again, we use a fold that starts with chunksOf to divide our input into groups of 3.
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard allLines = foldM foldHard 0 (chunksOf 3 allLines)
foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard = ...With this function, we first make sure we have exactly 3 strings.
foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard prevScore [s1, s2, s3] = ...
foldHard prevScore inputs = logErrorN ("Invalid inputs (should be size 3) " <> (pack . show $ inputs)) >> return prevScoreNow for the primary case, we do the same thing as before, only we filter s1 based on s2. Then we filter that result with s3 and do the same nub trick.
foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard prevScore [s1, s2, s3] = ...
where
s1AndS2 = filter (`elem` s2) s1
all3 = nub $ filter (`elem` s3) s1AndS2And we conclude with the same process as before. Log an error if we don't get the right outputs, otherwise add the score for the character.
foldHard :: (MonadLogger m) => Int -> [String] -> m Int
foldHard prevScore [s1, s2, s3] = do
case all3 of
[c] -> logErrorN ("Found " <> (pack [c]) <> " with score " <> (pack . show $ scoreChar c)) >> return (prevScore + scoreChar c)
cs -> logErrorN ("Invalid chars in all 3 ! " <> (pack . show $ cs)) >> return prevScore
where
s1AndS2 = filter (`elem` s2) s1
all3 = nub $ filter (`elem` s3) s1AndS2Answering the Question
As with the past couple days, we don't have any more work to do after processing the input:
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputAnd this gives us our answer!
Video
Day 2 - Rock, Paper, Scissors
Subscribe to Monday Morning Haskell!
Problem Overview
In today's problem, we're playing Rock-Paper-Scissors (RPS). Given a series of rounds of RPS play, we're supposed to evaluate the total "score" we get depending on what we've played. Inputs are line-by-line with two characters on each line:
A Y
B X
C ZThe first character always tells us what the opponent plays in that match - A = Rock, B = Paper, C = Scissors.
In the first part of the problem, the second character simply tells us what figure we should play (X = Rock, Y = Paper, Z = Scissors). In the second part of the problem, this character actually tells us the result we are trying to achieve - X = Loss, Y = Draw, Z = Win.
In both cases, our final solution is to calculate our total score over all the rounds, tabulated as follows:
- 6 points are given for a win, 3 for a draw, and 0 for a loss.
- Then we get a certain number of points for the figure we played - 1 for Rock, 2 for Paper, and 3 for Scissors.
So for part 1, the simple 3-line inputs gives the following results:
Round 1: Play paper (2 points) against rock. Win (6 points)
Round 2: Play rock (1 point) against paper. Lose (0 points)
Round 3: Play scissors (3 points) against scissors. Draw (3 points)Adding up all the points gives a total of 15.
For part 2, we get the following sequence by trying to match the results:
Round 1: Draw (3 points) against rock by playing rock (1 point)
Round 2: Lose (0 points) against paper by playing rock (1 point)
Round 3: Win (6 points) against scissors by playing rock (1 point)This gives a total of 12 points.
Solution Approach and Insights
This problem follows the simple and common "fold line-by-line" solution approach. I have some pre-planned boilerplate in my solution template for this! The folding action is not hard here - we just have to evaluate the result of the match and score it appropriately.
Parsing the Input
So remember, our sample input looks like this:
A Y
B X
C ZI started with an RPS type for the three possible figures we can playing:
data RPS = Rock | Paper | Scissors
deriving (Show, Eq)So we parse one of the figures using alternatives:
parseRPS :: ParsecT Void Text m RPS
parseRPS = parseRock <|> parsePaper <|> parseScissors
where
parseRock = (char 'A' <|> char 'X') >> return Rock
parsePaper = (char 'B' <|> char 'Y') >> return Paper
parseScissors = (char 'C' <|> char 'Z') >> return ScissorsSo we can parse a single line by taking two of these figures with a space between. In my template, I have a generic LineType alias to use both while parsing and folding over lines. In our case, each line is two of these RPS values.
type LineType = (RPS, RPS)
parseLine :: (MonadLogger m) => ParsecT Void Text m LineType
parseLine = do
first <- parseRPS
char ' '
second <- parseRPS
return (first, second)Then our final input uses the very common sepEndBy1 ... eol pattern. We use another alias for InputType here.
type InputType = [LineType]
parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parseLine eolAs a final wrinkle, we'll make a separate type for part 2, because the letters represent something semantically different. We won't change the parser. We'll just write a translation function to use later.
data ExpectedResult = Loss | Draw | Win
deriving (Show, Eq)
rpsToResult :: RPS -> ExpectedResult
rpsToResult Rock = Loss
rpsToResult Paper = Draw
rpsToResult Scissors = Win
translate :: (RPS, RPS) -> (RPS, ExpectedResult)
translate (first, second) = (first, rpsToResult second)Getting the Easy Solution
As I mentioned above, this problem fits a common pattern: fold our inputs line-by-line and accumulate a solution. I'll use some more generic types and values to outline this approach.
solveFold :: (MonadLogger m) => [LineType] -> m EasySolutionType
solveFold = foldM foldLine initialFoldV
type FoldType = Int
initialFoldV :: FoldType
initialFoldV = 0
foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine = ...We're tracking a score, so the FoldType that we're modifying with each step is just an Int, and we give the initial value of 0. Solving the problem is as simple as applying foldM with a proper folding function and the initial value. The only challenge is filling in foldLine. For this, we need two scoring functions, one for the figure we choose (scoreRps) and another for the outcome of the match, which just requires looking at each case:
scoreRps :: RPS -> Int
scoreRps Rock = 1
scoreRps Paper = 2
scoreRps Scissors = 3
evalMatch :: (RPS, RPS) -> Int
evalMatch (Rock, Rock) = 3
evalMatch (Rock, Paper) = 6
evalMatch (Rock, Scissors) = 0
evalMatch (Paper, Rock) = 0
evalMatch (Paper, Paper) = 3
evalMatch (Paper, Scissors) = 6
evalMatch (Scissors, Rock) = 6
evalMatch (Scissors, Paper) = 0
evalMatch (Scissors, Scissors) = 3And our fold simply applies both these to the input and adds to the previous result!
foldLine :: (MonadLogger m) => FoldType -> LineType -> m FoldType
foldLine prevScore (first, second) = return $ prevScore + (evalMatch (first, second) + scoreRps second)Getting the "Hard" Solution
For part 2, all we really need is to translate each input pair so it has an ExpectedResult, and then use a different evaluation function. Here's how we evaluate each pair:
evalMatchHard :: (RPS, ExpectedResult) -> Int
evalMatchHard (Rock, Win) = 8 -- Play Paper (2 + 6)
evalMatchHard (Rock, Draw) = 4 -- Play Rock (1 + 3)
evalMatchHard (Rock, Loss) = 3 -- Play Scissors (3 + 0)
evalMatchHard (Paper, Win) = 9 -- Play Scissors (3 + 6)
evalMatchHard (Paper, Draw) = 5 -- Play Paper (2 + 3)
evalMatchHard (Paper, Loss) = 1 -- Play Rock (1 + 0)
evalMatchHard (Scissors, Win) = 7 -- Play Rock (1 + 6)
evalMatchHard (Scissors, Draw) = 6 -- Play Scissors (3 + 3)
evalMatchHard (Scissors, Loss) = 2 -- Play Paper (2 + 0)And we fold over the inputs like so:
type HardSolutionType = EasySolutionType -- < Int
processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = foldM foldExpResult initialFoldV (map translate inputs)
foldExpResult :: (MonadLogger m) => Int -> (RPS, ExpectedResult) -> m Int
foldExpResult prevScore (oppPlay, result) = return $ prevScore + evalMatchHard (oppPlay, result)Answering the Question
No further work is needed beyond passing our inputs to our functions and taking the result:
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard input
-- Note: These functions are the same, since nothing extra was required in processing!
processInputEasy = solveFoldNow we're done!
Video
Day 1 - Intro Problem
As a reminder, these writeups won't be super detailed, since I have to do one every day. I'll try to focus on the key ideas though, and I'll always link to my code!
Subscribe to Monday Morning Haskell!
Problem Overview
This year we're dealing with elves. Each elf is carrying some snack items with a certain number of calories. Our input has one calorie count per line, and an empty line denotes that we have reached the end of one elf's snack collection and started another.
1000
2000
3000
4000
5000
6000
7000
8000
9000
10000For the first part, we just want to find the elf with the most calories. This is the 4th elf, with a total of 24000 calories (7000+8000+9000).
For the second part, we want the sum of calories from the three elves with the most. So we take the 24000 from the elf with the most, and add the 3rd elf (11000 calories) and the 5th elf (10000 calories). This gives a total of 45000.
Solution Approach and Insights
Nothing complicated here. Once we parse into list-of-lists-of-ints, we just use map sum and either take the maximum or the sum of the top 3.
Relevant Utilities
Function parseFile
Parsing the Input
Here's our parsing code. One nuance...I needed to add an extra empty line to the given inputs in order to make this parse work. Dealing with empty line separators is a little tricky with megaparsec (or at least I haven't mastered the right pattern yet), because the "chunk separator" is the same as the "line separator" within each chunk (eol parser).
parseInput :: (MonadLogger m) => ParsecT Void Text m [[Int]]
parseInput =
sepEndBy1 parseIntLines eol
where
parseIntLines = some parseIntLine
parseIntLine = do
i <- parsePositiveNumber
eol
return iGetting the Solution
As above, nothing complicated here. Use map sum and take the maximum.
processInputEasy :: (MonadLogger m) => [[Int]] -> m Int
processInputEasy intLists = return $ maximum (map sum intLists)With the hard part, we sort, reverse, take 3, and then take another sum.
processInputHard :: (MonadLogger m) => [[Int]] -> m Int
processInputHard intLists = return $ sum $ take 3 $ reverse $ sort (map sum intLists)Answering the Question
And no additional processing is needed - we have our answer! (My standard template has the answer always wrapped in Maybe to account for failure cases).
solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputEasy input
solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
input <- parseFile parseInput fp
Just <$> processInputHard inputVideo
Advent of Code 2022!
Tomorrow is December 1st, which means that tonight (midnight Eastern American time, 9pm Pacific) is the start of Advent of Code! This is an informal, annual coding contest where you can solve one programming puzzle each day from December 1st up through Christmas on December 25th. The problems generally get more challenging as the month goes on, as you'll start needing to use more advanced data structures and solution techniques.
Last year I did Advent of Code for the first time, writing up all my solutions in Haskell (of course). This year I will be doing the contest again, and this time I plan to create more blog content as I go, rather than doing writeups way after the fact. Of course, I might not be able to do everything every day, but I'll try to keep up!
Here are all the ways I'll be trying to put my solutions out there for you to learn from (and critique!).
Code
I will push all my code to my GitHub repository, on the aoc-2022 branch. So once my solutions are done you'll be able to see them for yourself!
Writeups
I will also attempt to do daily write-ups on the blog, giving a rough descriptive outline of each solution. These won't be as detailed as the write-ups I did in the last month or so, but all the code will be there and I'll describe all the key insights and general solution approach.
Videos
I'll also be recording myself as I solve the problems so you can watch my solution process in real time. I'll post these videos to my YouTube channel. These videos will generally be unedited since I won't have time to go back through everything every day. I also won't be able to do these as much when it gets closer to Christmas as I'll be traveling and away from my recording setup. Some of these videos might have more commentary, some might have less. I haven't decided yet and it will vary from day-to-day.
Streaming
I will not have a regular streaming schedule. As much as possible, I plan to attempt to solve problems as soon as they come out, and the contest rules request that people do not stream solutions until the leaderboard (for the fastest solutions) is filled for that particular problem. This is in order to prevent someone from copying the solution and getting on the leaderboard without effort. (For what it's worth, I doubt I'll actually be fast enough to get on the leaderboard).
If I get behind on my solutions, then it's very possible I'll do some streaming sessions while I catch up. You can follow me on Twitter or on my Twitch stream to know when I'm going live!
Conclusion
I'll try to keep up and solve the problem every day and keep up with content, but life gets busy, so I can't make any guarantees! But hopefully I'll have all the solutions published by the end of the year!
I encourage you to try out the Advent of Code problems for yourself! It's a great tool for learning a new programming language (especially Haskell!).
I'll also be doing a couple newsletter updates over the course of this month, so make sure to subscribe to our mailing list to get those and stay up to date!
Black Friday Sale Ends Today!
Today is Cyber Monday, which marks the last day of our Black Friday Thanksgiving sale! This is your last chance to get the biggest deals of the year on all of our online courses here at Monday Morning Haskell!
For the rest of the day, you can get 20% off any of our courses by using the code BLACKFRIDAY22 at checkout. And you can get an extra discount (up to 30% off) if you subscribe to our monthly newsletter!
Here's one final review of our different courses.
Haskell From Scratch
This is our full-length beginners course. It will give you a full introduction to Haskell's syntax and core concepts. You'll also get the chance to start developing your Haskell problem solving skills. It's the best option if you've never written a full Haskell project before!
Making Sense of Monads
This shorter course focuses strictly on monads and other functional structures. If monads have been a tricky subject for you in the past, hopefully this course can help you finally conquer them! The course includes two mini-projects for you to hone your skills!
Effectful Haskell
Effectful Haskell goes a step beyond our introductory monads course. You'll learn some practical applications for advanced monadic ideas - like how to use monad classes and free monads to organize effects in your program. Effectful Haskell also includes some basic practice in deploying an application to Heroku.
Practical Haskell
Practical Haskell is our second full-length course. Over the course of five modules, you'll build out the different layers of a full-stack application. You'll learn how to interact with a database, build a web server and develop a web frontend with Elm!
Haskell Brain
Haskell Brain is our machine-learning course. It will teach you how to use TensorFlow in conjunction with Haskell, as well as a couple other related libraries and techniques!
Conclusion
So don't miss out on these offers! Remember the code BLACKFRIDAY22 at checkout for 20% off, and you can subscribe to our mailing list for an ever better offer!
Later this week, we'll be back with the start of Advent of Code, so there will be a ton of new content in the next month!
Black Friday Spotlight: Haskell Brain!
Machine learning is one of the most important skills in software today. The field has typically been dominated by languages like Python (through TensorFlow and PyTorch) and R. So it's a bit frustrating for Haskell fans who want to use this awesome language as widely as possible but struggle to apply it to this critical domain.
However, there are a few tools out there that allow us to use Haskell for machine learning! Chief among these are the Haskell Tensorflow bindings. They aren't easy to use though, and there aren't many tutorials either!
The Haskell Brain seeks to fill this gap. This course will walk you through all the important questions about getting started with Haskell and TensorFlow.
- What system setup is required?
- How are tensors represented in Haskell?
- How can I train a machine learning model with tensors?
If you're ready to start answering these questions, head to the course sales page!
For more details about what's included in the course, including FAQ, head over to our course description page.
The best part of it is that for the next few days, you can get 20% off this course through our Black Friday sale! Just use the code BLACKFRIDAY22 and checkout. If you want an even better deal of 30% off, you can subscribe to our mailing list! You'll get a special code when you sign up. So don't miss out!
Black Friday Spotlight: Practical Haskell
How do you actually do something in Haskell? A programming language is only helpful if we can use it to solve real problems. Perhaps you've written up some neat and tidy solutions to small problems with Haskell. But does the language actually have the libraries and tools to build useful programs?
The answer to this question is a resounding Yes! Not only does Haskell have useful libraries for practical problems, but the "Haskell Approach" to these problems often has clear advantages! For instance, in Haskell you can:
- Write database queries that are type-safe, interoperating seamlessly with well-defined Haskell types.
- Define a web server where the API is clearly laid out and defined in terms of Haskell types.
- Link your Haskell types to frontend types that will populate your Web UI
- Organize "effects" within your system so that the capabilities of different functions are explicitly defined and known to your program at compile-time.
- Use monads to describe a test case in plan language.
These ideas can supercharge your Haskell abilities! But they aren't necessarily easy to pick up. It takes a fair amount of commitment to learn them well enough to use in your own projects.
Luckily, Monday Morning Haskell has a great tool for you to learn these skills! Our Practical Haskell Course will teach you how to build a functional application that integrates systems like databases, web servers, frontend web pages, and behavioral tests.
If this sounds like exactly what you've been looking for to rapidly improve your Haskell, head to the course page to get started!
If you're curious for more details, head to our course description page to learn about what you can expect in the course.
Don't forget, you've got a couple more days to take advantage of our Black Friday Sale! You can use the code BlackFriday22 to get 20% off any of our courses, including Practical Haskell. If you subscribe to our mailing list, you can get an even better code for 30% off! So don't miss out on those savings!
