aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--2023/19-Aplenty/second.hs130
1 files changed, 130 insertions, 0 deletions
diff --git a/2023/19-Aplenty/second.hs b/2023/19-Aplenty/second.hs
new file mode 100644
index 0000000..c59f079
--- /dev/null
+++ b/2023/19-Aplenty/second.hs
@@ -0,0 +1,130 @@
+-- requires cabal install --lib megaparsec parser-combinators heap vector
+module Main (main) where
+
+import Control.Applicative.Permutations
+import Control.Monad (void, when)
+import qualified Data.Char as C
+import Data.Either
+import Data.Functor
+import qualified Data.Heap as H
+import qualified Data.List as L
+import qualified Data.Map as M
+import Data.Maybe
+import qualified Data.Set as S
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as VU
+import Data.Void (Void)
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+import Debug.Trace
+
+exampleExpectedOutput = 167409079868000
+
+data Category = X | M | A | S deriving (Eq, Show)
+data Op = Gt | Lt deriving (Eq, Show)
+data Action = Accept | Reject | Jmp String deriving (Eq, Show)
+data Rule = Cmp Category Op Int Action | RuleAction Action deriving (Eq, Show)
+type Workflow = (String, [Rule])
+type Workflows = M.Map String [Rule]
+data Part = Part Int Int Int Int deriving (Eq, Show)
+type Parts = [Part]
+data Input = Input Workflows Parts deriving (Eq, Show)
+
+type Parser = Parsec Void String
+
+parseCategory :: Parser Category
+parseCategory = char 'x' $> X
+ <|> char 'm' $> M
+ <|> char 'a' $> A
+ <|> char 's' $> S
+
+parseOp :: Parser Op
+parseOp = char '>' $> Gt
+ <|> char '<' $> Lt
+
+parseNumber :: Parser Int
+parseNumber = read <$> some digitChar
+
+parseLabel :: Parser String
+parseLabel = try $ count' 2 4 letterChar
+
+parseAction :: Parser Action
+parseAction = char 'A' $> Accept
+ <|> char 'R' $> Reject
+ <|> (Jmp <$> parseLabel)
+
+parseRule :: Parser Rule
+parseRule = (RuleAction <$> parseAction)
+ <|> (Cmp <$> parseCategory <*> parseOp <*> parseNumber <* char ':' <*> parseAction)
+
+parseWorkflow :: Parser Workflow
+parseWorkflow = (,) <$> parseLabel <* char '{'
+ <*> some (parseRule <* optional (char ',')) <* char '}'
+
+parseWorkflows :: Parser Workflows
+parseWorkflows = M.fromList <$> some (parseWorkflow <* eol)
+
+parsePart :: Parser Part
+parsePart = Part <$> (string "{x=" *> parseNumber)
+ <*> (string ",m=" *> parseNumber)
+ <*> (string ",a=" *> parseNumber)
+ <*> (string ",s=" *> parseNumber <* char '}')
+
+parseParts :: Parser Parts
+parseParts = some (parsePart <* eol)
+
+parseInput' :: Parser Input
+parseInput' = Input <$> (parseWorkflows <* eol)
+ <*> (parseParts <* eof)
+
+parseInput :: String -> IO Input
+parseInput filename = do
+ input <- readFile filename
+ case runParser parseInput' filename input of
+ Left bundle -> error $ errorBundlePretty bundle
+ Right input' -> return input'
+
+type Interval = (Int, Int)
+data Combination = Combination Interval Interval Interval Interval deriving (Eq, Show)
+
+compute :: Input -> Int
+compute (Input workflows _) = compute' (Combination (1, 4000) (1, 4000) (1, 4000) (1, 4000)) [RuleAction (Jmp "in")]
+ where
+ compute' :: Combination -> [Rule] -> Int
+ compute' comb (RuleAction Accept:_) = score comb
+ compute' comb (RuleAction Reject:_) = 0
+ compute' comb (RuleAction (Jmp s):_) = compute' comb (workflows M.! s)
+ compute' comb@(Combination (xl, xr) m a s) (Cmp X Lt n act:xs) | xr < n = compute' comb [(RuleAction act)]
+ | xl >= n = compute' comb xs
+ | otherwise = compute' (Combination (xl, n - 1) m a s) [(RuleAction act)] + compute' (Combination (n, xr) m a s) xs
+ compute' comb@(Combination x (ml, mr) a s) (Cmp M Lt n act:xs) | mr < n = compute' comb [(RuleAction act)]
+ | ml >= n = compute' comb xs
+ | otherwise = compute' (Combination x (ml, n - 1) a s) [(RuleAction act)] + compute' (Combination x (n, mr) a s) xs
+ compute' comb@(Combination x m (al, ar) s) (Cmp A Lt n act:xs) | ar < n = compute' comb [(RuleAction act)]
+ | al >= n = compute' comb xs
+ | otherwise = compute' (Combination x m (al, n - 1) s) [(RuleAction act)] + compute' (Combination x m (n, ar) s) xs
+ compute' comb@(Combination x m a (sl, sr)) (Cmp S Lt n act:xs) | sr < n = compute' comb [(RuleAction act)]
+ | sl >= n = compute' comb xs
+ | otherwise = compute' (Combination x m a (sl, n - 1)) [(RuleAction act)] + compute' (Combination x m a (n, sr)) xs
+ compute' comb@(Combination (xl, xr) m a s) (Cmp X Gt n act:xs) | xl > n = compute' comb [(RuleAction act)]
+ | xr <= n = compute' comb xs
+ | otherwise = compute' (Combination (xl, n) m a s) xs + compute' (Combination (n + 1, xr) m a s) [(RuleAction act)]
+ compute' comb@(Combination x (ml, mr) a s) (Cmp M Gt n act:xs) | ml > n = compute' comb [(RuleAction act)]
+ | mr <= n = compute' comb xs
+ | otherwise = compute' (Combination x (ml, n) a s) xs + compute' (Combination x (n + 1, mr) a s) [(RuleAction act)]
+ compute' comb@(Combination x m (al, ar) s) (Cmp A Gt n act:xs) | al > n = compute' comb [(RuleAction act)]
+ | ar <= n = compute' comb xs
+ | otherwise = compute' (Combination x m (al, n) s) xs + compute' (Combination x m (n + 1, ar) s) [(RuleAction act)]
+ compute' comb@(Combination x m a (sl, sr)) (Cmp S Gt n act:xs) | sl > n = compute' comb [(RuleAction act)]
+ | sr <= n = compute' comb xs
+ | otherwise = compute' (Combination x m a (sl, n)) xs + compute' (Combination x m a (n + 1, sr)) [(RuleAction act)]
+ score (Combination (xl, xr) (ml, mr) (al, ar) (sl, sr)) = (xr - xl + 1) * (mr - ml + 1) * (ar - al + 1) * (sr - sl + 1)
+
+main :: IO ()
+main = do
+ example <- parseInput "example"
+ let exampleOutput = compute example
+ when (exampleOutput /= exampleExpectedOutput) (error $ "example failed: got " ++ show exampleOutput ++ " instead of " ++ show exampleExpectedOutput)
+ input <- parseInput "input"
+ print $ compute input