{-# Language DataKinds, DeriveTraversable, GADTs, ImportQualifiedPost, LambdaCase, PatternSynonyms, QuasiQuotes, TemplateHaskell, ViewPatterns #-}
{-|
Module      : Main
Description : Day 19 solution
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2023/day/19>

>>> :{
:main +
"px{a<2006:qkq,m>2090:A,rfg}
pv{a>1716:R,A}
lnx{m>1548:A,A}
rfg{s<537:gd,x>2440:R,A}
qs{s>3448:A,lnx}
qkq{x<1416:A,crn}
crn{x>2662:A,R}
in{s<1351:px,qqz}
qqz{s>2770:qs,m<1801:hdj,R}
gd{a>3333:R,R}
hdj{m>838:A,pv}\n
{x=787,m=2655,a=1222,s=2876}
{x=1679,m=44,a=2067,s=496}
{x=2036,m=264,a=79,s=2244}
{x=2461,m=1339,a=466,s=291}
{x=2127,m=1623,a=2188,s=1013}
"
:}
19114
167409079868000

-}
module Main (main) where

import Advent (format, stageTH)
import Advent.Box (size, Box(Pt, Dim), Box')
import Data.Map (Map)
import Data.Map qualified as Map

-- | A part is a quadruple of parameters indexed by 'V'
data Part a = Part a a a a
  deriving ((forall a b. (a -> b) -> Part a -> Part b)
-> (forall a b. a -> Part b -> Part a) -> Functor Part
forall a b. a -> Part b -> Part a
forall a b. (a -> b) -> Part a -> Part b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Part a -> Part b
fmap :: forall a b. (a -> b) -> Part a -> Part b
$c<$ :: forall a b. a -> Part b -> Part a
<$ :: forall a b. a -> Part b -> Part a
Functor, (forall m. Monoid m => Part m -> m)
-> (forall m a. Monoid m => (a -> m) -> Part a -> m)
-> (forall m a. Monoid m => (a -> m) -> Part a -> m)
-> (forall a b. (a -> b -> b) -> b -> Part a -> b)
-> (forall a b. (a -> b -> b) -> b -> Part a -> b)
-> (forall b a. (b -> a -> b) -> b -> Part a -> b)
-> (forall b a. (b -> a -> b) -> b -> Part a -> b)
-> (forall a. (a -> a -> a) -> Part a -> a)
-> (forall a. (a -> a -> a) -> Part a -> a)
-> (forall a. Part a -> [a])
-> (forall a. Part a -> Bool)
-> (forall a. Part a -> Int)
-> (forall a. Eq a => a -> Part a -> Bool)
-> (forall a. Ord a => Part a -> a)
-> (forall a. Ord a => Part a -> a)
-> (forall a. Num a => Part a -> a)
-> (forall a. Num a => Part a -> a)
-> Foldable Part
forall a. Eq a => a -> Part a -> Bool
forall a. Num a => Part a -> a
forall a. Ord a => Part a -> a
forall m. Monoid m => Part m -> m
forall a. Part a -> Bool
forall a. Part a -> Int
forall a. Part a -> [a]
forall a. (a -> a -> a) -> Part a -> a
forall m a. Monoid m => (a -> m) -> Part a -> m
forall b a. (b -> a -> b) -> b -> Part a -> b
forall a b. (a -> b -> b) -> b -> Part a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Part m -> m
fold :: forall m. Monoid m => Part m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Part a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Part a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Part a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Part a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Part a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Part a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Part a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Part a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Part a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Part a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Part a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Part a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Part a -> a
foldr1 :: forall a. (a -> a -> a) -> Part a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Part a -> a
foldl1 :: forall a. (a -> a -> a) -> Part a -> a
$ctoList :: forall a. Part a -> [a]
toList :: forall a. Part a -> [a]
$cnull :: forall a. Part a -> Bool
null :: forall a. Part a -> Bool
$clength :: forall a. Part a -> Int
length :: forall a. Part a -> Int
$celem :: forall a. Eq a => a -> Part a -> Bool
elem :: forall a. Eq a => a -> Part a -> Bool
$cmaximum :: forall a. Ord a => Part a -> a
maximum :: forall a. Ord a => Part a -> a
$cminimum :: forall a. Ord a => Part a -> a
minimum :: forall a. Ord a => Part a -> a
$csum :: forall a. Num a => Part a -> a
sum :: forall a. Num a => Part a -> a
$cproduct :: forall a. Num a => Part a -> a
product :: forall a. Num a => Part a -> a
Foldable, Functor Part
Foldable Part
(Functor Part, Foldable Part) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Part a -> f (Part b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Part (f a) -> f (Part a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Part a -> m (Part b))
-> (forall (m :: * -> *) a. Monad m => Part (m a) -> m (Part a))
-> Traversable Part
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Part (m a) -> m (Part a)
forall (f :: * -> *) a. Applicative f => Part (f a) -> f (Part a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Part a -> m (Part b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Part a -> f (Part b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Part a -> f (Part b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Part a -> f (Part b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Part (f a) -> f (Part a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Part (f a) -> f (Part a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Part a -> m (Part b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Part a -> m (Part b)
$csequence :: forall (m :: * -> *) a. Monad m => Part (m a) -> m (Part a)
sequence :: forall (m :: * -> *) a. Monad m => Part (m a) -> m (Part a)
Traversable, Int -> Part a -> ShowS
[Part a] -> ShowS
Part a -> String
(Int -> Part a -> ShowS)
-> (Part a -> String) -> ([Part a] -> ShowS) -> Show (Part a)
forall a. Show a => Int -> Part a -> ShowS
forall a. Show a => [Part a] -> ShowS
forall a. Show a => Part a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Part a -> ShowS
showsPrec :: Int -> Part a -> ShowS
$cshow :: forall a. Show a => Part a -> String
show :: Part a -> String
$cshowList :: forall a. Show a => [Part a] -> ShowS
showList :: [Part a] -> ShowS
Show)

-- | 'V' is an index into a field of a 'Part'
data V = Vx | Vm | Va | Vs

-- | Less-than and greater-than comparison operators for the workflow rules.
data O = O_LT | O_GT

-- | 'Ints' is a range of 'Int' with an inclusive lower bound and exclusive upper bound.
type Ints = Box' 1

-- | A rule is a part field, an operator, a bound, and a jump target
type Rule = (V, O, Int, String)

stageTH

-- | Parse the input instructions and print both parts.
--
-- >>> :main
-- 397134
-- 127517902575337
main :: IO ()
IO ()
main =
 do (workflows_, parts_) <- [format|2023 19 (%a+{(@V@O%u:%a+,)*%a+}%n)*%n({x=%u,m=%u,a=%u,s=%u}%n)*|]
    let workflows = [(String, ([(V, O, Int, String)], String))]
-> Map String ([(V, O, Int, String)], String)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
k, ([(V, O, Int, String)]
rs, String
e)) | (String
k, [(V, O, Int, String)]
rs, String
e) <- [(String, [(V, O, Int, String)], String)]
workflows_]
        parts = [Int -> Int -> Int -> Int -> Part Int
forall a. a -> a -> a -> a -> Part a
Part Int
x Int
m Int
a Int
s | (Int
x, Int
m, Int
a, Int
s) <- [(Int, Int, Int, Int)]
parts_]

    print (sum [sum p | p <- parts, accepted workflows p])
    let full = Int
1 Int -> Int -> Ints
:> Int
4001
    print (acceptedCount workflows (Part full full full full))

-- | Predicate for parts that will be accepted by the workflow.
accepted :: Map String ([Rule], String) -> Part Int -> Bool
accepted :: Map String ([(V, O, Int, String)], String) -> Part Int -> Bool
accepted Map String ([(V, O, Int, String)], String)
workflows Part Int
xmas = Int
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Map String ([(V, O, Int, String)], String) -> Part Ints -> Int
acceptedCount Map String ([(V, O, Int, String)], String)
workflows ((Int -> Box ('S 'Z)) -> Part Int -> Part (Box ('S 'Z))
forall a b. (a -> b) -> Part a -> Part b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Box ('S 'Z)
one Part Int
xmas)
  where
    one :: Int -> Ints
one Int
i = Int
i Int -> Int -> Ints
:> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- single-element interval

-- | Count of the number of distinct parts that are accepted by the workflow.
acceptedCount :: Map String ([Rule], String) -> Part Ints -> Int
acceptedCount :: Map String ([(V, O, Int, String)], String) -> Part Ints -> Int
acceptedCount Map String ([(V, O, Int, String)], String)
workflows = String -> Part (Box ('S 'Z)) -> Int
jump String
"in"
  where
    jump :: String -> Part (Box ('S 'Z)) -> Int
jump String
"A"                {- accept -} = Part Int -> Int
forall a. Num a => Part a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (Part Int -> Int)
-> (Part (Box ('S 'Z)) -> Part Int) -> Part (Box ('S 'Z)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Box ('S 'Z) -> Int) -> Part (Box ('S 'Z)) -> Part Int
forall a b. (a -> b) -> Part a -> Part b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Box ('S 'Z) -> Int
forall (n :: Nat). Box n -> Int
size
    jump String
"R"                {- reject -} = Int -> Part (Box ('S 'Z)) -> Int
forall a b. a -> b -> a
const Int
0
    jump ((Map String ([(V, O, Int, String)], String)
workflows Map String ([(V, O, Int, String)], String)
-> String -> ([(V, O, Int, String)], String)
forall k a. Ord k => Map k a -> k -> a
Map.!) -> ([(V, O, Int, String)]
rs, String
el)) = ((V, O, Int, String)
 -> (Part (Box ('S 'Z)) -> Int) -> Part (Box ('S 'Z)) -> Int)
-> (Part (Box ('S 'Z)) -> Int)
-> [(V, O, Int, String)]
-> Part (Box ('S 'Z))
-> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (V, O, Int, String)
-> (Part (Box ('S 'Z)) -> Int) -> Part (Box ('S 'Z)) -> Int
rule (String -> Part (Box ('S 'Z)) -> Int
jump String
el) [(V, O, Int, String)]
rs

    rule :: (V, O, Int, String)
-> (Part (Box ('S 'Z)) -> Int) -> Part (Box ('S 'Z)) -> Int
rule (V
var, O
O_GT, Int
n, String
tgt) Part (Box ('S 'Z)) -> Int
continue Part (Box ('S 'Z))
p =
      case Int -> Ints -> (Maybe Ints, Maybe Ints)
split (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Box ('S 'Z) -> (Maybe (Box ('S 'Z)), Maybe (Box ('S 'Z))))
-> (Box ('S 'Z) -> Part (Box ('S 'Z)), Box ('S 'Z))
-> (Box ('S 'Z) -> Part (Box ('S 'Z)),
    (Maybe (Box ('S 'Z)), Maybe (Box ('S 'Z))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Part (Box ('S 'Z))
-> V -> (Box ('S 'Z) -> Part (Box ('S 'Z)), Box ('S 'Z))
forall a. Part a -> V -> (a -> Part a, a)
part Part (Box ('S 'Z))
p V
var of
        (Box ('S 'Z) -> Part (Box ('S 'Z))
mk, (Maybe (Box ('S 'Z))
lo, Maybe (Box ('S 'Z))
hi)) ->
          Int -> (Box ('S 'Z) -> Int) -> Maybe (Box ('S 'Z)) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Part (Box ('S 'Z)) -> Int
continue (Part (Box ('S 'Z)) -> Int)
-> (Box ('S 'Z) -> Part (Box ('S 'Z))) -> Box ('S 'Z) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box ('S 'Z) -> Part (Box ('S 'Z))
mk) Maybe (Box ('S 'Z))
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+
          Int -> (Box ('S 'Z) -> Int) -> Maybe (Box ('S 'Z)) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (String -> Part (Box ('S 'Z)) -> Int
jump String
tgt (Part (Box ('S 'Z)) -> Int)
-> (Box ('S 'Z) -> Part (Box ('S 'Z))) -> Box ('S 'Z) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box ('S 'Z) -> Part (Box ('S 'Z))
mk) Maybe (Box ('S 'Z))
hi

    rule (V
var, O
O_LT, Int
n, String
tgt) Part (Box ('S 'Z)) -> Int
continue Part (Box ('S 'Z))
p =
      case Int -> Ints -> (Maybe Ints, Maybe Ints)
split Int
n (Box ('S 'Z) -> (Maybe (Box ('S 'Z)), Maybe (Box ('S 'Z))))
-> (Box ('S 'Z) -> Part (Box ('S 'Z)), Box ('S 'Z))
-> (Box ('S 'Z) -> Part (Box ('S 'Z)),
    (Maybe (Box ('S 'Z)), Maybe (Box ('S 'Z))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Part (Box ('S 'Z))
-> V -> (Box ('S 'Z) -> Part (Box ('S 'Z)), Box ('S 'Z))
forall a. Part a -> V -> (a -> Part a, a)
part Part (Box ('S 'Z))
p V
var of
        (Box ('S 'Z) -> Part (Box ('S 'Z))
mk, (Maybe (Box ('S 'Z))
lo, Maybe (Box ('S 'Z))
hi)) ->
          Int -> (Box ('S 'Z) -> Int) -> Maybe (Box ('S 'Z)) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (String -> Part (Box ('S 'Z)) -> Int
jump String
tgt (Part (Box ('S 'Z)) -> Int)
-> (Box ('S 'Z) -> Part (Box ('S 'Z))) -> Box ('S 'Z) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box ('S 'Z) -> Part (Box ('S 'Z))
mk) Maybe (Box ('S 'Z))
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+
          Int -> (Box ('S 'Z) -> Int) -> Maybe (Box ('S 'Z)) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Part (Box ('S 'Z)) -> Int
continue (Part (Box ('S 'Z)) -> Int)
-> (Box ('S 'Z) -> Part (Box ('S 'Z))) -> Box ('S 'Z) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box ('S 'Z) -> Part (Box ('S 'Z))
mk) Maybe (Box ('S 'Z))
hi

-- | Divide an interval into a region below and at a split.
split :: Int -> Ints -> (Maybe Ints, Maybe Ints)
split :: Int -> Ints -> (Maybe Ints, Maybe Ints)
split Int
n r :: Ints
r@(Int
lo :> Int
hi)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lo   = (Maybe Ints
Maybe (Box ('S 'Z))
forall a. Maybe a
Nothing       , Box ('S 'Z) -> Maybe (Box ('S 'Z))
forall a. a -> Maybe a
Just Ints
Box ('S 'Z)
r        )
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hi   = (Box ('S 'Z) -> Maybe (Box ('S 'Z))
forall a. a -> Maybe a
Just Ints
Box ('S 'Z)
r        , Maybe Ints
Maybe (Box ('S 'Z))
forall a. Maybe a
Nothing       )
  | Bool
otherwise = (Box ('S 'Z) -> Maybe (Box ('S 'Z))
forall a. a -> Maybe a
Just (Int
lo Int -> Int -> Ints
:> Int
n), Box ('S 'Z) -> Maybe (Box ('S 'Z))
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Ints
:> Int
hi))

-- | Factor a part into one of its parameters and a way to put that parameter back.
part :: Part a -> V -> (a -> Part a, a)
part :: forall a. Part a -> V -> (a -> Part a, a)
part (Part a
x a
m a
a a
s) = \case
  V
Vx -> (\a
o -> a -> a -> a -> a -> Part a
forall a. a -> a -> a -> a -> Part a
Part a
o a
m a
a a
s, a
x)
  V
Vm -> (\a
o -> a -> a -> a -> a -> Part a
forall a. a -> a -> a -> a -> Part a
Part a
x a
o a
a a
s, a
m)
  V
Va -> (\a
o -> a -> a -> a -> a -> Part a
forall a. a -> a -> a -> a -> Part a
Part a
x a
m a
o a
s, a
a)
  V
Vs -> (\a
o -> a -> a -> a -> a -> Part a
forall a. a -> a -> a -> a -> Part a
Part a
x a
m a
a a
o, a
s)

-- | Interval constructor: inclusive lower-bound, exclusive upper-bound.
-- Invariant: lower-bound < upper-bound
pattern (:>) :: Int -> Int -> Ints
pattern lo $m:> :: forall {r}. Ints -> (Int -> Int -> r) -> ((# #) -> r) -> r
$b:> :: Int -> Int -> Ints
:> hi = Dim lo hi Pt
infix 4 :>
{-# COMPLETE (:>) #-}