Advent of Code 2025
in Haskell
by Hugo Vilela
December 2025

Day 1

Part 1

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 where

Parsing the Input

Let’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 _ = undefined

Solving Part 1

To solve this, we’ll fold over the list of rotations while maintaining a tuple of (count, currentRotation):

After 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 . parse

Part 2

Part 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 Algorithm

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)

Counting Zero Crossings

The numberOfClicks function calculates how many times we pass through zero during a single rotation.

The logic breaks down as follows:

  1. Normalize the current position to be in range [0, 99]
  2. Calculate complete rotations: Dividing the rotation amount by 100 gives us how many full loops around the dial we make (totalRotations)
  3. Check the remainder: After the complete rotations, does the remainder push us through 0?
    • Right rotation: We pass through 0 if currentPos + remainder >= 100
    • Left rotation: We pass through 0 if we’re not already at 0 and currentPos - remainder <= 0
numberOfClicks :: 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 0

Handling Negative Positions

One 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` 100

With all the pieces in place, Part 2 comes together:

part2 :: String -> Int
part2 = solvePart2 . parse

Day 2

Part 1

Today’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:

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module Day02 where

import qualified Data.Text as T
import Control.Arrow ((>>>))
import Data.Function ((&))
import Data.List.Split (chunksOf)

Parsing

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 Solution

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 == snd

Part 2

Part 2 generalizes the pattern: now an ID is invalid if it consists of any repeating segment, not just two halves. For example:

The Key Insight

We 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 [] = True

Day 3

Part 1

The Problem

Today’s input gives us rows of digits—think of each row as a “bank of batteries”:

987654321111111
811111111111119
234234234234278
818181911112111

Each 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)

The Solution

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

Part 2 escalates things: now we need to pick 12 digits to form a 12-digit number, and maximize that.

The Greedy Insight

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.

Implementation

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))
          & getSum

Day 4

Part 1

Today’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.V2

Data Representation

We’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

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) $ grid

The 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 . parse

Part 2

Part 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.

The Iterative Approach

This is a classic fixed-point iteration. Each round, we:

  1. Identify accessible rolls (using our Part 1 logic)
  2. Remove them from the grid
  3. Repeat until the grid stops changing

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 . parse

Day 5

Part 1

Today’s puzzle gives us a database containing two pieces of information:

  1. A list of valid ranges (e.g., 100-500, 600-1000)
  2. A list of ID numbers to check

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)

Data Model

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)

Parsing

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')

The Solution

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 . parse

Part 2

Part 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 Sorting Insight

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 . parse

Day 6

Part 1

Today’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 ((&))

Part 1 Solution

The algorithm is straightforward:

  1. Split the input into rows and the final operations line
  2. Parse each row as space-separated numbers
  3. Transpose to get columns instead of rows
  4. Zip operations with columns and apply each operation
  5. Sum the results
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 matrix

Operations

We support two operations: sum (+) and product (*).

getOp :: String -> [Int] -> Int
getOp "+" = sum
getOp "*" = product
getOp _ = error "unreachable"

Part 2

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 Solution

The key difference is in how we process the transposed data:

  1. Strip whitespace from each cell
  2. Split on empty strings to get groups
  3. Parse each group as numbers
  4. Apply operations as before
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 numbers

Helper Functions

We 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 : remaining

Day 7

Part 1

Today’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)

Data Model

We need to track:

data Instructions = Instructions {
  _start :: (Int, Int),
  _tachyons :: HashMap Int [Int]  -- maps column x to list of y coordinates
} deriving (Show)

Parsing

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 tachyons

Helper: Grouping

A 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 rest

The Algorithm

The beam simulation is a recursive traversal:

  1. From the current position (x, y), look up the column and find the next tachyon above the current y-coordinate
  2. If we find one and haven’t visited it yet:
    • Mark it as visited
    • Remove it from the available tachyons
    • Split: recursively simulate beams going left (x-1, newY) and right (x+1, newY)
  3. If no tachyon found or already visited, return the current visited set

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 . parse

Part 2

Part 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 Memoized Solution

The algorithm is similar to Part 1, but now:

solvePart2 :: 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 . parse

Day 8

Part 1

Today’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.0

The 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:

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.empty

We’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 'ProblemState

We alias our computation type as Solver for clarity.

type Solver a = State ProblemState a

Building blocks

Adding 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)

The core algorithm

Now for the heart of the solution: processing a junction pair. Given junctions (a, b), we need to handle five distinct cases:

  1. Only a is connected: Add b to a’s circuit
  2. Only b is connected: Add a to b’s circuit
  3. Both in same circuit: Nothing to do
  4. Both in different circuits: Merge them by moving all junctions from one circuit to the other, then delete the empty circuit
  5. Neither connected: Create a new circuit containing both and increment our ID counter

This 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 nextId

Putting it together

With our machinery in place, Part 1 is straightforward:

  1. Take the 1000 closest junction pairs
  2. Process each pair with our state-modifying function
  3. Find the three largest circuits and multiply their sizes

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

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^._x

Day 9

Part 1

Today’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 . parse

Part 2

Part 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.

A stroke of luck

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:

day09 input svg

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 svg

The solution

Armed 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) $ rectangles

The 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 . parse

Day 10

Part 1

Today’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:

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)

Modeling the problem

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)

Finding the shortest path

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 light

With 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 . parse

Part 2

Part 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:

  1. Achieves the target LED configuration
  2. Uses exactly the specified amount of power from each joltage source

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:

My dog Pepita

SOLVED! Enter the SMT solver

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!

Reframing as constrained optimization

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_n

Constraints (conditions that must be satisfied):

  1. Non-negativity: We can’t press a button a negative number of times

    button_i ≥ 0  (for all i)
  2. 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_j

For 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 = 15

This is a classic Integer Linear Programming (ILP) problem—and Z3 excels at solving these!

Building the constraint system

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..]

Translating to Z3

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 _) = do

Step 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 . show

Step 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 0

Step 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 joltage

Step 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 res

The 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.

Wrapping it up

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 . parse

Note 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

Part 1

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: out

This 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!

Modeling and parsing

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)

Counting paths with dynamic programming

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:

  1. Base case: If we’ve reached the end device, return a cache with just {end: 1}
  2. Cache hit: If we’ve already computed this device’s path count, return the existing cache unchanged
  3. Cache miss: This is where the magic happens:
    • Get all children (devices this one connects to)
    • Recursively build the cache for each child using foldl'
    • Sum up the path counts from all children (that’s the total paths through this device!)
    • Insert this device’s count into the cache

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 . parse

Part 2

Part 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!

The inclusion-exclusion principle

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"

Alternative approach: counting subpaths

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:

These 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 . parse

This 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

Part 1

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 0

This 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')

Modeling the problem

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)

The real problem: 2D bin packing

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:

  1. Try different rotations of each present (if rotation is allowed)
  2. Consider all possible positions for placing each present
  3. Ensure presents don’t overlap with each other
  4. Backtrack when a configuration doesn’t work

This could involve sophisticated algorithms like genetic algorithms, simulated annealing, or branch-and-bound search. For large inputs, even approximate solutions are challenging!

A pragmatic shortcut

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 . parse

This elegant simplification turns an intractable problem into an O(n) solution. Sometimes the best algorithm is recognizing when you don’t need one!

Part 2

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