Today’s puzzle involves a combination lock with a rotating dial. We’re given a series of left (L) and right (R) rotations, and we need to count how many times the dial lands exactly on position 0 after completing each rotation.
The dial has 100 positions (0-99) and starts at position 50.
{-# LANGUAGE TypeApplications #-}
module Day01 whereLet’s start by modeling the problem. A list of integers is perfect for representing rotations—we’ll use positive integers for right rotations and negative integers for left rotations. This lets us simply add the rotation value to our current position without branching logic.
parse :: String -> [Int]
parse = map parseLine . lines
where
parseLine :: String -> Int
parseLine ('R':rest) = read @Int rest
parseLine ('L':rest) = negate $ read @Int rest
parseLine _ = undefinedTo solve this, we’ll fold over the list of rotations while
maintaining a tuple of (count, currentRotation):
count: the number of times we’ve landed exactly on
0currentRotation: our current position on the
dialAfter each rotation, we check if our new position modulo 100 equals 0—meaning we’ve landed precisely on position 0.
solvePart1 :: [Int] -> Int
solvePart1 = fst . foldl' rotate (0, 50)
where
rotate :: (Int, Int) -> Int -> (Int, Int)
rotate (count, currentRotation) rotation =
let newRotation = currentRotation + rotation
isZero = newRotation `mod` 100 == 0
in (count + if isZero then 1 else 0, newRotation)All that’s left is to compose parsing with solving:
part1 :: String -> Int
part1 = solvePart1 . parsePart 2 increases the difficulty: now we need to track how many times the indicator passes through position 0, including positions crossed during a rotation (not just where it lands).
For example, if we’re at position 80 and rotate right by 30, we pass through position 0 once during that rotation (80 → 90 → 100/0 → 10).
The base algorithm remains a fold over the rotation list, but now we need a more sophisticated way to count zero crossings:
solvePart2 :: [Int] -> Int
solvePart2 rotations = fst $ foldl' go (0, 50) rotations
where
go :: (Int, Int) -> Int -> (Int, Int)
go (count, currentRotation) rotation =
let newRotation = currentRotation + rotation
clicks = numberOfClicks currentRotation rotation
in (count + clicks, newRotation)The numberOfClicks function calculates how many times
we pass through zero during a single rotation.
The logic breaks down as follows:
totalRotations)currentPos + remainder >= 100currentPos - remainder <= 0numberOfClicks :: Int -> Int -> Int
numberOfClicks pos rotation =
let actualPos = normalizeRotation pos
(totalRotations, remainder) = quotRem (abs rotation) 100
remainderClicks = if rotation > 0
then actualPos + remainder >= 100
else actualPos /= 0 && actualPos - remainder <= 0
in totalRotations + if remainderClicks then 1 else 0One important edge case: Haskell’s mod operator
doesn’t wrap negative numbers the way we need for a circular dial. Our
custom normalization function ensures that -10 becomes
90, -110 becomes 90, and so
on—wrapping properly in the reverse direction.
normalizeRotation :: Int -> Int
normalizeRotation n
| n >= 0 = n `mod` 100
| otherwise = (100 - (abs n) `mod` 100) `mod` 100With all the pieces in place, Part 2 comes together:
part2 :: String -> Int
part2 = solvePart2 . parseToday’s puzzle gives us a list of numeric ranges:
(90 - 10000)
(57 - 82345)Our task: find all “invalid IDs” within each range and sum them together.
An ID is invalid if its digits can be split into two equal halves. For example:
1010 splits into 10 and 10
✓ invalid123123 splits into 123 and
123 ✓ invalid88 splits into 8 and 8 ✓
invalid123 has odd length ✗ valid1234 splits into 12 and 34
✗ valid{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module Day02 where
import qualified Data.Text as T
import Control.Arrow ((>>>))
import Data.Function ((&))
import Data.List.Split (chunksOf)The input is comma-separated ranges, which we’ll model as pairs of integers.
type Range = (Int, Int)
parse :: String -> [Range]
parse = T.pack >>> T.splitOn "," >>> map parseRange
where
parseRange str = let [a, b] = T.splitOn "-" str
in (read @Int $ T.unpack a, read @Int $ T.unpack b)The algorithm is straightforward: for each range, check every number to see if it’s invalid, sum those that are, then sum across all ranges.
The isInvalid function checks if a number has even
digit length and whether its first half equals its second half.
part1 :: String -> Int
part1 = parse >>> map invalidIdsInRange >>> sum
where
invalidIdsInRange :: Range -> Int
invalidIdsInRange (a, b) = sum $ filter isInvalid $ [a..b]
isInvalid :: Int -> Bool
isInvalid n = let str = show n
[fst, snd] = chunksOf (length str `div` 2) str
in even (length str) && fst == sndPart 2 generalizes the pattern: now an ID is invalid if it consists of any repeating segment, not just two halves. For example:
111 → 1 repeated 3 times ✓ invalid123123123 → 123 repeated 3 times ✓
invalid88 → 8 repeated 2 times ✓ invalid1234 → no repeating pattern ✗ validWe need to find all possible chunk sizes that could divide the number evenly, then check if chunking by that size produces identical chunks.
For a number with length 6, we check chunk sizes 1, 2, and 3 (divisors of 6). If any chunking produces all-equal chunks, the number is invalid.
The implementation changes only the isInvalid
function—everything else stays the same.
part2 :: String -> Int
part2 = parse >>> map invalidIdsInRange >>> sum
where
invalidIdsInRange :: Range -> Int
invalidIdsInRange (a, b) = sum $ filter isInvalid $ [a..b]
isInvalid :: Int -> Bool
isInvalid n = let str = show n
divs = [1..length str `div` 2] & filter (\it -> length str `mod` it == 0)
in any (allEqual . flip chunksOf str) divs
allEqual :: (Eq a) => [a] -> Bool
allEqual (x:xs) = all (== x) xs
allEqual [] = TrueToday’s input gives us rows of digits—think of each row as a “bank of batteries”:
987654321111111
811111111111119
234234234234278
818181911112111Each digit represents a battery, and our job is to calculate the maximum “joltage” for each bank, then sum them all together.
For Part 1, the joltage of a bank is determined by picking any two
digits (in order, no reversing) and forming a two-digit number. For
example, from 987654321111111, we could pick the
9 and 8 to get 98, or the
9 and 7 to get 97. The maximum
joltage is the largest such number we can form.
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Day03 where
import Control.Arrow ((>>>))
import Data.Function ((&), on)
import Data.Foldable (Foldable(foldMap'))
import Data.Monoid (Sum(Sum, getSum))
import Data.List (sortBy)Our data model is simple: a list of banks, where each bank is a list of digit values.
type Bank = [Int]Parsing is straightforward—we split into lines and convert each character to a single digit.
parse :: String -> [[Int]]
parse = lines
>>> map (map (read @Int . (:[])))The algorithm: generate all possible pairs of digits (maintaining order), form two-digit numbers from each pair, and take the maximum. Sum across all banks for the final answer.
part1 :: String -> Int
part1 = solve . parse
where
solve :: [Bank] -> Int
solve = sum . map getBankJoltage
getBankJoltage :: Bank -> Int
getBankJoltage = maximum . allJoltagesInBank
allJoltagesInBank :: Bank -> [Int]
allJoltagesInBank = map (\(a, b) -> a * 10 + b) . batteryPairs
batteryPairs :: Bank -> [(Int, Int)]
batteryPairs (x:xs) = map (x,) xs <> batteryPairs xs
batteryPairs [] = []Part 2 escalates things: now we need to pick 12 digits to form a 12-digit number, and maximize that.
Here’s the key insight: we can solve this greedily by picking digits from most significant to least significant.
Let’s think through a simpler example: picking 4 digits from a 6-digit bank. The first digit we pick can’t be in the last 3 positions—we need to leave room for the 3 digits that follow. Among the valid positions (first 3 positions), we pick the largest digit.
If there’s a tie, we pick the earliest occurrence. Why? Because choosing earlier gives us more options for subsequent digits—we preserve flexibility down the line.
Once we’ve picked the first digit, we repeat the process for the second digit (starting from just after our first pick), then the third, and so on.
The structure mirrors Part 1, except we use
getMaxJoltageOf to generalize to any number of digits (12
in this case).
-- | The solution for part2 is more efficient and could be used for part1 by using (getMaxJoltageOf 2)
part2 :: String -> Int
part2 = solve . parse
where
solve :: [[Int]] -> Int
solve = sum . map (getMaxJoltageOf 12)The getMaxJoltageOf function implements our greedy
strategy. For each digit position, we calculate which indices in the
original bank are valid candidates (ensuring we leave enough room for
remaining digits), then pick the largest digit from those
positions.
The recursion tracks three things: how many digits we’ve picked so far, the minimum index we can pick from (to maintain order), and our accumulated result.
-- |returns the max joltage of taking `size` batteries in a bank
getMaxJoltageOf :: Int -> [Int] -> Int
getMaxJoltageOf size digits = mergeDigits $ reverse $ go 0 0 []
where
go :: Int -> Int -> [Int] -> [Int]
go n _ acc | n == size = acc
-- | recursively find the next best digit
-- when picking a digit we know what positions in the original array are valid
-- we pick the greatest digit and if there are multiple we pick the first
go ix minBound acc = let digitBounds = [minBound..(length digits - size + ix)]
(maxDigitIx, maxDigit) = head . sortBy (compare `on` negate . snd) $ map (\(ix, ix2) -> (ix, digits!!ix2)) $ zip digitBounds digitBounds
in go (ix + 1) (maxDigitIx +1) (maxDigit:acc)Finally, we need to merge our list of digits into an actual number. We reverse the list (since we built it backwards), then combine digits by multiplying each by the appropriate power of 10 based on its position.
-- | Merges digits into number.
-- mergeDigits [1, 2, 3] === 123
mergeDigits :: [Int] -> Int
mergeDigits xs = zip [0..] (reverse xs)
& foldMap' (\(ix, d) -> Sum (d * 10 ^ ix))
& getSumToday’s puzzle presents us with a 2D grid containing rolls of paper
(marked with @) scattered among empty spaces.
Our task: count how many rolls are accessible. A roll is accessible if it has fewer than 4 neighboring rolls in the 8 adjacent positions (including diagonals). In other words, rolls that are too crowded (4+ neighbors) are inaccessible.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
module Day04 where
import Data.HashSet (HashSet)
import qualified Data.HashSet as Set
import Linear.V2We’ll use V2 Int from the linear package
to represent positions, and a HashSet to store the
grid.
Since we only care about where the rolls are (not empty spaces), we store just the positions containing rolls. This gives us efficient O(1) average-case lookups to check “is there a roll at this position?”
type Position = V2 Int
type Grid = HashSet Position
parse :: String -> Grid
parse str =
Set.fromList $
[ pos
| (lineIx, line) <- zip [0..] (lines str)
, (colIx, char) <- zip [0..] line
, let pos = V2 lineIx colIx
, char == '@'
]The solution filters the grid to keep only rolls with fewer than 4 neighbors, then counts them.
solvePart1 :: Grid -> Int
solvePart1 grid = length . Set.filter ((<4) . getAdjacentRolls grid) $ gridThe getAdjacentRolls helper generates all 8 adjacent
positions (using vector addition) and counts how many contain
rolls.
getAdjacentRolls :: Grid -> Position -> Int
getAdjacentRolls grid pos = length . filter (`Set.member` grid) . map (pos +) $ adjacentVectors
where
adjacentVectors :: [V2 Int]
adjacentVectors = [V2 a b | a <- [-1..1], b <- [-1..1], a /= 0 || b /=0 ]
part1 :: String -> Int
part1 = solvePart1 . parsePart 2 introduces a removal process: we repeatedly remove all accessible rolls (those with fewer than 4 neighbors) until no more can be removed. The answer is the total count of removed rolls.
This is a classic fixed-point iteration. Each round, we:
The trick: when we remove rolls, previously inaccessible rolls might become accessible (they now have fewer neighbors). So we keep iterating until we reach a stable state.
The final answer is the difference between the original grid size and the final grid size.
solvePart2 :: Grid -> Int
solvePart2 grid = let finalGrid = removeAll grid
in length grid - length finalGrid
where
-- Keep only inaccessible rolls (4+ neighbors)
removeOnce :: Grid -> Grid
removeOnce grid = Set.filter (\pos -> getAdjacentRolls grid pos >= 4) grid
-- Iterate until we reach a fixed point (grid stops changing)
removeAll :: Grid -> Grid
removeAll grid = let !next = removeOnce grid
in if Set.size next == Set.size grid
then grid
else removeAll next
part2 :: String -> Int
part2 = solvePart2 . parseToday’s puzzle gives us a database containing two pieces of information:
100-500,
600-1000)Our task for Part 1: count how many of the given IDs fall within at least one of the valid ranges. An ID is “fresh” if it’s covered by any range.
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE BangPatterns #-}
module Day05 where
import Data.List (sortBy)
import Data.Function (on)We’ll represent ranges as pairs of integers and bundle everything
into a Database type for clean organization.
type Range = (Int, Int)
data Database = Database
{ ranges :: [Range]
, ids :: [Int]
} deriving (Show)The input format has ranges first (one per line), then a blank line, then a list of IDs. We split on the blank line and parse each section accordingly.
parse :: String -> Database
parse str =
let rows = lines str
(rangeLines, idLines) = break (null) rows
in Database
(map parseRange rangeLines)
(map read $ tail idLines)
where
parseRange :: String -> Range
parseRange str = let (fst', snd') = break (== '-') str
in (read fst', read . tail $ snd')Part 1 is straightforward: for each ID, check if any range contains it. Count the IDs that pass this test.
The contains helper checks if a value falls within a
range’s bounds (inclusive).
solvePart1 :: Database -> Int
solvePart1 (Database ranges ids) = length $ filter isFresh ids
where
isFresh :: Int -> Bool
isFresh id = any (contains id) ranges
contains :: Int -> Range -> Bool
contains id (min, max) = id >= min && id <= max
part1 :: String -> Int
part1 = solvePart1 . parsePart 2 asks a different question: what’s the total count of unique integers covered by all the ranges combined?
For example, if we have ranges 1-5 and
3-8, the unique integers covered are
[1,2,3,4,5,6,7,8], giving us a count of 8 (not 11, which
would be if we counted overlaps twice).
The key insight: if we sort the ranges by their start position, we know that each subsequent range never starts before any previous range. This makes merging overlaps much simpler.
As we fold through the sorted ranges, we track: - The previous range’s maximum value - The running count of unique integers covered
For each new range, we calculate how many new integers it contributes by ensuring we don’t double-count overlaps with the previous range.
solvePart2 :: Database -> Int
solvePart2 = snd . foldl' addRange empty . sortBy (compare `on` fst) . ranges
where
countRange (min, max) = max - min + 1
addRange :: (Range, Int) -> Range -> (Range, Int)
addRange ((_, prevMax), count) (nextMin, nextMax) =
let newRange = ( max nextMin (prevMax + 1), max nextMax prevMax)
in (newRange, count + countRange newRange)
empty :: (Range, Int)
empty = ((undefined, (-2)), 0)
part2 :: String -> Int
part2 = solvePart2 . parseToday’s puzzle gives us a grid of numbers followed by a line of operations.
The twist? We need to read the grid vertically (column by column) rather than horizontally. Each column of numbers gets paired with an operation from the last line, and we apply that operation to get a result. The final answer is the sum of all column results.
For example, if a column is [2, 3, 5] and the
operation is +, we get 10. If the operation
is *, we get 30.
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE BangPatterns #-}
module Day06 where
import Data.List (unsnoc, transpose)
import Data.Char (isSpace)
import Control.Arrow ((>>>))
import Data.Function ((&))The algorithm is straightforward:
part1 :: String -> Int
part1 str =
let Just (rows, opsLine) = unsnoc . lines $ str
matrix :: [[Int]]
matrix = transpose . map (map (read @Int) . words) $ rows
ops = words opsLine
in sum . map (uncurry getOp) $ zip ops matrixWe support two operations: sum (+) and product
(*).
getOp :: String -> [Int] -> Int
getOp "+" = sum
getOp "*" = product
getOp _ = error "unreachable"Part 2 changes the parsing rules. Now the grid can contain empty spaces within columns, and we need to treat sequences of numbers separated by spaces as distinct groups within each column.
For example, a column might look like:
1
2
3
4
This represents two groups: [1, 2] and
[3, 4]. We split on empty spaces, apply operations to
each group separately, then sum everything.
The key difference is in how we process the transposed data:
part2 :: String -> Int
part2 str =
let Just (rows, opsLine) = unsnoc . lines $ str
numbers = rows
& transpose
& map (strip)
& splitOn null
& map (map (read @Int))
ops = words opsLine
in sum . map (uncurry getOp) $ zip ops numbersWe need helpers to strip whitespace and split on a predicate.
strip :: String -> String
strip = dropWhile (isSpace) >>> takeWhile (not . isSpace)
splitOn :: (a -> Bool) -> [a] -> [[a]]
splitOn _ [] = []
splitOn fn xs = let (group, rest) = break fn xs
remaining = splitOn fn (drop 1 rest)
in if null group then remaining else group : remainingToday’s puzzle involves a beam of light traveling through a grid
containing tachyons (represented by ^ symbols). The beam
starts at position S and travels upward through
columns.
When the beam hits a tachyon, something interesting happens: it splits into two beams that move horizontally (one left, one right), then continue upward from their new positions.
Our task: count how many unique tachyons the beam(s) will hit.
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE BangPatterns #-}
module Day07 where
import Data.Function ((&), on)
import Data.List (find, sortBy, sort, uncons)
import Data.HashMap.Lazy (HashMap, (!?))
import qualified Data.HashMap.Lazy as Map
import qualified Data.HashSet as Set
import Data.HashSet (HashSet)
import Control.Monad (guard)We need to track:
S position)data Instructions = Instructions {
_start :: (Int, Int),
_tachyons :: HashMap Int [Int] -- maps column x to list of y coordinates
} deriving (Show)We scan the grid for special characters: S marks the
start position, and ^ marks tachyons. We organize
tachyons by column and sort their y-coordinates for efficient upward
traversal.
parse :: String -> Instructions
parse str = let chars :: [(Char, (Int, Int))]
chars = [ (c, (x, y))
| (y, line) <- zip [0..] (lines str)
, (x, c) <- zip [0..] line
, c /= '.'
]
Just (_, start) = find (\(c, _) -> c == 'S') chars
tachyons = chars
& filter (\(c, _) -> c == '^')
& map snd
& sortBy (compare `on` fst)
& groupBy fst
& map (\col -> (fst $ head col, map snd col))
& Map.fromList
& fmap (sort)
in Instructions start tachyonsA simple grouping function that clusters consecutive elements with the same key.
groupBy :: (Eq b) => (a -> b) -> [a] -> [[a]]
groupBy fn [] = []
groupBy fn (x:xs) = let (group, rest) = span (\a -> fn a == fn x) xs
in (x:group) : groupBy fn restThe beam simulation is a recursive traversal:
(x, y), look up the column
and find the next tachyon above the current y-coordinate(x-1, newY) and right (x+1, newY)The union of all visited tachyons gives us the answer.
solvePart1 :: Instructions -> Int
solvePart1 (Instructions start tachyons) = Set.size $ go mempty start tachyons
where
go :: HashSet (Int, Int) -> (Int, Int) -> HashMap Int [Int] -> HashSet (Int, Int)
go cache (x, y) tachyons =
let match = do
col <- tachyons !? x
(head, rest) <- uncons $ dropWhile (< y) col
guard $ not $ (x, head) `Set.member ` cache
let newMap = Map.insert x rest tachyons
Just (head, newMap)
in case match of
Just (newY, newMap) ->
let newCache = Set.insert (x, newY) cache
lhs = go newCache (x - 1, newY) newMap
rhs = go lhs (x + 1, newY) newMap
in Set.union lhs rhs
Nothing -> cache
part1 :: String -> Int
part1 = solvePart1 . parsePart 2 asks: how many distinct paths does the beam take to reach the end?
Instead of just counting visited tachyons, we now count all the different ways the beam can split and travel through the grid. This is a classic path-counting problem that benefits from memoization—if we reach the same tachyon from the same direction multiple times, the number of paths from there is always the same.
The algorithm is similar to Part 1, but now:
(position -> path_count)
instead of a setsolvePart2 :: Instructions -> Int
solvePart2 (Instructions start tachyons) = snd $ go mempty start tachyons
where
go :: HashMap (Int, Int) Int -> (Int, Int) -> HashMap Int [Int] -> (HashMap (Int, Int) Int, Int)
go cache (x, y) tachyons =
let match = do
col <- tachyons !? x
(head, rest) <- uncons $ dropWhile (< y) col
let newMap = Map.insert x rest tachyons
Just (head, newMap, cache Map.!? (x, head))
in case match of
Just (newY, newMap, count) ->
case count of
Just n -> (cache, n) -- Cache hit!
Nothing -> let (leftCache, nl) = go cache (x - 1, newY) newMap
(rightCache, nr) = go leftCache (x + 1, newY) newMap
newCache = Map.insert (x, newY) (nl + nr) $
Map.union leftCache rightCache
in (newCache, nl + nr)
Nothing -> (Map.empty, 1) -- Reached the end, count as 1 path
part2 :: String -> Int
part2 = solvePart2 . parseToday’s puzzle gives us electrical junctions floating in 3D space, each described by x,y,z coordinates:
162,817,812
57,618,57
906,360,560
...Our task: repeatedly pick the two closest junctions and connect them into a circuit. This happens 1000 times, and each connection can play out in three ways:
After 1000 connections, we multiply the sizes of the three largest circuits together.
If this sounds like a job for a Union-Find (Disjoint Set) data structure, you’re absolutely right. That’s the textbook efficient solution for this kind of problem.
Here’s the thing: this puzzle is actually why I learned about disjoint sets in the first place—but only after I’d already solved it my own way. So today we’ll walk through my original, more naive approach using the State monad and some good old hashmaps.
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE BangPatterns #-}
module Day08 where
import Linear.V3
import Data.Function (on)
import Data.List.Split (splitOn)
import System.IO (readFile')
import Data.List (sortBy)
import Data.HashMap.Strict (HashMap, (!?) )
import qualified Data.HashMap.Strict as Map
import Control.Lens
import Control.Arrow ((>>>))
import Control.Monad.State.Lazy (State, evalState)
import Control.Monad (forM_)Let’s start with our data model. We’ll use integers to identify
circuits and 3D vectors from the linear library to
represent junction positions.
type CircuitId = Int
type Junction = (V3 Int)Parsing is straightforward—each line contains comma-separated x,y,z coordinates.
parse :: String -> [Junction]
parse = map parseJunction . lines
where
parseJunction :: String -> Junction
parseJunction line = let [x, y, z] = splitOn "," line
in V3 (read x) (read y) (read z)For distance calculations, we use squared Euclidean distance. Since
we only care about relative distances for sorting, we can skip the
sqrt—it’s monotonic, so the ordering stays the same and
we save some computation.
distanceTo :: Junction -> Junction -> Double
distanceTo (V3 x1 y1 z1) (V3 x2 y2 z2) =
(fromIntegral (x2 - x1)) ** 2.0
+ (fromIntegral (y2 - y1)) ** 2.0
+ (fromIntegral (z2 - z1)) ** 2.0The distances function generates all possible junction
pairs and sorts them by distance, giving us a priority queue of
connections to process.
distances :: [Junction] -> [(Junction, Junction)]
distances vecs = [ (v1, v2)
| (ix, v1) <- zip [0..] vecs
, v2 <- drop (ix + 1) vecs
] & sortBy (compare `on` uncurry distanceTo)Now for the core state management. Our ProblemState
tracks three things:
nextCircuitId: Counter for assigning
IDs to new circuitsjunctions: Maps each junction to its
circuit ID (for fast “which circuit am I in?” lookups)circuits: Maps each circuit ID to
its junctions (for fast “what’s in this circuit?” lookups)This bidirectional indexing lets us efficiently handle all three connection cases.
data ProblemState = ProblemState {
_nextCircuitId :: CircuitId,
_junctions :: HashMap Junction CircuitId,
_circuits :: HashMap CircuitId [Junction]
}
emptyState :: ProblemState
emptyState = ProblemState 0 Map.empty Map.emptyWe’re using the State monad combined with the lens library to keep our solution clean and readable. Lenses let us update nested state elegantly without the usual record update boilerplate. If you’re new to lenses, I highly recommend Optics By Example.
makeLenses 'ProblemStateWe alias our computation type as Solver for
clarity.
type Solver a = State ProblemState aAdding a junction to a circuit requires updating both indexes: we record which circuit the junction belongs to, and add the junction to that circuit’s member list.
addJunctionToCircuit :: (V3 Int) -> CircuitId -> Solver ()
addJunctionToCircuit junction circuitId = do
junctions %= Map.insert junction circuitId
circuits %= Map.alter (insert junction) circuitId
return ()
where
insert :: V3 Int -> Maybe [V3 Int] -> Maybe [V3 Int]
insert junction Nothing = Just [junction]
insert junction (Just js) = Just (junction : js)Now for the heart of the solution: processing a junction pair.
Given junctions (a, b), we need to handle five distinct
cases:
a is connected: Add
b to a’s circuitb is connected: Add
a to b’s circuitThis is where things get interesting—and where a proper Union-Find structure would shine. But our State monad approach keeps the logic explicit and easy to follow.
addJunctionPair :: (V3 Int, V3 Int) -> Solver ()
addJunctionPair (a, b) = do
-- find the circuits where a and b belong
mCa <- uses junctions (!? a)
mCb <- uses junctions (!? b)
case (mCa, mCb) of
(Just ca, Nothing) -> addJunctionToCircuit b ca
(Nothing, Just cb) -> addJunctionToCircuit a cb
(Just ca, Just cb) | ca == cb -> return ()
(Just ca, Just cb) -> do
junctionsInCa <- uses circuits (Map.! ca)
forM_ junctionsInCa $ flip addJunctionToCircuit cb
circuits %= Map.delete ca
(Nothing, Nothing) -> do
nextId <- use nextCircuitId
nextCircuitId += 1
addJunctionToCircuit a nextId
addJunctionToCircuit b nextIdWith our machinery in place, Part 1 is straightforward:
That final one-liner does some heavy lifting: it extracts all circuits, maps to their sizes, sorts in descending order, takes the top 3, and multiplies them together.
part1 :: String -> Int
part1 = solvePart1 . parse
solvePart1 :: [V3 Int] -> Int
solvePart1 junctions = flip evalState emptyState $ do
let pairs = take 1000 $ distances junctions
forM_ pairs addJunctionPair
uses circuits (Map.toList >>> map (length . snd) >>> sortBy (flip compare) >>> take 3 >>> product)Part 2 asks a different question: when do all junctions get connected into a single unified circuit? We need to find the specific pair that completes this unification, then multiply their x-coordinates together.
The beautiful part? We’ve already built everything we need. Our state tracks both the number of junctions assigned to circuits and the number of distinct circuits. When those numbers are equal to the total junction count and 1 respectively, we’re done.
The addUntilDone helper processes pairs one by one
until it hits that condition, then returns the winning pair. Multiply
the x-coordinates, and we have our answer.
part2 :: String -> Int
part2 = solvePart2 . parse
solvePart2 :: [V3 Int] -> Int
solvePart2 js = flip evalState emptyState $ do
let pairs = distances js
addUntilDone [] = error "unreachable"
addUntilDone (n:rest) = do
addJunctionPair n
junctionCount <- uses junctions Map.size
circuitCount <- uses circuits Map.size
if junctionCount == length js && circuitCount == 1
then return n
else addUntilDone rest
(a, b) <- addUntilDone pairs
return $ a^._x * b^._xToday’s puzzle gives us a collection of points scattered across a 2D grid. Our task: find the largest rectangle we can form by choosing any two points as opposite corners.
The twist? The rectangle’s sides must be axis-aligned (parallel to the x and y axes), and we count tiles inclusively—so a rectangle from (0,0) to (2,2) contains 9 tiles, not 4.
Oooof, these imports are getting out of hand! But hey, we’ve got SVG rendering to do later.
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Day09 where
import Linear.V2
import Data.List.Split (splitOn)
import Control.Arrow ((>>>))
import System.IO (readFile')
import Data.Function ((&))
import Control.Lens.Getter
import Text.Blaze.Svg11 ((!), m)
import qualified Text.Blaze.Svg11 as S
import qualified Text.Blaze.Svg11.Attributes as A
import Text.Blaze.Svg.Renderer.String (renderSvg)
import Text.Printf (printf)
import Data.String (IsString(fromString))
import Text.Blaze.Svg (mkPath)
import Control.Monad (forM_)
import Text.Blaze.Svg11 (l)The linear library’s V2 Int type is
perfect for 2D points—it gives us vector operations for free if we
need them later.
Parsing is straightforward: each line contains comma-separated x,y coordinates.
type Point = V2 Int
parse :: String -> [Point]
parse = lines >>> map parseV2
where
parseV2 line = let [x, y] = splitOn "," line
in V2 (read x) (read y)With a modest number of points, brute force is our friend. We check every possible pair of points, calculate the resulting rectangle’s area, and take the maximum.
solvePart1 :: [V2 Int] -> Int
solvePart1 tiles =
maximum [ area p1 p2
| (ix, p1) <- zip [1..] tiles
, p2 <- drop ix tiles
]The area function adds 1 to each dimension because
we’re counting tiles inclusively—a rectangle from (0,0) to (2,2) spans
3 units in each direction, giving us 3×3=9 tiles.
area :: V2 Int -> V2 Int -> Int
area (V2 x1 y1) (V2 x2 y2) = (abs (y2 - y1) + 1) * (abs (x2 - x1) + 1)
part1 :: String -> Int
part1 = solvePart1 . parsePart 2 cranks up the difficulty: now we need to find the largest rectangle that fits inside a polygon formed by connecting all the input points in sequence.
My first instinct was to implement the classic raycast algorithm for point-in-polygon testing. But that’s a lot of code for something I’ve written before, and—let’s be honest—it’s not that interesting the second time around.
Instead, I got curious. What does the actual input look like? I whipped up a quick SVG visualization:
Jackpot! The polygon is roughly circular with a narrow cut extending inward from the edge.
This observation unlocks a much simpler approach: any rectangle large enough to be worth considering will be entirely on one side of that cut. It either fits in the “upper” region or the “lower” region—it can’t bridge across the cut without intersecting an edge.
So instead of checking if every point inside a candidate rectangle is within the polygon, we just need to verify that the rectangle’s boundary doesn’t intersect any polygon edges.
drawInput :: IO String
drawInput = do
points <- parse <$> readFile' "assets/day09-input.txt"
let edges = let (p:ps) = points in zip (p:ps) (ps ++ [p])
maxX = points & map (view _x) & maximum
maxY = points & map (view _y) & maximum
svgPath = mkPath $ do
forM_ edges $ \(e1, e2) -> do
m (e1^._x) (e1^._y)
l (e2^._x) (e2^._y)
svg = renderSvg $ S.docTypeSvg ! A.version "1.1" ! A.width "400" ! A.height "400" ! A.viewbox (fromString $ printf "0 0 %d %d" maxX maxY) $ do
S.path ! A.d svgPath ! A.strokeWidth "400" ! A.stroke "red";
return svgArmed with our insight, the solution mirrors Part 1’s brute force—except now we filter out any rectangle whose interior intersects with a polygon edge.
solvePart2 :: [V2 Int] -> Int
solvePart2 squares@(p:ps) =
let rectangles = [ (p1, p2)
| (ix, p1) <- zip [1..] squares
, p2 <- drop ix squares
, not (intersects p1 p2 edges)
]
edges = zip (p:ps) (ps ++ [p])
in maximum $ map (uncurry area) $ rectanglesThe intersects function checks if any polygon edge
crosses through our candidate rectangle. We do this by testing whether
the edge’s bounding box overlaps with the rectangle’s interior. If any
edge overlaps, the rectangle is invalid.
intersects :: V2 Int -> V2 Int -> [(V2 Int, V2 Int)] -> Bool
intersects p1 p2 edges = any inside $ edges
where
inside :: (V2 Int, V2 Int) -> Bool
inside (e1, e2) = min (e1^._x) (e2^._x) < maxX
&& max (e1^._x) (e2^._x) > minX
&& min (e1^._y) (e2^._y) < maxY
&& max (e1^._y) (e2^._y) > minY
minX = min (p1^._x) (p2^._x)
maxX = max (p1^._x) (p2^._x)
minY = min (p1^._y) (p2^._y)
maxY = max (p1^._y) (p2^._y)
part2 :: String -> Int
part2 = solvePart2 . parseToday’s puzzle presents us with a collection of lights, each composed of multiple LEDs. Our task: figure out the minimum number of button presses needed to configure each light to match a target pattern.
Each light comes with three pieces of information:
[.##.] where # represents an LED that should
be ON and . represents one that should be OFF(1,3) toggles LEDs at indices 1 and
3)For example, in
[.##.] (3) (1,3) (2) (2,3) (0,2) (0,1) {3,5,4,7}: - We
want LEDs at positions 1 and 2 to be ON, the rest OFF - We have six
buttons available, each toggling different LED combinations - The
joltages {3,5,4,7} don’t matter yet
This is essentially a search problem: starting from all LEDs off, find the shortest sequence of button presses to reach the target configuration
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
module Day10 where
import Data.List (uncons)
import Data.Function ((&))
import Data.List.Split (splitOn)
import Control.Arrow ((>>>))
import System.IO (readFile')
import qualified Data.HashMap.Strict as Map
import Data.HashMap.Strict (HashMap)
import qualified Data.IntSet as Set
import Data.IntSet (IntSet)
import qualified Z3.Monad as Z
import Data.Maybe (catMaybes)
import Control.Monad (forM, forM_)
import GHC.IO.Unsafe (unsafePerformIO)We’ll represent each light with a simple record type. The key
insight is that we only care about which LEDs are on, not
their order, so IntSet is perfect for tracking
configurations efficiently.
data Light = Light {
_target :: IntSet,
_buttons :: [[Int]],
_joltages :: [Int]
} deriving (Show)Parsing this format is a bit fiddly—we need to strip brackets, parentheses, and curly braces, then split on commas and whitespace. Not the most elegant code I’ve written, but it gets the job done without pulling in heavy parsing libraries.
Reminder to Self: find better combinators for parsing. (Although I’d like to keep my solutions parsec and regex free)
parse :: String -> [Light]
parse = map (parseLine . words) . lines
where
parseLine :: [String] -> Light
parseLine words =
let Just (light, rest) = uncons words
(buttons, [joltages]) = break ((== '{') . head) rest
in Light (parseLight light) (map parseButton buttons) (parseJoltages joltages)
parseLight :: String -> IntSet
parseLight str = filter (\c -> c /= '[' && c /= ']') str
& zip [0..]
& filter ((== '#') . snd)
& map (fst)
& Set.fromList
parseButton :: String -> [Int]
parseButton = filter (\c -> c /= '(' && c /= ')')
>>> splitOn ","
>>> map (read @Int)
parseJoltages :: String -> [Int]
parseJoltages = filter (\c -> c /= '{' && c /= '}') >>> splitOn "," >>> map (read @Int)When we want the minimum number of steps to reach a goal, breadth-first search (BFS) is our go-to algorithm. It explores all configurations reachable in N steps before trying any configuration that takes N+1 steps—guaranteeing we find the shortest path.
Here’s the game plan: 1. Start with all LEDs off (empty
IntSet) 2. For each configuration we’re exploring, try
pressing every button 3. Track which configurations we’ve seen before
to avoid cycles 4. Stop when we reach the target configuration
The breadth function does the heavy lifting: -
states: configurations we’re currently exploring -
cache: a map recording how many steps it took to reach
each configuration - steps: current depth in our
search
Each iteration generates new configurations by clicking every possible button on every current state, filters out ones we’ve seen before, and continues until we hit the target
The helper functions are straightforward: clickButton
applies a button press to a configuration by toggling each LED the
button affects, and toggleLight flips a single LED on or
off.
findMinButtonPresses :: Light -> Int
findMinButtonPresses (Light target buttons _) =
let (cache, _) = breadth 0 (Map.singleton Set.empty 0)[ Set.empty ]
in cache Map.! target
where
breadth :: Int -> HashMap IntSet Int -> [IntSet] -> (HashMap IntSet Int, [IntSet])
breadth steps cache states =
let !b = concatMap (\s ->
filter (not . (flip Map.member cache))
. map (clickButton s)
$ buttons )
states
!updatedCache = foldl' (\acc k -> Map.insert k (steps + 1) acc) cache b
!found = Map.member target updatedCache
in if null b then error "unreachable" else if found
then (updatedCache, b)
else breadth (steps + 1) updatedCache b
clickButton :: IntSet -> [Int] -> IntSet
clickButton current button =
foldl' (toggleLight) current button
toggleLight light button =
if button `Set.member` light
then Set.delete button light
else Set.insert button lightWith BFS handling the search for each individual light, the final solution just sums up the minimum button presses across all lights in our input.
solvePart1 :: [Light] -> Int
solvePart1 = sum . map findMinButtonPresses
part1 :: String -> Int
part1 = solvePart1 . parsePart 2 adds a delightful twist: now we need to consider the joltages—those power requirements we ignored in Part 1. Each button press consumes power from specific joltage sources, and we need to find the minimum number of button presses that both:
For example, if joltage 0 must total exactly 7, and buttons
(0,2) and (1,3) both draw from joltage 0,
then we need to press those buttons a combined total of 7 times. The
challenge is finding a combination of button presses that satisfies
all joltage constraints simultaneously while minimizing total
presses.
This transforms our simple BFS problem into something much more sophisticated: a constrained optimization problem.
Unfortunately I couldn’t solve part 2 initially… So instead here’s a picture of my dog:
This is Hugo from the future! I’ve finally been able to link Z3 with Haskell on my MacBook. I’m relatively new to Z3 and SMT (Satisfiability Modulo Theories) solvers in general, so this was a great learning opportunity.
What’s an SMT solver? Think of it as a constraint satisfaction engine on steroids. You describe your problem as a set of mathematical constraints (equations, inequalities, logical formulas), specify what you want to minimize or maximize, and the solver finds a solution that satisfies everything—if one exists.
Z3, developed by Microsoft Research, is one of the most powerful SMT solvers available. It’s used for everything from program verification to test case generation. And for our puzzle? It’s perfect!
The key insight is recognizing this as a system of linear equations with an optimization goal. Let’s break it down:
Variables: For each button i, let
button_i represent the number of times we press it.
Objective function (what we want to minimize):
total_presses = button_0 + button_1 + ... + button_nConstraints (conditions that must be satisfied):
Non-negativity: We can’t press a button a negative number of times
button_i ≥ 0 (for all i)Joltage requirements: For each joltage source, the sum of button presses that draw from that source must equal the required total
Σ(button_i where button i affects joltage j) = joltage_jFor example, if buttons 2, 5, and 7 all draw from joltage source 3, and joltage 3 requires 15 total power, then:
button_2 + button_5 + button_7 = 15This is a classic Integer Linear Programming (ILP) problem—and Z3 excels at solving these!
First, we need to extract our linear equations from the puzzle input. For each joltage source, we identify which buttons affect it.
Remember: button index i in the buttons list affects
joltage j if j appears in that button’s
list. So for joltage source 2, we scan through all buttons looking for
those that mention index 2.
The result is a list of tuples:
(required_joltage, [button_indices]) where each tuple
represents one constraint equation.
getLinearEquations :: Light -> [(Int, [Int])]
getLinearEquations (Light _ buttons joltages) =
flip map (enumerated joltages) $ \(jix, joltage) ->
let buttons' = (enumerated buttons)
& filter (any (== jix) . snd)
& map fst
in (joltage, buttons')
enumerated :: [b] -> [(Int, b)]
enumerated = zip [0..]Now comes the fun part: encoding our problem in Z3. The Haskell
bindings are… let’s say “functional but verbose.” Everything is done
monadically through the Z3 monad, which handles the
interaction with the underlying solver.
script :: Light -> Z.Z3 Int
script light@(Light _ buttons _) = doStep 1: Create decision variables
We create one integer variable per button. These represent our unknowns—the number of times each button will be pressed in the optimal solution.
vars <- forM [0..length buttons - 1] $ Z.mkFreshIntVar . showStep 2: Add non-negativity constraints
Each variable must be ≥ 0 since we can’t press a button a negative
number of times. We use Z.optimizeAssert to add each
constraint to our optimization problem.
forM_ vars $ \var ->
Z.optimizeAssert =<< Z.mkGe var =<< Z.mkIntNum 0Step 3: Add joltage equality constraints
For each joltage equation we extracted earlier, we tell Z3: “the sum of these specific button presses must equal this joltage value.” This is the heart of our constraint system.
-- for each equation
forM_ (getLinearEquations light) $ \(joltage, buttons) -> do
let buttonVars = map (vars !!) buttons
buttonSum <- Z.mkAdd buttonVars
-- the sum of the buttons must be equal to the joltage
Z.optimizeAssert =<< Z.mkEq buttonSum =<< Z.mkIntNum joltageStep 4: Define the optimization goal and solve
We create an expression representing the total button presses (sum of all variables), tell Z3 to minimize it, then run the solver. If a solution exists, we extract the value assigned to each variable and sum them up.
goal <- Z.mkAdd vars
Z.optimizeMinimize goal
_ <- Z.optimizeCheck []
m <- Z.optimizeGetModel
res <- sum . catMaybes <$> mapM (Z.evalInt m) vars
return $ fromInteger resThe verbosity is unfortunate (those nested mkEq and
mkIntNum calls!), but the elegance of the approach shines
through: we’ve transformed a complex search problem into a declarative
specification that Z3 can solve optimally.
The final step is straightforward: run our Z3 script for each light
and sum the results. We use Z.evalZ3 to execute the Z3
monad and get back our answer.
solvePart2 :: [Light] -> IO Int
solvePart2 = fmap sum . mapM (Z.evalZ3 . script)
part2 :: String -> Int
part2 = unsafePerformIO . solvePart2 . parseNote on unsafePerformIO: Normally
mixing IO into pure functions is dangerous, but here it’s safe because
Z3 solving is referentially transparent—given the same input, it
always produces the same output with no side effects we care about. We
use unsafePerformIO purely to maintain a consistent API
with Part 1.
The beauty of this approach is its generality. Once you’ve modeled your problem as constraints and an objective function, Z3 handles all the complexity of finding an optimal solution. No manual search algorithms, no clever heuristics—just declarative problem specification and powerful automated reasoning. This is why SMT solvers are such a fundamental tool in modern software engineering and formal methods!
Day 11 presents us with a network topology puzzle! We’re given a list of network devices and their connections, forming a directed acyclic graph (DAG). Each line describes which devices a particular node connects to.
Here’s a simplified example of the input format:
a: you
you: c d
c: out
d: outThis describes a network where device a connects to
you, device you has two outgoing connections
to c and d, and both c and
d connect to the final destination out.
Our task for Part 1: count all possible paths from
the starting node "you" to the destination node
"out". In the example above, there are 2 paths: -
you → c → out - you → d → out
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module Day11 where
import Data.Text (Text)
import Data.Text qualified as Text
import System.IO (readFile')
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as Map
import Data.Maybe (catMaybes, fromMaybe)
import Control.Monad.State.Strict (State)
import Debug.Trace (traceShow, trace)
import Text.Printf (printf)We’re using Text for efficient string handling (device
IDs can be arbitrary strings), and HashMap for fast O(log
n) lookups when traversing the graph—much better than linear searches
through lists!
The model is straightforward: we represent the entire network as a mapping from each device ID to its list of outgoing connections.
Parsing is mercifully simple: each line has a device ID followed by
a colon, then a space-separated list of devices it connects to. We
strip the trailing colon with Text.init and collect the
rest as a list of outgoing connections.
type DeviceId = Text
type Connections = HashMap DeviceId [DeviceId]
parse :: String -> Connections
parse = Map.fromList . map parseConnections . Text.lines . Text.pack
where
parseConnections :: Text -> (DeviceId, [DeviceId])
parseConnections line =
let (deviceId:others) = Text.words line
in ((Text.init deviceId), others)Here’s where things get interesting. The naive approach—recursively
exploring every path from start to end—would repeatedly recompute the
same subproblems. If device c is reachable from multiple
places in the network, we’d count all paths from c to
out multiple times!
Dynamic programming to the rescue! We’ll use memoization to cache the number of paths from each device to our destination. The first time we visit a device, we compute its path count and store it. Every subsequent visit just looks up the cached value.
Think of it as working backwards from the destination: - The destination itself has exactly 1 path (the empty path) - Any device that connects directly to the destination has as many paths as it has outgoing edges to the destination - Any other device has paths equal to the sum of paths from all its children
This is essentially a depth-first search with memoization, a classic DP technique for DAGs.
The countConnections function implements our memoized
DFS. Let’s break down what’s happening:
Initial cache setup: We start with a clever
optimization—any device that connects directly to end
already has at least one path. We pre-populate the cache by counting
direct connections to the end node for every device.
The buildMap recursion handles three
cases:
{end: 1}foldl'The fold accumulates the cache as we explore, ensuring each device is only computed once. When we’re done, we look up our starting device in the final cache to get the total path count.
countConnections :: Connections -> DeviceId -> DeviceId -> Int
countConnections grid start end =
let cache = Map.filter (> 0) . fmap (length . filter (== end)) $ grid
newCache = buildMap start cache
in newCache Map.! start
where
buildMap :: DeviceId -> HashMap DeviceId Int -> HashMap DeviceId Int
buildMap device cache
| device == end = Map.singleton end 1
| Map.member device cache = cache
| otherwise =
let children = fromMaybe [] $ grid Map.!? device
combine = flip buildMap
childrensMap = foldl' combine cache children
childrenCount = sum . catMaybes . map (flip Map.lookup childrensMap) $ children
in Map.insert device childrenCount $ childrensMap
solvePart1 :: Connections -> Int
solvePart1 graph = countConnections graph "you" "out"
part1 :: String -> Int
part1 = solvePart1 . parsePart 2 cranks up the complexity: now we need to count only paths
from "svr" to "out" that pass through
both "fft" and "dac"
devices. Not just one or the other—both!
At first glance, this seems like we need a completely different algorithm. But there’s an elegant mathematical trick we can use: the inclusion-exclusion principle.
Think about it in terms of set operations. We want paths that include both checkpoints, which is equivalent to:
allPaths - pathsWithoutDac - pathsWithoutFft + pathsWithoutEither
Why does this work? - Start with all paths from svr to out - Subtract paths that don’t go through dac (removes all paths missing that checkpoint) - Subtract paths that don’t go through fft (removes all paths missing that checkpoint) - Add back paths that avoid both (we subtracted these twice, so we need to add them once)
This is the classic inclusion-exclusion formula: |A ∩ B| = |U| - |Ā| - |B̄| + |Ā ∩ B̄|
And the beautiful part? We can compute “paths that avoid X” by simply removing X from the graph and counting paths normally!
solvePart2 :: Connections -> Int
solvePart2 graph = all - noDac - noFft + noDacNoFft
where
all = countConnections graph "svr" "out"
noDac = countConnections (Map.delete "dac" graph) "svr" "out"
noFft = countConnections (Map.delete "fft" graph) "svr" "out"
noDacNoFft = countConnections (Map.delete "dac" $ Map.delete "fft" $ graph) "svr" "out"There’s another way to think about this problem that’s perhaps more intuitive. Any path that goes through both dac and fft must visit them in some order:
svr → ... → dac → ... → fft → ... → outsvr → ... → fft → ... → dac → ... → outThese are mutually exclusive cases (you can’t visit dac before fft and fft before dac in the same path), so we can count them separately and add the results.
For the first case, we need:
(paths from svr to dac) × (paths from dac to fft) × (paths from fft to out)
Why multiplication? Because each path in the first segment can be paired with each path in the second segment, and each of those combinations can be paired with each path in the third segment. That’s the fundamental counting principle!
Similarly for the second case. Add them together:
solvePart2' :: Connections -> Int
solvePart2' graph = paths "svr" "dac" * paths "dac" "fft" * paths "fft" "out"
+ paths "svr" "fft" * paths "fft" "dac" * paths "dac" "out"
where
paths = countConnections graph
part2 :: String -> Int
part2 = solvePart2 . parseThis alternative formulation is arguably clearer—it directly
expresses the structure of the paths we’re counting. Both solutions
produce the same answer, but I find the inclusion-exclusion approach
(solvePart2) more elegant and generalizable. If we needed
to check for three or four required checkpoints, the combinatorial
explosion of cases in the subpath approach would get messy fast, while
inclusion-exclusion scales gracefully.
Day 12 brings us a festive packing puzzle! We’re playing Santa’s logistics coordinator, trying to figure out which Christmas trees have enough space underneath to hold all their designated presents.
The input gives us two things: a catalog of present shapes and a list of trees with their packing requirements.
Each present is defined by its shape on a 2D grid:
0:
###
##.
##.The first line shows the present’s index (0 in this
case). The following rows describe the shape, where #
represents solid present and . represents empty space.
This present occupies 5 cells.
Trees are specified with their dimensions and the presents they need to hold:
4x4: 0 0 0 0 2 0This tree has a 4×4 grid of space underneath (16 cells total), and
needs to accommodate: four copies of present 0, one copy
of present 2, and one copy of present 0
again.
Our task: Determine which trees have sufficient area to fit all their assigned presents.
module Day12 where
import Data.List (unsnoc)
import Data.Bifunctor (bimap)
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import Control.Arrow ((>>>))
import System.IO (readFile')The model is straightforward: we represent each present as a 2D
grid of booleans, where True indicates a solid cell.
Trees track their dimensions and the list of present indices they need
to hold.
type Present = [[Bool]]
data Tree =
Tree { _width :: Int
, _height :: Int
, _presents :: [Int]
} deriving (Show)
type Problem = ([Present], [Tree])Parsing follows the input structure: we split on double newlines to
separate the present catalog from the tree list. Each present’s shape
is converted to a grid of booleans by testing for '#'
characters. Tree parsing extracts dimensions from the
WxH: prefix and reads the space-separated present
indices.
parse :: String -> Problem
parse = splitOn "\n\n"
>>> unsnoc
>>> fromMaybe undefined
>>> bimap (map parsePresent)
(map parseTree . lines)
where
parsePresent :: String -> Present
parsePresent = lines >>> tail >>> map (map (== '#'))
parseTree :: String -> Tree
parseTree str = let (fst:presents) = splitOn " " str
(width, height) = break (== 'x') (init fst)
in Tree (read width) (read (drop 1 height)) (map read presents)At first glance, this might look like the classic knapsack problem—we need to fit items into a container. But it’s actually harder! This is a 2D bin packing problem, where we need to arrange irregularly-shaped presents within a rectangular space.
The general version of this problem is NP-complete. A proper solution would need to:
This could involve sophisticated algorithms like genetic algorithms, simulated annealing, or branch-and-bound search. For large inputs, even approximate solutions are challenging!
Here’s where things get interesting. After examining the actual puzzle input, I noticed something: for every tree in the input, a simple area check is sufficient. That is, if the sum of all present areas is less than or equal to the tree’s total area, then those presents will actually fit when properly arranged.
This suggests the puzzle author deliberately crafted the input to avoid the NP-complete complexity. Perhaps the presents are designed to pack efficiently, or the tree spaces are generous enough that optimal packing isn’t required. Either way, we can solve Part 1 with a straightforward area comparison!
The solution filters trees by checking if their total area can
accommodate all assigned presents. We pre-compute each present’s area
(counting True cells in its grid), then for each tree,
sum up the areas of its required presents and compare against the
tree’s dimensions.
solvePart1 :: Problem -> Int
solvePart1 (presents, trees) = length $ filter (fitsAllPresents) trees
where
fitsAllPresents :: Tree -> Bool
fitsAllPresents (Tree width height presents') =
let totalPresentsArea = foldl' (\acc (ix, count) -> acc + (count * (presentsArea !! ix))) 0 (zip [0..] presents')
totalArea = width * height
in totalPresentsArea <= (totalArea)
presentsArea = map (length . filter id . concat) presents
part1 :: String -> Int
part1 = solvePart1 . parseThis elegant simplification turns an intractable problem into an O(n) solution. Sometimes the best algorithm is recognizing when you don’t need one!
There is no Part 2, part 2 is the stars we collected along the way (:
I hope this has been useful to you, if it was please consider leaving a star in the repo.
Merry Christmas,
Hugo Vilela