From 5683ae214534135cff306267104edbbefb4f7d9f Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 19 Dec 2023 09:57:24 -0800 Subject: [PATCH] cleanup --- solutions/src/2023/19.hs | 132 +++++++++++++++++++++++---------------- 1 file changed, 77 insertions(+), 55 deletions(-) diff --git a/solutions/src/2023/19.hs b/solutions/src/2023/19.hs index 1415e01..24ec0fe 100644 --- a/solutions/src/2023/19.hs +++ b/solutions/src/2023/19.hs @@ -1,4 +1,4 @@ -{-# Language QuasiQuotes, TemplateHaskell, GADTs, DataKinds, ImportQualifiedPost #-} +{-# Language DataKinds, DeriveTraversable, GADTs, ImportQualifiedPost, PatternSynonyms, QuasiQuotes, TemplateHaskell, ViewPatterns #-} {-| Module : Main Description : Day 19 solution @@ -39,8 +39,21 @@ 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 (Functor, Foldable, Traversable) + +-- | 'V' is an index into a field of a 'Part' data V = Vx | Vm | Va | Vs +-- | 'Ints' is a range of 'Int' with an inclusive lower bound and exclusive upper bound. +type Ints = Box' 1 + +-- | Workflow rule determine an action to take based on parameter value. +data Rule + = LessThan V Int String -- ^ Action when variable less-than bound + | GreaterThan V Int String -- ^ Action when variable greater-than bound + stageTH -- | Parse the input instructions and print both parts. @@ -50,59 +63,68 @@ stageTH -- 127517902575337 main :: IO () main = - do (workflows, parts) <- [format|2023 19 (%a+{((@V>%d:%a+|@V<%d:%a+),)*%a+}%n)*%n({x=%d,m=%d,a=%d,s=%d}%n)*|] - let workflowMap = Map.fromList [(k, (map toRule rs, e)) | (k, rs, e) <- workflows] - print (sum [rating1 workflowMap "in" p | p <- parts]) - let full = Dim 1 4001 Pt - print (rating2 workflowMap "in" (full,full,full,full)) - -data Rule = LessThan V Int String | GreaterThan V Int String - -toRule :: Either (V, Int, String) (V, Int, String) -> Rule -toRule (Left (v, n, lbl)) = GreaterThan v n lbl -toRule (Right (v, n, lbl)) = LessThan v n lbl - -rating1 :: Map String ([Rule], String) -> String -> (Int, Int, Int, Int) -> Int -rating1 _ "A" (x, m, a, s) = x + m + a + s -rating1 _ "R" _ = 0 -rating1 workflows k p = - case workflows Map.! k of - (rs, el) -> foldr process (rating1 workflows el p) rs + do (workflows_, parts_) <- [format|2023 19 (%a+{((@V(<|>)!%d:%a+),)*%a+}%n)*%n({x=%d,m=%d,a=%d,s=%d}%n)*|] + let workflows = Map.fromList [(k, (map toRule rs, e)) | (k, rs, e) <- workflows_] + parts = [Part x m a s | (x, m, a, s) <- parts_] + print (sum [sum p | p <- parts, accepted workflows p]) + let full = 1 :> 4001 + print (acceptedCount workflows (Part full full full full)) + +-- | Convert parsed syntax to semantic representation +toRule :: (V, String, Int, String) -> Rule +toRule (v, ">", n, lbl) = GreaterThan v n lbl +toRule (v, _ , n, lbl) = LessThan v n lbl + +-- | Predicate for parts that will be accepted by the workflow. +accepted :: Map String ([Rule], String) -> Part Int -> Bool +accepted workflows xmas = 0 /= acceptedCount workflows (fmap one xmas) where - process (GreaterThan var n tgt) rest - | lkp p var > n = rating1 workflows tgt p - | otherwise = rest - process (LessThan var n tgt) rest - | lkp p var < n = rating1 workflows tgt p - | otherwise = rest - -rating2 :: Map String ([Rule], String) -> String -> (Box' 1, Box' 1, Box' 1, Box' 1) -> Int -rating2 _ "A" (x,m,a,s) = size x * size m * size a * size s -rating2 _ "R" _ = 0 -rating2 workflows k p0 = process (workflows Map.! k) p0 + one i = i :> i + 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 workflows = jump "in" where - process (GreaterThan var n tgt : rest, el) p = - case lkp p var of - Dim lo hi Pt -> - (if lo < n+1 then process (rest, el) (set p var (Dim lo (n+1) Pt)) else 0) + - (if n+1 < hi then rating2 workflows tgt (set p var (Dim (n+1) hi Pt)) else 0) - - process (LessThan var n tgt : rest, el) p = - case lkp p var of - Dim lo hi Pt -> - (if lo < n then rating2 workflows tgt (set p var (Dim lo n Pt) ) else 0) + - (if n < hi then process (rest, el) (set p var (Dim n hi Pt)) else 0) - - process ([], el) p = rating2 workflows el p - -lkp :: (a, a, a, a) -> V -> a -lkp (x,_,_,_) Vx = x -lkp (_,m,_,_) Vm = m -lkp (_,_,a,_) Va = a -lkp (_,_,_,s) Vs = s - -set :: (d, d, d, d) -> V -> d -> (d, d, d, d) -set (_,m,a,s) Vx x = (x,m,a,s) -set (x,_,a,s) Vm m = (x,m,a,s) -set (x,m,_,s) Va a = (x,m,a,s) -set (x,m,a,_) Vs s = (x,m,a,s) + jump "A" = product . fmap size + jump "R" = const 0 + jump ((workflows Map.!) -> (rs, el)) = foldr rule (jump el) rs + + rule (GreaterThan var n tgt) continue p = + case split (n + 1) (lkp p var) of + (lo, hi) -> + maybe 0 (continue . set p var) lo + + maybe 0 (jump tgt . set p var) hi + + rule (LessThan var n tgt) continue p = + case split n (lkp p var) of + (lo, hi) -> + maybe 0 (jump tgt . set p var) lo + + maybe 0 (continue . set p var) hi + +-- | Divide an interval into a region below and at a split. +split :: Int -> Ints -> (Maybe Ints, Maybe Ints) +split n r@(lo :> hi) + | n <= lo = (Nothing , Just r ) + | n >= hi = (Just r , Nothing ) + | otherwise = (Just (lo :> n), Just (n :> hi)) + +-- | Field accessor for 'Part' +lkp :: Part a -> V -> a +lkp (Part x _ _ _) Vx = x +lkp (Part _ m _ _) Vm = m +lkp (Part _ _ a _) Va = a +lkp (Part _ _ _ s) Vs = s + +-- | Field updater for 'Part' +set :: Part a -> V -> a -> Part a +set (Part _ m a s) Vx x = Part x m a s +set (Part x _ a s) Vm m = Part x m a s +set (Part x m _ s) Va a = Part x m a s +set (Part x m a _) Vs s = Part x m a s + +-- | Interval constructor: inclusive lower-bound, exclusive upper-bound. +-- Invariant: lower-bound < upper-bound +pattern (:>) :: Int -> Int -> Ints +pattern lo :> hi = Dim lo hi Pt +infix 4 :> +{-# COMPLETE (:>) #-}