Done day 19

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index 374f2015f10d1eeafd3135f4f80a787652616c4e..a731ac852a71821ca04e77b12cb18482d1fa09e9 100644 (file)
--- 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 (file)
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