From 845d28911baf93ec02a940198d210688adf9873f Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sat, 23 Dec 2023 10:19:27 +0000 Subject: [PATCH] Done day 19 --- advent-of-code23.cabal | 6 +- advent19/Main.hs | 250 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 255 insertions(+), 1 deletion(-) create mode 100644 advent19/Main.hs diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index 374f201..a731ac8 100644 --- a/advent-of-code23.cabal +++ b/advent-of-code23.cabal @@ -206,4 +206,8 @@ executable advent18 import: common-extensions, build-directives main-is: advent18/Main.hs build-depends: linear, text, attoparsec - \ No newline at end of file + +executable advent19 + import: common-extensions, build-directives + main-is: advent19/Main.hs + build-depends: containers, text, attoparsec, lens diff --git a/advent19/Main.hs b/advent19/Main.hs new file mode 100644 index 0000000..ff4187c --- /dev/null +++ b/advent19/Main.hs @@ -0,0 +1,250 @@ +-- Writeup at https://work.njae.me.uk/2023/12/22/advent-of-code-2023-day-18/ + +import AoC + +import Data.Text (Text, unpack) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text +import qualified Data.Attoparsec.Text as AT +import Control.Applicative +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import Control.Lens +import Data.Semigroup +import Data.Monoid +import Data.Semigroup (Semigroup) + +data Interval = Interval { _low :: Int, _high :: Int } + deriving (Eq, Ord, Show) +makeLenses ''Interval + +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 + +data WaitingPart = WaitingPart String (Part Interval) + deriving (Eq, Ord, Show) + +data Evaluation = Evaluation + { _accepted :: [Part Interval] + , _waiting :: [WaitingPart] + } deriving (Eq, Ord, Show) +makeLenses ''Evaluation + +instance Semigroup Evaluation where + (Evaluation a1 w1) <> (Evaluation a2 w2) = Evaluation (a1 <> a2) (w1 <> w2) + +instance Monoid Evaluation where + mempty = Evaluation [] [] + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let (rules, parts) = successfulParse text + -- print rules + -- print parts + -- print $ fmap (applyWorkflow "in" rules) parts + -- print $ filter ((== Accept) . applyWorkflow "in" rules) parts + print $ part1 rules parts + print $ part2 rules + -- print $ part2 text + +part1 :: RuleBase -> [Part Int] -> Int +part1 rules parts = sum $ fmap sumRegisters acceptedParts + where acceptedParts = filter ((== Accept) . applyWorkflow "in" rules) parts + +part2 rules = sum $ fmap registerRange accepted + where accepted = evaluateRules rules + (Evaluation [] [(WaitingPart "in" initialPart)]) + + +applyWorkflow :: String -> RuleBase -> Part Int -> Destination +applyWorkflow name rules part = + case applyRule part (rules ! name) of + Rule name' -> applyWorkflow name' rules part + dest -> dest + + +applyRule :: Part Int -> [RuleElement] -> Destination +applyRule _ [] = Reject +applyRule part (x:xs) = + case applyElement part x of + Continue -> applyRule part xs + dest -> dest + +applyElement :: Part Int -> RuleElement -> Destination +applyElement _ (WithoutTest dest) = dest +applyElement part (WithTest test dest) + | (test ^. comparator == Lt) = + if (regValue part (test ^. register) < (test ^. threshold)) + then dest + else Continue + | otherwise = + if (regValue part (test ^. register) > (test ^. threshold)) + then dest + else Continue + +regValue :: Part a -> Register -> a +regValue part X = part ^. x +regValue part M = part ^. m +regValue part A = part ^. a +regValue part S = part ^. s + + +-- lensOfR :: Register -> Lens' (Part a) a +-- lensOfR X = x +-- lensOfR M = m +-- lensOfR A = a +-- lensOfR S = s + +sumRegisters :: Part Int -> Int +sumRegisters part = (part ^. x) + (part ^. m) + (part ^. a) + (part ^. s) + +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) + +initialPart :: Part Interval +initialPart = Part (Interval 1 4000) (Interval 1 4000) + (Interval 1 4000) (Interval 1 4000) + + +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 rulebody + +applyRuleI :: (Part Interval) -> [RuleElement] -> Evaluation +applyRuleI part [] = mempty +applyRuleI part (x:xs) = + case inProgress of + Nothing -> evaluation + Just p -> evaluation <> (applyRuleI p xs) + where (evaluation, inProgress) = applyElementI part x + +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) + +splitPart :: Part Interval -> Test -> (Maybe (Part Interval), Maybe (Part Interval)) +splitPart part test = (passingPart, failingPart) + where -- regLens = lensOfR $ test ^. register + (passingInterval, failingInterval) = + -- splitInterval (part ^. regLens) (test ^. comparator) (test ^. threshold) + splitInterval (regValue part (test ^. register)) (test ^. comparator) (test ^. threshold) + passingPart = case passingInterval of + Nothing -> Nothing + -- Just interval -> Just (part & regLens .~ interval) + Just interval -> Just (setRegister part test interval) + failingPart = case failingInterval of + Nothing -> Nothing + -- Just interval -> Just (part & regLens .~ interval) + Just interval -> Just (setRegister part test interval) + +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) + ) + + +setRegister :: Part Interval -> Test -> Interval -> Part Interval +setRegister part (Test X _ _) val = part & x .~ val +setRegister part (Test M _ _) val = part & m .~ val +setRegister part (Test A _ _) val = part & a .~ val +setRegister part (Test S _ _) val = part & s .~ val + + +-- Parse the input file + +rulePartP :: Parser (RuleBase, [Part Int]) +rulesP :: Parser RuleBase +ruleP :: Parser (String, [RuleElement]) +nameP :: Parser String +ruleBodyP :: Parser [RuleElement] +ruleElementP, withTestP, withoutTestP :: Parser RuleElement +testP :: Parser Test +registerP :: Parser Register +destinationP :: Parser Destination +comparatorP :: Parser Comparator +partsP :: Parser [Part Int] +partP :: Parser (Part Int) + +rulePartP = (,) <$> (rulesP <* endOfLine <* endOfLine) <*> partsP + +rulesP = M.fromList <$> ruleP `sepBy` endOfLine +ruleP = (,) <$> (nameP <* "{") <*> (ruleBodyP <* "}") + +nameP = unpack <$> AT.takeWhile (inClass "a-z") -- many1 letter +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 <* "}") + +successfulParse :: Text -> (RuleBase, [Part Int]) +successfulParse input = + case parseOnly rulePartP input of + Left _err -> (M.empty, []) -- TIO.putStr $ T.pack $ parseErrorPretty err + Right matches -> matches \ No newline at end of file -- 2.34.1