diff options
| -rw-r--r-- | 2023/19-Aplenty/second.hs | 130 |
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 |