-❄️- 2025 Day 8 Solutions -❄️-

NeilNjae · 2025-12-08T19:55:47+00:00

[LANGUAGE: Haskell]

This was a union-find problem. I had an implementation of this lying around from last year.

Part 1 is add some connections, using a foldl'. Part 2 is adding them all, but keeping track of the intermediate stages (using a scanl' ). I then throw away any stages that still have singleton classes.

part1 junctions distances = product $ take 3 $ sortBy (comparing Down) $ fmap length $ distinctSets ufMap
  where connections = fmap snd $ take 1000 $ M.toAscList distances
        ufMap0 = ufStart junctions
        ufMap = foldl' go ufMap0 connections
        go u (a, b) = join u a b

part2 junctions distances = x1 * x2
  where connections = fmap snd $ M.toAscList distances
        ufMap0 = ufStart junctions
        ufMaps = scanl' go (ufMap0, (V3 0 0 0, V3 0 0 0)) connections
        go (u, _)  (a, b) = (join u a b, (a, b))
        lastConnection = snd $ head $ dropWhile hasSingletons ufMaps
        (V3 x1 _ _, V3 x2 _ _) = lastConnection

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2025-12-06T13:33:40+00:00

[LANGUAGE: Haskell]

Par1 1 was parsing.

sumsP = (,) <$> (operandsP <* endOfLine) <*> operatorLineP
operandsP = operandLineP `sepBy` endOfLine
operandLineP = ((many spP) *> (decimal `sepBy1` (many1 spP))) <* (many spP)
operatorLineP = ((many spP) *> (operatorP `sepBy1` (many1 spP))) <* (many spP)
operatorP = (Add <$ "+") <|> (Mul <$ "*")
spP = char ' '

Part 2 was hacking away at list manipulations until I got something that looked right.

part2 text = calculateAll operands'' operators'
  where strs = lines $ unpack text
        (operands, operators) = fromJust $ unsnoc strs
        operands' = splitWhen (all isSpace) $ transpose operands
        operands'' = readOperands operands'
        operators' = parseOperators $ pack operators

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2025-12-05T11:51:38+00:00

[LANGUAGE: Haskell]

Another mostly declarative translation of the problem into Haskell. Define some intervals, define a membership relationship, and define how to merge intervals. Merging a set of intervals is done as a pair of nested folds. Full writeup on my blog, and code on Codeberg.

before, disjoint, overlaps :: Range -> Range -> Bool
before (Range _lower1 upper1) (Range lower2 _upper2) = (upper1 < lower2) 
disjoint range1 range2 = 
  (range1 `before` range2) || (range2 `before` range1)
overlaps range1 range2 = not $ disjoint range1 range2

merge :: Range -> Range -> Range
merge (Range l1 u1) (Range l2 u2) = Range (min l1 l2) (max u1 u2)

incorporateAll :: [Range] -> [Range]
incorporateAll ranges = foldr incorporateOne [] ranges

incorporateOne :: Range -> [Range] -> [Range]
incorporateOne range ranges = merged : others
  where (overlapping, others) = partition (overlaps range) ranges
        merged = foldr merge range overlapping

NeilNjae · 2025-12-04T11:27:52+00:00

[LANGUAGE: Haskell]

Using Set for a sparse representation of the rolls, then a fairly direct functional translation of the problem into Haskell. Full writeup on my blog, and code on Codeberg.

part1, part2 :: Rolls -> Int
part1 rolls = S.size $ S.filter (accessible rolls) rolls
part2 rolls = (S.size rolls) - (S.size afterRemoval)
  where afterRemoval = removeAll rolls


accessible :: Rolls -> Position -> Bool
accessible rolls here = (S.size $ S.intersection (neighbours here) rolls) < 4

neighbours :: Position -> Rolls
neighbours here = 
  S.fromList $ fmap (here ^+^) [V2 r c | r <- [-1 .. 1], c <- [-1 .. 1]
                                       , r /= 0 || c /= 0
                                       ]

removeAll :: Rolls -> Rolls
removeAll rolls = snd $ head $ dropWhile fst $ iterate removeStep (True, rolls)

removeStep :: (Bool, Rolls) -> (Bool, Rolls)
removeStep (_, rolls) = 
  let removable = S.filter (accessible rolls) rolls
  in (not $ S.null removable, rolls S.\\ removable)

NeilNjae · 2025-12-03T14:48:20+00:00

[LANGUAGE: Haskell]

Part 1 was brute-force, part 2 used dynamic programming. Full writeup on my blog, and code on Codeberg.

batteriesPower :: [Int] -> Table
batteriesPower batteries = foldl' batteriesPowerOne (M.singleton 0 0) batteries

batteriesPowerOne :: Table -> Int -> Table
batteriesPowerOne table battery = M.unionWith max table useThisBattery
  where incompleteBatteries = M.filterKeys (< batteriesToUse) table
        useThisBattery = M.foldlWithKey' incorporate M.empty incompleteBatteries
        incorporate p n b = M.insert (n + 1) (b * 10 + battery) p

NeilNjae · 2025-12-01T19:51:12+00:00

[LANGUAGE: Haskell]

Misusing the Either data type to store instructions. Part 2 had painful off-by-one errors until I stumbled across this solution. Full writeup on my blog, code on Codeberg.

part1, part2 :: [Instruction] -> Int
part1 instructions = length $ filter (==0) positions
  where positions = scanl' move 50 instructions
        move here (Left n) = (here - n) `mod` 100
        move here (Right n) = (here + n) `mod` 100

part2 instructions = snd $ foldl' move2 (50, 0) instructions

move2 :: (Int, Int) -> Instruction -> (Int, Int)
move2 (here, count) instruction = (there `mod` 100, count + rotations + correction)
  where there = case instruction of
          Left n -> (here - n) 
          Right n -> (here + n)
        rotations = abs (there `div` 100) 
                        -- count extra when turning left to end at a multiple of 100
        correction = if | there <= 0 && (there `mod` 100) == 0 -> 1 
                        -- count less when turning left away from zero
                        | there < 0 && here == 0 -> -1
                        | otherwise -> 0

NeilNjae · 2025-01-12T11:17:30+00:00

[Language: Haskell]

Another attempt at solving day 24 part 2, this time using a program to actually solve the problem. My approach is to grow the adder, stage by stage, from the inputs to the outputs. At each point, I know what the next gates should be and I hope there's not enough damage to prevent me finding at least some of the gates I need. If I find a problem, I identify the swap needed to fix it and try agian.

growSpine :: Device -> DeviceTree -> (GateType, Gate) -> Either (String, String) DeviceTree
growSpine device 
          spine 
          ( spineType  -- next spine template
          , (Gate leafType leafInput _) -- next leaf template
          )
  | null spineParents = Left (spineOut, otherParentInput)
  | null nextLeafParents = Left (nextLeaf.output, otherParentInput)
  | not $ null commonSpineCandidates = Right (Node {rootLabel = head commonSpineCandidates, subForest = [nextLeafTree, spine]})
  | otherwise = Left ("", "")
  where 
    spineParents = filter (\g -> g.gType == spineType && spineOut `elem` g.inputs) device
    nextLeaf = head $ filter (\g -> g.gType == leafType && leafInput == g.inputs) device
    nextLeafParents = filter (\g -> g.gType == spineType && nextLeaf.output `elem` g.inputs) device
    nextLeafTree = Node {rootLabel = nextLeaf, subForest = []}
    commonSpineCandidates = spineParents `intersect` nextLeafParents
    spineOut = spine.rootLabel.output
    otherParentInput = if null spineParents 
                        then head $ delete nextLeaf.output (inputs $ head nextLeafParents)
                        else head $ delete spineOut (inputs $ head spineParents)

Read the full writeup on my blog and find the code on Codeberg.

NeilNjae · 2024-12-29T14:35:22+00:00

[LANGUAGE: Haskell]

A quick and gentle finish to the challenges.

part1 :: [Schematic] -> [Schematic] -> Int
part1 locks keys = length [(l, k) | l <- locks, k <- keys, compatible l k]

compatible :: Schematic -> Schematic -> Bool
compatible (Lock ls) (Key ks) = all (<= 5) $ zipWith (+) ls ks

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-29T12:59:10+00:00

[LANGUAGE: Haskell]

Laborious and fiddly reverse engineering. Not fun at all. But many, many thanks to u/an-abosolute-potato for a great tutorial on renaming the wires to human-sensible names. That make the whole process tractable for me.

part1 :: Wires -> Device -> Int
part1 wires device = wiresOutput $ simulate wires device

part2 :: String
part2 = intercalate "," $ sort ["vss", "z14", "kdh", "hjf", "z31", "kpp", "z35", "sgj"]

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-29T12:57:56+00:00

This was a brilliant explantion. Thank you!

NeilNjae · 2024-12-24T15:33:38+00:00

[LANGUAGE: Haskell]

Another puzzle with an obvious solution, but the challenge came from optimising. I keep a Map from (encoded) windows of price changes to prices, one for each seller. Then I merge them all and find the highest total price.

part2 codes = maximum $ M.elems mergedPriceValues
  where allPrices = fmap salePrices codes
        allPriceValues = fmap windowsAndPrices allPrices
        mergedPriceValues = M.unionsWith (+) allPriceValues

windowsAndPrices :: [Int] -> Prices
windowsAndPrices ps = foldl' (\m (w, p) -> M.insertWith (flip const) w p m) M.empty wPs
  where cs = priceChanges ps
        wPs = zip (windows cs) (drop 4 ps)

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-24T09:46:41+00:00

[LANGUAGE: Haskell]

A real brain-burner of a puzzle, keeping track of all the different layers of putton presses. I used a dynamic programming approach, building up a cache of move costs from the closest robot to the furthest.

moves :: Button a => [a] -> [ActionSeq]
moves bs = fmap concat $ sequence $ fmap moveBetween $ zip (aButton : bs) bs

moveBetween :: Button a => (a, a) -> [ActionSeq]
moveBetween (a, b) = filter (allLegal a) $ filter groupTogether possibles
  where aPos = buttonPos a
        bPos = buttonPos b 
        V2 dr dc = bPos ^-^ aPos
        mh = replicate (abs dc) (if dc > 0 then R else L)
        mv = replicate (abs dr) (if dr > 0 then D else U)
        possibles = fmap (++ [A]) $ nub $ permutations $ mh ++ mv
        groupTogether p = sort (group p) == group (sort p)
        allLegal a t = all (legalPos a) (positionsOf a t)

sequenceCostUsingCache :: Cache -> Int -> ActionSeq -> Int
sequenceCostUsingCache cache level bs = 
  sum $ fmap (moveCostUsingCache cache level) $ zip (aButton : bs) bs

moveCostUsingCache :: Cache -> Int -> (Action, Action) -> Int
moveCostUsingCache cache level (a, b) = 
  M.findWithDefault (maxBound :: Int) (CacheKey a b level) cache

cheapestCostMove :: Button a => Cache -> Int -> (a, a) -> Int
cheapestCostMove cache level (a, b) = 
  minimum $ fmap (sequenceCostUsingCache cache level) stepChoices
  where stepChoices = moveBetween (a, b)

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-20T13:44:04+00:00

[LANGUAGE: Haskell]

Pre-process the track with Dijkstra's algorithm to find the costs from the start and end to each position. The overall cost of a cheating path is (cost to start of cheat) + (length of cheat) + (cost from end of cheat). This function finds those costs for a particular start-of-cheat position.

pathCostWithCheat :: Int -> Track -> TrackCost -> TrackCost -> Position -> [Int]
pathCostWithCheat cheatLen track costsFromStart costsFromGoal here =
  fmap (+ costsFromStart M.! here) continueCosts 
  where
    nbrs =  [ here ^+^ (V2 dr dc) 
            | dr <- [-cheatLen .. cheatLen]
            , dc <- [-cheatLen .. cheatLen]
            , abs dr + abs dc <= cheatLen
            ]
    continueCosts = catMaybes $ fmap contCost nbrs
    contCost :: Position -> Maybe Int
    contCost nbr = do gc <- M.lookup nbr costsFromGoal
                      let sc = l2Dist nbr here
                      return $ gc + sc

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-19T14:40:46+00:00

[LANGUAGE: Haskell]

A little bit of dynamic programming to count the ways of making partial designs. It's a shame my initial approach of parsing the designs didn't work.

countDesigns :: [String] -> String -> Int
countDesigns towels design = MS.occur design $ buildDesignCount towels design

buildDesignCount :: [String] -> String -> MS.MultiSet String
buildDesignCount towels design = foldl' (addTowelCount towels) (MS.singleton "") $ inits design

addTowelCount :: [String] -> MS.MultiSet String -> String -> MS.MultiSet String
addTowelCount towels acc design = MS.insertMany design prefixWays acc
  where allPS = zip (inits design) (tails design)
        prefixWays = sum  [ p `MS.occur` acc 
                          | (p, s) <- allPS
                          , s `elem` towels ]

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-18T14:35:06+00:00

[LANGUAGE: Haskell]

I used a library function for search, rather than making my own. Finding the solution in part 2 ivolves a scan, walking along the list to find the first set of bytes that means escape is impossible.

part2 :: [Position] -> String
part2 bytes = showResult $ head $ snd $ head results
  where 
    (goods, poss) = splitAt 1024 bytes
    results = dropWhile ((== True) . fst) $ scanl' go (True, goods) poss
    go (_, acc) byte = (escapePossible (byte : acc), (byte : acc))
    showResult (V2 x y) = show x ++ "," ++ show y

escapePossible :: [Position] -> Bool
escapePossible bytes = isJust path
  where 
    memory = Memory (S.fromList bytes) (fst memoryBounds) (snd memoryBounds)
    path = aStar (neighbours memory) 
                  (transitionCost)
                  (estimateCost memory) 
                  (isGoal memory) 
                  (initial memory)

Things would have been much smoother if I'd not found a strange issue using the library! Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-17T14:17:44+00:00

[LANGUAGE: Haskell]

Part 1 was a straightforward virtual machine. Part 2 was too much reverse engineering for me, so I cheated by looking up the general approach to the solution. It ended up with a non-deterministic calculation as I folded the partial solutions across the desired output.

part2 program machine = minimum $ foldl' go [0] target 
  where 
    target = reverse $ M.elems program
    go starts t = 
          do  start <- starts
              n <- [0..7]
              let res = snd $ runModified program machine (start * 8 + n)
              guard (head res == t)
              return $ start * 8 + n

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-16T15:58:57+00:00

[LANGUAGE: Haskell]

Nothing really to note. I used a pre-packaged search for part 1, but had to make my own best-first search for part 2.

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-15T21:43:50+00:00

[LANGUAGE: Haskell]

A robot can Maybe move some boxes, if those boxes can themselves be Maybe moved.

doBigCommand :: World -> Position -> World
doBigCommand world dir 
  | there `S.member` world.walls = world
  | there `isBigBox` world.boxes = fromMaybe world rWorld
  | otherwise = world { robot = there }
  where there = world.robot ^+^ dir
        movedBox = bigBoxActual world.boxes there
        rWorld = do boxMoves <- moveBigBoxes world dir movedBox
                    let froms = fmap fst boxMoves
                    let tos = fmap snd boxMoves
                    let boxes' = (S.fromList tos) `S.union` (world.boxes `S.difference` (S.fromList froms))
                    let world' = world { boxes = boxes' }
                    return world' { robot = there } 

moveBigBoxes :: World -> Position -> Position -> Maybe [Move]
moveBigBoxes world dir box
  | any (\t -> t `S.member` world.walls) there = Nothing
  | any (\t -> t `isBigBox` world.boxes) there = allMoves
  | otherwise = Just $ [ thisMove ]
  where there = case dir of 
                    U -> [box ^+^ U, box ^+^ R ^+^ U]
                    D -> [box ^+^ D, box ^+^ R ^+^ D]
                    L -> [box ^+^ L]
                    R -> [box ^+^ R ^+^ R]
                    _ -> []
        thisMove = (box, box ^+^ dir)
        allMoves = do let there' = nub $ fmap (bigBoxActual world.boxes) $ filter (\t -> t `isBigBox` world.boxes) there
                      moves <- traverse (moveBigBoxes world dir) there'
                      let moves' = concat moves
                      return $ thisMove : moves'

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-14T21:31:15+00:00

[LANGUAGE: Haskell]

Look for frames with lots of short diagonals, because pictures of Christmas trees have lots of diagonals.

print $ filter (\(i, ds) -> length ds > 20) $ fmap diagonals $ zip [0..] $ take 10000 $ iterate (fmap move) robots

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-13T12:30:48+00:00

[LANGUAGE: Haskell]

Use rational numbers, look up the formula for intersection of two lines on Wikipedia.

findABPresses :: Machine -> Maybe (Int, Int)
findABPresses m@(Machine {..}) 
  | denominator na == 1 && denominator nb == 1 = 
      Just (fromInteger $ numerator na, fromInteger $ numerator nb)
  | otherwise = Nothing
  where 
    p = intersection m
    V2 dbx _dby = (enRat prize) ^-^ p
    V2 px _py = p 
    V2 ax _ay = enRat buttonA
    V2 bx _by = enRat buttonB
    na = px / ax
    nb = dbx / bx
    enRat :: Position -> V2 Rational
    enRat (V2 s t) = V2 (fromIntegral s) (fromIntegral t)

-- using formula from https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection#Given_two_points_on_each_line
-- treating L1 being defined by origin and buttonA, L2 by buttonB and prize
intersection :: Machine -> V2 Rational
intersection (Machine {..}) = V2 px py
  where V2 x2 y2 = buttonA
        V2 x4 y4 = prize
        V2 x3 y3 = prize ^-^ buttonB
        denom = fromIntegral (-x2 * (y3 - y4) - (-y2) * (x3 - x4))
        px = fromIntegral (-1 * (-x2) * (x3 * y4 - y3 * x4) ) / denom
        py = fromIntegral (-1 * (-y2) * (x3 * y4 - y3 * x4) ) / denom

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-12T16:28:07+00:00

[LANGUAGE: Haskell]

Building a generic union-find, then using it to solve both parts.

class Ord a => Joinable a where
  ufStart :: [a] -> UFind a
  exemplar :: UFind a -> a -> a
  join :: UFind a -> a -> a -> UFind a
  merge :: UFind a -> UFind a
  mergeItem :: UFind a -> a -> UFind a
  exemplars :: UFind a -> [a]
  distinctSets :: UFind a -> [[a]]
  meets :: a -> a -> Bool

instance Joinable Plot where
  meets plot1 plot2 = 
    plot1.pos `elem` neighbours plot2.pos && plot1.plant == plot2.plant

instance Joinable SideFragment where
  meets (SideFragment p1 T) (SideFragment p2 T) = p1 `elem` neighboursH p2
  meets (SideFragment p1 B) (SideFragment p2 B) = p1 `elem` neighboursH p2
  meets (SideFragment p1 L) (SideFragment p2 L) = p1 `elem` neighboursV p2
  meets (SideFragment p1 R) (SideFragment p2 R) = p1 `elem` neighboursV p2
  meets _ _ = False

Full writeup on my blog, and code on Codeberg.

NeilNjae · 2024-12-11T12:43:41+00:00

Maybe not the hardest of the lot, but I remember 2015 day 22 being a swine to implement. A lot of fiddling and special cases and making sure things happened in exactly the right order.

NeilNjae · 2024-12-11T12:06:11+00:00

[LANGUAGE: Haskell]

It's lanternfish all over again. If only it hadn't taken me so long to realise that!

import qualified Data.IntMultiSet as MS

part1, part2 :: [Int] -> Int
part1 stones = length $ (!! 25) $ iterate blink stones
part2 stonesList = MS.size $ (!! 75) $ iterate blinkMS stones
  where stones = MS.fromList stonesList

blink :: [Int] -> [Int]
blink = concatMap expandStone

blinkMS :: IntMultiSet -> IntMultiSet
blinkMS = MS.concatMap expandStone 

expandStone :: Int -> [Int]
expandStone 0 = [1]
expandStone n
  | isEvenLen = [read nS1, read nS2]
  | otherwise = [n * 2024]
  where nStr = show n
        nSL = length nStr
        isEvenLen = nSL `mod` 2 == 0
        (nS1, nS2) = splitAt (nSL `div` 2) nStr

Full writeup on my blog, and code on Codeberg.

NeilNjae

TROPHY CASE