Day 19

advent-of-code-2023.cabal

@@ -130,3 +130,10 @@ executable day18
     build-depends:    base ^>=4.15.1.0, containers, MissingH
     hs-source-dirs:   day18
     default-language: Haskell2010
+
+executable day19
+    main-is:          Main.hs
+    other-modules:    Commons Part1 Part2
+    build-depends:    base ^>=4.15.1.0, containers, MissingH
+    hs-source-dirs:   day19
+    default-language: Haskell2010

day19/Commons.hs

@@ -0,0 +1,63 @@
+module Commons where
+
+import Data.List.Utils (split)
+import GHC.IO.Handle (isEOF)
+import Data.Map (Map, assocs, member, (!), fromList, empty, insert)
+
+
+data Part = Part { xr :: Int, mr :: Int, ar :: Int, sr :: Int } deriving (Eq, Show)
+data Rule = Rule { apply :: Part -> Bool, destination :: String, r :: Char, v :: Int, s :: Char }
+type Workflows = Map String [Rule]
+
+
+parsePart :: String -> Part
+parsePart line = let (x: m: a: s: _) = split "," line
+                 in Part {xr = read $ tail $ tail x, mr = read $ tail $ tail m, ar = read $ tail $ tail a,
+                          sr = read $ tail $ tail s}
+
+parseParts :: [Part] -> IO [Part]
+parseParts otherParts = do done <- isEOF
+                           if done then return otherParts
+                           else do line <- getLine
+                                   let part = parsePart $ tail $ init line
+                                   parseParts $ otherParts ++ [part]
+
+parseRules :: [String] -> [Rule]
+parseRules = map (\ rule -> if length rule < 2 || head (tail rule) /= '<' && head (tail rule) /= '>'
+                            then Rule {apply = const True, destination = rule, r = '*', v = 0, s = '>'}
+                            else let (condition: destination: _) = split ":" rule
+                                     (r: s: vRaw) = condition
+                                     v = read vRaw
+                                 in case (r, s) of
+                                         ('x', '>') -> Rule {apply = \ p -> xr p > v, destination = destination,
+                                                             r = r, v = v, s = s}
+                                         ('m', '>') -> Rule {apply = \ p -> mr p > v, destination = destination,
+                                                             r = r, v = v, s = s}
+                                         ('a', '>') -> Rule {apply = \ p -> ar p > v, destination = destination,
+                                                             r = r, v = v, s = s}
+                                         ('s', '>') -> Rule {apply = \ p -> sr p > v, destination = destination,
+                                                             r = r, v = v, s = s}
+                                         ('x', '<') -> Rule {apply = \ p -> xr p < v, destination = destination,
+                                                             r = r, v = v, s = s}
+                                         ('m', '<') -> Rule {apply = \ p -> mr p < v, destination = destination,
+                                                             r = r, v = v, s = s}
+                                         ('a', '<') -> Rule {apply = \ p -> ar p < v, destination = destination,
+                                                             r = r, v = v, s = s}
+                                         ('s', '<') -> Rule {apply = \ p -> sr p < v, destination = destination,
+                                                             r = r, v = v, s = s})
+
+parseWorkflow :: String -> (String, [Rule])
+parseWorkflow line = let (name: rulesRaw: _) = split "{" line
+                     in (name, parseRules $ split "," $ init rulesRaw)
+
+parseWorkflows :: Workflows -> IO Workflows
+parseWorkflows otherWorkflows = do line <- getLine
+                                   if null line
+                                   then return otherWorkflows
+                                   else do let (name, rules) = parseWorkflow line
+                                           parseWorkflows $ insert name rules otherWorkflows
+
+parse :: IO (Workflows, [Part])
+parse = do workflows <- parseWorkflows empty
+           ratings <- parseParts []
+           return (workflows, ratings)

day19/Main.hs

@@ -0,0 +1,12 @@
+module Main where
+
+import Commons
+import qualified Part1
+import qualified Part2
+
+
+main = do (workflows, parts) <- parse
+          let part1Res = Part1.getAcceptedSum workflows parts
+          print $ sum part1Res
+          let part2Res = Part2.getNCombinations workflows
+          print part2Res

day19/Part1.hs

@@ -0,0 +1,21 @@
+module Part1 where
+
+import Data.Map ((!))
+import Commons
+
+
+applyRules :: [Rule] -> Part -> String
+applyRules (h: t) p = if apply h p then destination h else applyRules t p
+
+applyWorkflow :: Workflows -> String -> Part -> Bool
+applyWorkflow workflows wName part = let destination = applyRules (workflows ! wName) part
+                                     in case destination of
+                                             "A" -> True
+                                             "R" -> False
+                                             _   -> applyWorkflow workflows destination part
+
+getAccepted :: Workflows -> [Part] -> [Part]
+getAccepted workflows = filter $ applyWorkflow workflows "in"
+
+getAcceptedSum :: Workflows -> [Part] -> [Int]
+getAcceptedSum workflows = map (\ p -> xr p + mr p + ar p + sr p) . getAccepted workflows

day19/Part2.hs

@@ -0,0 +1,44 @@
+module Part2 where
+
+import Data.Map ((!), Map, foldl, empty, filterWithKey, insert, member, fromList)
+import Commons
+
+
+type Intervals = Map Char (Int, Int)
+
+applyRule :: Rule -> Intervals -> (String, Intervals, Intervals)
+applyRule rule i
+  | r rule == '*'     = (destination rule, i, empty)
+  | member (r rule) i = let (start, end) = i ! r rule
+                        in case s rule of
+                                '>' -> if start > v rule
+                                       then (destination rule, i, empty)
+                                       else if end <= v rule
+                                            then (destination rule, empty, i)
+                                            else (destination rule, insert (r rule) (v rule + 1, end) i,
+                                                                    insert (r rule) (start, v rule) i)
+                                '<' -> if end < v rule
+                                       then (destination rule, i, empty)
+                                       else if start >= v rule
+                                            then (destination rule, empty, i)
+                                            else (destination rule, insert (r rule) (start, v rule - 1) i,
+                                                                    insert (r rule) (v rule, end) i)
+  | otherwise         = (destination rule, empty, i)
+
+applyRules :: [Rule] -> Intervals -> [(String, Intervals)]
+applyRules [] _ = []
+applyRules (h: t) i = let (destination, accepted, left) = applyRule h i
+                      in if destination == "R" then applyRules t left
+                         else (destination, accepted): applyRules t left
+
+applyWorkflow :: Workflows -> [(String, Intervals)] -> Int
+applyWorkflow _ [] = 0
+applyWorkflow workflows ((wName, i): t) | wName == "A" = Data.Map.foldl (\ a (start, end) -> a * (end - start + 1)) 1 i
+                                                         + applyWorkflow workflows t
+                                        | otherwise    = let afterRules = applyRules (workflows ! wName) i
+                                                         in applyWorkflow workflows afterRules
+                                                            + applyWorkflow workflows t
+
+getNCombinations :: Workflows -> Int
+getNCombinations w = applyWorkflow w [("in", fromList [('x', (1, 4000)), ('m', (1, 4000)), ('a', (1, 4000)),
+                                                       ('s', (1, 4000))])]