1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
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
|
