131 lines
6.8 KiB
Haskell
131 lines
6.8 KiB
Haskell
|
-- 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
|