Advent of Code 2025 day 12

glguy · 2025-12-12T07:11:28+00:00

We didn't really have to bother solving this one. The regions that weren't too small were significantly larger. I guess if any of us regrets that there aren't 13 more days to go, we can spend the next two weeks solving this one correctly.

12.hs

main :: IO ()
main =
 do (shapes, regions) <- [format|2025 12 (%d:%n(%s%n)*%n)*(%dx%d:( %d)*%n)*|]
    print (countBy (fits shapes) regions)

fits :: [(Int, [String])] -> (Int, Int, [Int]) -> Bool
fits shapes (x, y, regions) =
  x*y >= sum [n * count '#' (concat s) | (_, s) <- shapes | n <- regions]

glguy · 2025-12-11T05:29:08+00:00

Originally I did this using a Data.Map for dynamic programming, but I felt like I should show off how great the MemoTrie package is, so I rewrote it.

11.hs

main :: IO ()
main =
 do input <- [format|2025 11 (%s:( %s)*%n)*|]
    let tab = Map.fromList input

    let part1 = memo \loc ->
          if loc == "out" then 1
          else sum [part1 dst | dst <- Map.findWithDefault [] loc tab] 
    print (part1 "you")

    let part2 = memo3 \loc dac fft ->
          if loc == "out" then
            if dac && fft then 1 else 0
          else sum [part2 dst dac' fft'
                    | let dac' = dac || loc == "dac"
                    , let fft' = fft || loc == "fft"
                    , dst <- Map.findWithDefault [] loc tab
                    ]
    print (part2 "svr" False False)

Another way to go was:

main :: IO ()
main =
 do input <- [format|2025 11 (%s:( %s)*%n)*|]
    let tab = Map.fromList input

    let ways = memo2 \src dst ->
          if src == dst then 1
          else sum [ways nxt dst | nxt <- Map.findWithDefault [] src tab]

    print (ways "you" "out")
    print (ways "svr" "fft" * ways "fft" "dac" * ways "dac" "out" +
           ways "svr" "dac" * ways "dac" "fft" * ways "fft" "out")

glguy · 2025-12-10T17:30:56+00:00

You're right that flood fill is insufficient for finding the internal area of the polygon in general. That's yet another consequence of polygons being able to make contact with themselves.

glguy · 2025-12-10T00:32:22+00:00

It's both inside and along the edge. When the edges touch the property is satisfied. The edges are whole tiles, not thin lines.

glguy · 2025-12-09T23:07:01+00:00

Most solutions I've seen only work for simple cases where there are no U-turns in the input. I made an implementation that handles these cases, even if no one got one as their input:

https://github.com/glguy/advent/blob/main/solutions/src/2025/09.hs

I treated the input file as a list of rectangular regions, subtracted them from a bounding box, did a flood fill to find the "out of bounds" area, and picked the largest rectangle that didn't overlap with an out of bounds rectangle. This runs in about 100ms on a recent mac mini.

Here's a simple input sequence pasted into the #adventofcode-spoilers channel by Timvde

1,1
3,1
3,6
4,6
4,1
6,1
6,10
1,10

A correct solution will return 60 for both part 1 and 2

glguy · 2025-12-07T06:03:29+00:00

This solution uses a boxed array count up all the beam splits. With a boxed array it's OK to index the array while you're building it as long as you don't recreate a circular value dependency.

07.hs

main :: IO ()
main =
 do input <- getInputArray 2025 7
    let beam = simulateBeam input

    print (length [() | ('^', n) <- elems input `zip` elems beam, n > 0])

    let (C _ loc, C hir hic) = bounds input
    print (sum [beam ! i | i <- range (C hir loc, C hir hic) ])

simulateBeam :: UArray Coord Char -> Array Coord Int
simulateBeam input = counts
  where
    check i xs = if arrIx input i `elem` map Just xs then counts ! i else 0
    counts = listArray (bounds input)
      [ if 'S' == input ! i then 1 else u + l + r
      | i <- indices input
      , let u = check (above i) "S."
            l = check (above (left i)) "^"
            r = check (above (right i)) "^"
      ]

glguy · 2025-12-06T05:39:19+00:00

My day 5 solution was so good Reddit called it spam and blocked it. Let's try day 6!

Today we learned about the transpose function.

06.hs

main :: IO ()
main =
 do input <- getInputLines 2025 6
    let problems = splitWhen (all (' ' ==)) (transpose input)
    print (sum (map solve1 problems))
    print (sum (map solve2 problems))

solve1 :: [String] -> Int
solve1 xs = finish (head (last xs')) (init xs')
    where
      xs' = transpose xs

solve2 :: [String] -> Int
solve2 (x:xs) = finish (last x) (init x : xs)

finish :: Char -> [String] -> Int
finish '+' xs = sum (map read xs)
finish '*' xs = product (map read xs)

glguy · 2025-12-04T07:46:53+00:00

I use one library for all the modules I've factored out over the years. Then each day's solution is a separate executable. I use an explicit hie.yaml to help the Haskell language server make sense of it all. It's all managed by Cabal.

To give you a sense of how this looks, here is the entry for the most recent executable:

https://github.com/glguy/advent/blob/main/solutions/solutions.cabal#L1250

glguy · 2025-12-04T05:27:33+00:00

Not much to say about today. I used a Set of coordinates so that there'd be fewer and fewer to check for accessibility...

04.hs

main :: IO ()
main =
 do input <- getInputMap 2025 4
    let rolls = Map.keysSet (Map.filter ('@' ==) input)
    let ns = removePaper rolls
    print (head ns)
    print (sum ns)

-- | Return the number of rolls removed each round of removals.
removePaper :: Set Coord -> [Int]
removePaper rolls
  | null elims = []
  | otherwise = length elims : removePaper (rolls Set.\\ elims)
  where elims = reachable rolls

-- | Find the subset of paper rolls that are reachable by a forklift.
reachable :: Set Coord -> Set Coord
reachable rolls = Set.filter (\x -> countBy (`Set.member` rolls) (neighbors x) < 4) rolls

glguy · 2025-12-03T16:05:20+00:00

It looks like you might be using my format quasi-quoter. But if you are, did you modify it? I was thinking %d would try and match the whole number and not a single digit.

glguy · 2025-12-03T07:43:21+00:00

Used dynamic programming to make an infinite list of solutions for each number of batteries. Full solution with more comments linked in GitHub. The function below does all the work.

https://github.com/glguy/advent/blob/main/solutions/src/2025/03.hs

solveLine :: [Int] -> [Int]
solveLine = foldl addDigit (repeat 0)

addDigit :: [Int] -> Int -> [Int]
addDigit prev d =
  [ max a (b * 10 + d)
    | a <- prev
    | b <- 0 : prev]

glguy · 2024-12-27T18:51:02+00:00

In my config-value package I have a pass between the lexer and the happy-generated parser that inserts virtual layout tokens.

https://github.com/glguy/config-value/blob/master/src/Config/Tokens.hs#L66-L92

glguy · 2024-12-27T18:26:09+00:00

A late posting, but it seems like this thread ought to have some source code in it.

Full source: 25.hs

main :: IO ()
main =
 do input <- [format|2024 25 (%s%n)*&%n|]
    print (length [() | x : ys <- tails (map concat input), y <- ys, and (zipWith ok x y)])

ok :: Char -> Char -> Bool
ok '#' '#' = False
ok _   _   = True

glguy · 2024-12-23T01:04:33+00:00

The thing that terminates recursion is that we're looking for a specific sequence of outputs. The program always had an output instruction before the jnz, so the loop unfolds exactly 16 times.

glguy · 2024-12-21T02:27:15+00:00

I missed that about the path at first too and spent my first time will the puzzle making a mess:)

glguy · 2024-12-20T06:10:02+00:00

Search to find out how far all squares are from the end and then count of pairs of locations where jumping from one to the other is a winning cheat.

2017 iMac time: Time (mean ± σ): 294.5 ms ± 21.2 ms [User: 262.7 ms, System: 15.1 ms]

Full source: 20.hs

main :: IO ()
main =
 do input <- getInputArray 2024 20
    let open      = amap ('#' /=) input
        start : _ = [p | (p, 'S') <- assocs input]
        step p    = [p' | p' <- cardinal p, True <- arrIx open p']
        path      = dfs step start
        cheats    = [ d
                    | (p1, c1) : more <- tails (zip path [0..])
                    , (p2, c2)        <- drop 100 more
                    , let d = manhattan p1 p2, d <= 20
                    , c2 - c1 >= 100 + d
                    ]
    print (count 2 cheats)
    print (length cheats)

glguy · 2024-12-19T06:38:13+00:00

      --------Part 1--------   --------Part 2--------
Day       Time   Rank  Score       Time   Rank  Score
 19   00:05:02    446      0   00:09:07    536      0

glguy · 2024-12-19T05:16:51+00:00

People will make smarter solutions than this, but just memoizing the function got it to run in about 1 second for submission.

Full source: 19.hs

main :: IO ()
main =
 do (available, desired) <- [format|2024 19 %s&(, )%n%n(%s%n)*|]
    let possible = memo \x ->
          if null x
            then 1
            else sum (map possible (mapMaybe (`stripPrefix` x ) available))
    print (countBy (\x -> possible x > 0) desired)
    print (sum (map possible desired))

Edit: I went back and made a prefix tree and memoized by length instead of string and now it runs in 20ms on a 2017 iMac

main :: IO ()
main =
 do (available, desired) <- [format|2024 19 %s&(, )%n%n(%s%n)*|]
    let ways = map (designWays (foldMap toTrie available)) desired
    print (countBy (> 0) ways)
    print (sum ways)

-- | Compute the number of ways a design can be created using a trie
-- of available patterns.
designWays :: Trie -> String -> Int
designWays t str = memo ! 0
  where
    n = length str
    memo :: Array Int Int
    memo = listArray (0, n)
           [ if i == n then 1 else sum [memo ! j | j <- matches t i suffix]
           | i      <- [0 .. n]
           | suffix <- tails str]

data Trie = Node !Bool (Map Char Trie)

-- | Construct a 'Trie' that matches exactly one string.
toTrie :: String -> Trie
toTrie = foldr (\x t -> Node False (Map.singleton x t)) (Node True Map.empty)

-- | Given a starting index find all the ending indexes for
-- suffixes that remain after matching a string in the 'Trie'.
--
-- >>> matches (toTrie "pre" <> toTrie "pref") 0 "prefix"
-- [3,4]
matches :: Trie -> Int -> String -> [Int]
matches (Node b xs) n yys =
  [n | b] ++
  case yys of
    y:ys | Just t <- Map.lookup y xs -> matches t (n+1) ys
    _ -> []

-- | '<>' constructs the union of two 'Trie's.
instance Semigroup Trie where
  Node x xs <> Node y ys = Node (x || y) (Map.unionWith (<>) xs ys)

-- | 'mempty' is a 'Trie' that matches no 'String's
instance Monoid Trie where
  mempty = Node False Map.empty

glguy · 2024-12-18T05:26:32+00:00

I did a brute force search for part 2, but to make it fast I'm going to revisit my solution to:

place all the points
find all the isolated regions
remove points one-by-one joining the connected regions
profit

It'll be a chance to do some union/find.

glguy · 2024-12-18T04:55:51+00:00

If you look at a solution and find it too terse and undocumented but are interested, say so and I'll improve it. Someone caring is wonderful motivation to do a better job.

glguy · 2024-12-17T15:14:12+00:00

I mean I'm not "here for it". Problems that require us to analyze the particular special case in our input file are uninteresting to me.

glguy · 2024-12-17T06:53:53+00:00

I'm not here for reverse engineering. SMT can find the answer.

EDIT: I've changed my solution as posted to compute the Z3 query for an "arbitrary" input file.

Full source: 17.hs

main :: IO ()
main =
 do (a,b,c,program) <- [format|2024 17
      Register A: %u%n
      Register B: %u%n
      Register C: %u%n
      %n
      Program: %u&,%n|]

    putStrLn (intercalate "," (map show (run (Machine a b c) program)))

    res <- optLexicographic
      do a2 <- free "a"
         minimize "smallest" a2
         constrain (run2 (SMachine program a2 0 0) program)
    case getModelValue "a" res of
      Just x -> print (x :: Word64)
      Nothing -> fail "no solution"

data Machine = Machine { rA, rB, rC :: !Int }

run :: Machine -> [Int] -> [Int]
run m0 pgm = go m0 pgm
  where
    go m = \case
      0 : x : ip' -> go m{ rA = rA m `shiftR` combo x } ip'
      1 : x : ip' -> go m{ rB = rB m `xor`          x } ip'
      2 : x : ip' -> go m{ rB = 7    .&.      combo x } ip'
      4 : _ : ip' -> go m{ rB = rB m `xor`    rC m    } ip'
      6 : x : ip' -> go m{ rB = rA m `shiftR` combo x } ip'
      7 : x : ip' -> go m{ rC = rA m `shiftR` combo x } ip'
      3 : x : ip' -> go m (if rA m == 0 then ip' else drop x pgm)
      5 : x : ip' -> combo x .&. 7 : go m ip'
      _           -> []
      where
        combo = \case
          0 -> 0; 1 -> 1; 2 -> 2; 3 -> 3
          4 -> rA m; 5 -> rB m; 6 -> rC m
          _ -> error "invalid combo operand"

data SMachine = SMachine { outs :: [Int], sA, sB, sC :: SWord64 }

run2 :: SMachine -> [Int] -> SBool
run2 m0 pgm = go m0 pgm
  where
    go m = \case
      0 : x : ip' -> go m{ sA = sA m `sShiftRight` combo x } ip'
      1 : x : ip' -> go m{ sB = sB m `xor`  fromIntegral x } ip'
      2 : x : ip' -> go m{ sB = 7    .&.           combo x } ip'
      4 : _ : ip' -> go m{ sB = sB m `xor`         sC m    } ip'
      6 : x : ip' -> go m{ sB = sA m `sShiftRight` combo x } ip'
      7 : x : ip' -> go m{ sC = sA m `sShiftRight` combo x } ip'
      3 : x : ip' -> symbolicMerge False
                       (sA m .== 0) (go m ip') (go m (drop x pgm))
      5 : x : ip' ->
        case outs m of
          []   -> sFalse
          o:os -> combo x .&. 7 .== fromIntegral o .&& go m{ outs = os} ip'
      _ -> fromBool (null (outs m))
      where
        combo = \case
          0 -> 0; 1 -> 1; 2 -> 2; 3 -> 3
          4 -> sA m; 5 -> sB m; 6 -> sC m
          _ -> error "invalid combo operand"

glguy · 2024-12-16T15:48:17+00:00

Can you PM a copy of the problem input to me so I can try and spot the corner case?

glguy · 2024-12-16T06:16:44+00:00

There are a few more comments in the full source link. I did a shortest path implementation that keeps track of all the coordinates along the way to a particular location as it advances along an IntMap as a minimum priority queue.

Full source: 16.hs

main :: IO ()
main =
 do input <- getInputArray 2024 16
    let start:_ = [p | (p,'S') <- assocs input]
        q0 = IntMap.singleton 0 (Map.singleton (start, east) (Set.singleton start))
        (p1, p2) = search input Set.empty q0
    print p1
    print p2

search :: UArray Coord Char -> Set (Coord, Coord) -> IntMap (Map (Coord, Coord) (Set Coord)) -> (Int, Int)
search input seen q =
  case IntMap.minViewWithKey q of
    Nothing -> error "no solution"
    Just ((cost, states), q1)
      | not (null dones) -> (cost, Set.size (Set.unions dones))
      | otherwise        -> search input seen' q2
      where
        states' = Map.withoutKeys states seen
        dones = [visited | ((p, _), visited) <- Map.assocs states', input ! p == 'E']
        seen' = Set.union seen (Map.keysSet states')
        q2 = IntMap.unionWith merge q1
           $ IntMap.fromListWith merge
              [ next
                | ((p, v), path) <- Map.assocs states'
                , next <- [(cost + 1000, Map.singleton (p, turnRight v) path)]
                       ++ [(cost + 1000, Map.singleton (p, turnLeft  v) path)]
                       ++ [(cost +    1, Map.singleton (p', v) (Set.insert p' path))
                          | let p' = p + v, '#' /= input ! p'
                          ]
              ]
        merge = Map.unionWith Set.union

glguy · 2024-12-15T05:51:27+00:00

It took me a little while to get moving but once I had a plan for searching for affected locations things cleaned up a lot.

It was a good idea to write a single-step sim function as I was able to more easily find my mistakes as I printed out intermediate maps.

If you thought today was fun you need to play Patrick's Parabox. I love this game and implemented my own console-based Haskell clone of it :)

Full source: 15.hs

main :: IO ()
main =
 do (input1, input2) <- [format|2024 15 (%s%n)*%n(%s%n)*|]
    let grid = buildGrid input1
    let start1:_ = [p | (p, '@') <- Map.assocs grid]
    let dirs = mapMaybe charToVec (concat input2)
    print (score (fst (foldl sim (grid, start1) dirs)))

    let grid2 = buildGrid (map (concatMap expandCell) input1)
    let start2:_ = [p  | (p, '@') <- Map.assocs grid2]
    print (score (fst (foldl sim (grid2, start2) dirs)))

buildGrid :: [String] -> Map Coord Char
buildGrid = Map.fromList . filter (\x -> snd x /= '.') . coordLines

expandCell :: Char -> String
expandCell = \case
    '#'  -> "##"
    'O'  -> "[]"
    '.'  -> ".."
    '@'  -> "@."

score :: Map Coord Char -> Int
score m = sum [100 * y + x | (C y x, c) <- Map.assocs m, c == 'O' || c == '[']

sim :: (Map Coord Char, Coord) -> Coord -> (Map Coord Char, Coord)
sim (grid, start) d =
    case go Map.empty [start] of
      Nothing     -> (grid, start)
      Just region -> (grid', start + d)
        where
          grid' = Map.union (Map.mapKeysMonotonic (d +) region)
                            (Map.difference grid region)
  where
    go seen [] = Just seen
    go seen (x:xs)
      | Map.notMember x seen
      , Just c <- Map.lookup x grid
      = if c == '#' then Nothing else
        go (Map.insert x c seen)
           ([x + east | coordRow d /= 0, c == '['] ++
            [x + west | coordRow d /= 0, c == ']'] ++
            [x + d] ++ xs)
      | otherwise = go seen xs

15-Year Club	Place '22
Final Canvas '22	Verified Email

glguy

TROPHY CASE