Advent of Code 2023 day 19
Day 19 was one where Haskell's type system kept me out of all sorts of trouble. And there were a lot of types involved to keep organised! It also showed off the use of lenses and monoids to keep the focus on the logic of the problem, not the plumbing of moving data around.
Data structures
Here I followed the task specification and created a type of all the different things I had to keep track of. The Part was simple enough. A RuleElement (like x>10:one or lnx) is either WithTest or WithoutTest; both have a Destination that's one of Accept, Reject, a new Rule, or to Continue to the next rule element. A Test has a Registerbeing tested, a Comparator, and a Threshold. Finally, a RuleBase is a Map from rule names (String) to lists of RuleElement.
data Part a = Part { _x :: a, _m :: a, _a :: a, _s :: a }
deriving (Eq, Ord, Show)
makeLenses ''Part
data Register = X | M | A | S
deriving (Eq, Ord, Show)
data Comparator = Lt | Gt
deriving (Eq, Ord, Show)
type RuleBase = M.Map String [RuleElement]
data Destination = Accept | Reject | Rule String | Continue
deriving (Eq, Ord, Show)
data RuleElement = WithTest Test Destination
| WithoutTest Destination
deriving (Eq, Ord, Show)
data Test = Test { _register :: Register
, _comparator :: Comparator
, _threshold :: Int
}
deriving (Eq, Ord, Show)
makeLenses ''Test Given all these bits of the input, the parser to read them all is long but a direct translation of the input format into the defined types.
rulePartP = (,) <$> (rulesP <* endOfLine <* endOfLine) <*> partsP
rulesP = M.fromList <$> ruleP `sepBy` endOfLine
ruleP = (,) <$> (nameP <* "{") <*> (ruleBodyP <* "}")
nameP = unpack <$> AT.takeWhile (inClass "a-z")
ruleBodyP = ruleElementP `sepBy` ","
ruleElementP = withTestP <|> withoutTestP
withTestP = WithTest <$> (testP <* ":") <*> destinationP
withoutTestP = WithoutTest <$> destinationP
testP = Test <$> registerP <*> comparatorP <*> decimal
registerP = choice [ X <$ "x"
, M <$ "m"
, A <$ "a"
, S <$ "s"
]
destinationP = choice [ Accept <$ "A"
, Reject <$ "R"
, Rule <$> nameP
]
comparatorP = choice [ Lt <$ "<"
, Gt <$ ">"
]
partsP = partP `sepBy` endOfLine
partP = Part <$> ("{x=" *> decimal) <*> (",m=" *> decimal) <*> (",a=" *> decimal) <*> (",s=" *> decimal <* "}")
Part 1
Working from the bottom up, applyElement applies a single rule element to a Part. If there's a test and the part fails it, the part will Continue to the next rule element; otherwise, it goes to the destination of the rule element.
applyElement :: Part Int -> RuleElement -> Destination
applyElement _ (WithoutTest dest) = dest
applyElement part (WithTest test dest)
| (test ^. comparator == Lt) =
if part ^. l < test ^. threshold
then dest
else Continue
| otherwise =
if part ^. l > test ^. threshold
then dest
else Continue
where l = lensOfR (test ^. register)
lensOfR :: Register -> Lens' (Part a) a
lensOfR X = x
lensOfR M = m
lensOfR A = a
lensOfR S = sTo use a whole rule, I apply the first element to the part; the result is Continue, I apply the rest of the rule, otherwise I return the destination.
applyRule :: Part Int -> [RuleElement] -> Destination
applyRule _ [] = Reject
applyRule part (x:xs) =
case applyElement part x of
Continue -> applyRule part xs
dest -> destTo apply the whole workflow, starting with a given rule name, I apply that rule. If that gives a new rule to apply, I use that; if not, I return the destination.
applyWorkflow :: String -> RuleBase -> Part Int -> Destination
applyWorkflow name rules part =
case applyRule part (rules ! name) of
Rule name' -> applyWorkflow name' rules part
dest -> destThe final solution is to apply the workflow to all the parts, and count how many end with Accept.
part1 rules parts = sum $ fmap sumRegisters acceptedParts
where acceptedParts = filter ((== Accept) . applyWorkflow "in" rules) parts
sumRegisters :: Part Int -> Int
sumRegisters part = (part ^. x) + (part ^. m) + (part ^. a) + (part ^. s)Part 2
This needs a whole different approach. The idea is to apply the rules to find the ranges of values that will be accepted. When I'm thinking about these sorts of problems, I tend to think about what I need to know when I'm part-way through the process.
After processing some rules, I'll end up with some parts-with-ranges that I know are accepted, some that still need further processing by other rules, and some that I know are rejected. As I don't need to know anything about the rejected portions, I don't need to keep hold of them.
That leads to two new data structures. An Interval is a way of representing a range of values, and that explains the polymorphism of the Part earlier. An Evaluation is the current state of the process, with accepted parts and parts waiting further processing by other rules (represented by a list of WaitingPart).
data Interval = Interval { _low :: Int, _high :: Int }
deriving (Eq, Ord, Show)
makeLenses ''Interval
data WaitingPart = WaitingPart String (Part Interval)
deriving (Eq, Ord, Show)
data Evaluation = Evaluation
{ _accepted :: [Part Interval]
, _waiting :: [WaitingPart]
} deriving (Eq, Ord, Show)
makeLenses ''EvaluationThere will be lots of Evaluations lying around, that I'll want to merge together. I define a Monoid instance to help this, as well as defining the initialPart.
instance Semigroup Evaluation where
(Evaluation a1 w1) <> (Evaluation a2 w2) = Evaluation (a1 <> a2) (w1 <> w2)
instance Monoid Evaluation where
mempty = Evaluation [] []
initialPart :: Part Interval
initialPart = Part (Interval 1 4000) (Interval 1 4000)
(Interval 1 4000) (Interval 1 4000)At the high level, the evaluation as a whole takes an evaluation, runs the first WaitingPart, then combines that with the result of evaluating the rest of the waiting rules. Of course, evaluating a WaitingPart may result in more WaitingParts.
evaluateRules :: RuleBase -> Evaluation -> [Part Interval]
evaluateRules rules (Evaluation accepted []) = accepted
evaluateRules rules (Evaluation accepted ((WaitingPart rulename part):waiting)) =
evaluateRules rules ((Evaluation accepted waiting) <> newEvaluation)
where rulebody = rules ! rulename
newEvaluation = applyRuleI part rulebodyTo understand how to apply a rule to a Part Interval, it's easiest to start at the lowest level. Each test in a rule element will split an interval of values into (up to) two parts: the bit that passes the test, and the bit that fails the test. For instance, the test s<1351 will split the interval 1–4000 into the parts 1–1350 and 1351–4000, but the interval 1–1200 into the parts 1–1200 and nothing. splitInterval does this splitting, returning two Maybe (Part Interval)s.
splitInterval :: Interval -> Comparator -> Int -> (Maybe Interval, Maybe Interval)
splitInterval interval Lt threshold
| (interval ^. high) < threshold = (Just interval, Nothing)
| (interval ^. low) > threshold = (Nothing, Just interval)
| otherwise = ( Just (Interval (interval ^. low) (threshold - 1))
, Just (Interval threshold (interval ^. high))
)
splitInterval interval Gt threshold
| (interval ^. low) > threshold = (Just interval, Nothing)
| (interval ^. high) < threshold = (Nothing, Just interval)
| otherwise = ( Just (Interval (threshold + 1) (interval ^. high))
, Just (Interval (interval ^. low) threshold)
)splitPart takes the result of splitInterval and uses it to produce possibly two new Parts. (There's a type issue here that prevents me using the lensOfR result in both the call to splitInterval and the creations of the new Parts. I don't understand the problem, but the use of regValue is the work-around.)
splitPart :: Part Interval -> Test -> (Maybe (Part Interval), Maybe (Part Interval))
splitPart part test = (passingPart, failingPart)
where l = lensOfR (test ^. register) :: Lens' (Part Interval) Interval
(passingInterval, failingInterval) =
splitInterval (regValue part (test ^. register)) (test ^. comparator) (test ^. threshold)
passingPart = case passingInterval of
Nothing -> Nothing
Just pi -> Just (part & l .~ pi)
interval)
failingPart = case failingInterval of
Nothing -> Nothing
Just fi -> Just (part & l .~ fi)These two Parts are used in applyElementI that applies a ruleElement to a Part Interval. It returns a new Evaluation and a Maybe (Part Interval) that contains the Part that falls through to the next RuleElement in the RuleBody. If the RuleElement has no test, the incoming part is used to create the new Evaluation and the fall-through Part is Nothing. If the RuleElement has a test, it's used by splitPart to produce the two new Parts. The Part that passes the test is sent back to applyElementI to create its Evaluation, that the part that fails is returned.
applyElementI :: Part Interval -> RuleElement -> (Evaluation, Maybe (Part Interval))
applyElementI part (WithoutTest Accept) = (mempty & accepted .~ [part], Nothing)
applyElementI part (WithoutTest Reject) = (mempty, Nothing)
applyElementI part (WithoutTest (Rule rule)) = (mempty & waiting .~ [WaitingPart rule part], Nothing)
applyElementI part (WithTest test dest) = (evaluation, failing)
where (passing, failing) = splitPart part test
evaluation = case passing of
Nothing -> mempty
Just p -> fst $ applyElementI p (WithoutTest dest) Finally, applyRuleI keeps applying rule elements until it either runs out of elements or runs out of parts that need processing. It's called by evaluateRules above.
applyRuleI :: Part Interval -> [RuleElement] -> Evaluation
applyRuleI _ [] = mempty
applyRuleI part (e:es) =
case inProgress of
Nothing -> evaluation
Just p -> evaluation <> (applyRuleI p es)
where (evaluation, inProgress) = applyElementI part eThe whole process is kicked off by applying the initialPart to the in rule, and the result is calculated by finding the range of accepted values of all the accepted parts.
part2 rules = sum $ fmap registerRange accepted
where accepted = evaluateRules rules
(Evaluation [] [WaitingPart "in" initialPart])
registerRange :: Part Interval -> Int
registerRange part = ((part ^. x . high) - (part ^. x . low) + 1) *
((part ^. m . high) - (part ^. m . low) + 1) *
((part ^. a . high) - (part ^. a . low) + 1) *
((part ^. s . high) - (part ^. s . low) + 1) Code
You can get the code from my locally-hosted Git repo, or from Gitlab.