Advent of Code 2023 day 05

Day 5 was the return of the problem where a direct method works for part 1, but doesn't scale for part 2.

Problem and parsing

First off, I considered a couple of edge cases that could bite me.

1. In the full data, did each section of the almanac have only one ancestor and one descendant? (I confirmed this by manual inspection.)
2. In the full data, were all the rules disjoint, in that there were no two rules that applied to the same range of inputs? (I didn't check this, but assumed it was true.)

Given that, I put together a few data structures to store the almanac. The Almanac it self was a Map from the source category to the "map" in that section. That AMap was the name of the destination category and the list of rules. Each Rule is the triple of (destination, source, length). Finally, the Requirement is the current state of the problem: the current category and the current values.

type Almanac = M.Map String AMap
data AMap = AMap String [Rule] deriving (Eq, Show)
data Rule = Rule Int Int Int deriving (Eq, Show)
data Requirement = Requirement String [Int] deriving (Eq, Show)

Then I need to read the data and get it into these structures. It was mostly straight parsing, but with a few bespoke functions scattered around to reshape things into the data structures I'd chosen.

problemP = (,) <$> (seedsP <* blankLineP) <*> almanacP

seedsP = "seeds: " *> numbersP

almanacP = M.fromList <$> (aMapP `sepBy` blankLineP)
aMapP = aMapify <$> aMapHeaderP <*> rulesP
aMapHeaderP = (,) <$> (nameP <* "-to-") <*> (nameP <* " map:" <* endOfLine)

aMapify (s, d) rs = (s, AMap d rs)

rulesP = ruleP `sepBy` endOfLine
ruleP = Rule <$> (decimal <* space) <*> (decimal <* space) <*> decimal

numbersP = decimal `sepBy` skipSpace
nameP = many1 letter
blankLineP = endOfLine *> endOfLine

Part 1

Now to solve the actual problem! I built things up from the bottom. useRule attempts to apply a rule to a value, but returns Nothing if the value is outside the range of the rule. useRulesapplies many rules to a value, returning the original if no rule applies. useAMap applies all the values to all the rules, building the new Requirement.

useRule :: Int -> Rule -> Maybe Int
useRule x (Rule dest src rl)
  | x >= src && x < (src + rl) = Just (x + dest - src)
  | otherwise = Nothing

useRules :: [Rule] -> Int -> Int
useRules rs x 
  | null ruleResults = x
  | otherwise = head ruleResults
  where ruleResults = catMaybes $ fmap (useRule x) rs

useAMap :: AMap -> [Int] -> Requirement
useAMap (AMap d rs) xs = Requirement d $ fmap (useRules rs) xs

Then I needed to put things together into the full problem solution. followRequirements converts a source Requirement to its destination, using the almanac. lowestLocationbuilds the initial Requirement, kicks off the solution, and extracts the smallest value at the end.

part1 :: Almanac -> [Int] -> Int
part1 = lowestLocation

lowestLocation :: Almanac -> [Int] -> Int
lowestLocation almanac seeds = minimum locations
  where Requirement _ locations = followRequirements almanac $ Requirement "seed" seeds

followRequirements :: Almanac -> Requirement -> Requirement
followRequirements _ req@(Requirement "location" vals) = req
followRequirements almanac (Requirement name vals) = 
  followRequirements almanac newReq
  where aMap = almanac ! name
        newReq = useAMap aMap vals

Part 2

Part 2 changes the game, so I don't start with 20 seeds but rather 1.84 × 10⁹ seeds! That will take a bit of time to run. (But run it did, and it produced an answer. After about 20 minutes.) That version is in the repo as advent05/MainDirect.hs.

Rather than storing the value of very seed, I kept track of the Interval covered by the seeds. I also changed the Rule to hold the Interval where the rule applied, and the change applied to the values in that interval.

data Rule = Rule Interval Int deriving (Eq, Ord, Show)
data Requirement = Requirement String [Interval] deriving (Eq, Show)

data Interval = Iv Int Int deriving (Eq, Ord, Show) -- inclusive, closed at both ends

That change also needed some changes to the parser, including sorting the rules in the AMap.

ruleP = ruleify <$> (decimal <* space) <*> (decimal <* space) <*> decimal

aMapify :: (String, String) -> [Rule] -> (String, AMap)
aMapify (s, d) rs = (s, AMap d (sort rs))

ruleify :: Int -> Int -> Int -> Rule
ruleify d s l = Rule (Iv s (s + l - 1)) (d - s)

I knew that applying rules to intervals would end up with lots of little intervals all over the place, so tidyIntervals sorts all the intervals and merges the overlapping ones.

tidyIntervals :: [Interval] -> [Interval]
tidyIntervals = tidyIntervalsS . sort

tidyIntervalsS :: [Interval] -> [Interval]
tidyIntervalsS [] = []
tidyIntervalsS [x] = [x]
tidyIntervalsS (x:y:xs)
  | x `allBelow` y = x : tidyIntervalsS (y:xs)
  | otherwise = tidyIntervalsS $ (x `merge` y) : xs

allBelow :: Interval -> Interval -> Bool
allBelow (Iv _ x2) (Iv y1 _) = (x2 + 1) < y1 

merge :: Interval -> Interval -> Interval
merge (Iv x1 x2) (Iv y1 y2) = Iv (min x1 y1) (max x2 y2)

Applying a Rules to the Intervals takes some care. Both the rules and the intervals are sorted, and in useRules I walk along both of them.

If the upper end of the current rule is below the lower end of the current interval, discard that rule and continue. If the upper end of the current interval is below the lower end of the current rule, keep that interval unchanged. For the other cases, things get more complicated, and useRule handles that.

useRules :: [Rule] -> [Interval] -> [Interval]
useRules [] vals = vals
useRules _ [] = []
useRules (r@(Rule rv _):rs) (v:vs)  
  | rv `allBelow` v = useRules rs (v:vs)
  | v `allBelow` rv = v : useRules (r:rs) vs
  | otherwise = newResults ++ (useRules (newRules ++ rs) (newVals ++ vs))
  where (newResults, newVals, newRules) = useRule r v

My basic idea is to follow Allen's interval algebra (paper), but not rigorously. Rather than dealing with Allen's 11 different ways to two non-separate intervals to connect, I just find all the fragments and throw away the illegal ones. I consider a few cases, like in the diagram below.

Using the diagram for inspiration, I can calculate five regions:

1. The bit of the value that's below the bottom of the rule. (This is added unchanged to the result.)
2. The bit of the value that's within the rule. (This is added to the result after applying the rule.)
3. The bit of the value that's above the top of the rule. (This is added to the list of unprocessed values.)
4. The bit of the rule below the bottom of the value. (This is discarded, so I don't actually generate it.)
5. The bit of the rule above the top of the value. (This is added to the list of unprocessed rules.)

Some of these regions may not exist. For instance, in the first diagram above, the bit of the value above the top of the rule has a negative size. I still generate that interval, but then filter it out. useRule does the creation and filtering of these new values and rules.

useRule :: Rule -> Interval -> ([Interval], [Interval], [Rule])
useRule (Rule (Iv rl rh) d) (Iv xl xh) = (newResults, newVals, newRules)
  where newResults = 
          filter legalInterval 
            [ Iv xl (rl - 1) -- input below rule
            , Iv ((max xl rl) + d) ((min xh rh) + d)] -- input within rule
        newVals = filter legalInterval 
            [Iv (rh + 1) xh] -- input above rule
        newRules = filter legalRule 
            [Rule (Iv (xh + 1) rh) d] -- rule above input

legalInterval :: Interval -> Bool
legalInterval (Iv l h) = l <= h

legalRule :: Rule -> Bool
legalRule (Rule iv _) = legalInterval iv

When I've finished applying the rules, useAMap builds the new Requirement and tidies the values to keep things neat.

useAMap :: AMap -> [Interval] -> Requirement
useAMap (AMap d rs) xs = Requirement d $ tidyIntervals $ useRules rs xs

The rest of the problem follows much the same pattern as before. For part 2, I create the intervals as needed. For part 1, I create a size-one interval for each seed.

singletonRanges :: [Int] -> [Interval]
singletonRanges = fmap (\x -> Iv x x)

expandRanges :: [Int] -> [Interval]
expandRanges seeds = fmap expandRange ranges
  where ranges = chunksOf 2 seeds
        expandRange [s, l] = Iv s (s + l - 1)

This code is in advent05/Main.hs

Code

You can get the code from my locally-hosted Git repo, or from Gitlab.