clean up day 19

mstksg · Dec 21, 2023 · 7a68df2 · 7a68df2
1 parent f8a9a45
commit 7a68df2
Show file tree

Hide file tree

Showing 2 changed files with 407 additions and 333 deletions.
diff --git a/src/AOC/Challenge/Day19.hs b/src/AOC/Challenge/Day19.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-unused-imports   #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 -- |
@@ -20,105 +20,134 @@
 --     types @_ :~> _@ with the actual types of inputs and outputs of the
 --     solution.  You can delete the type signatures completely and GHC
 --     will recommend what should go in place of the underscores.
+module AOC.Challenge.Day19
+  ( day19a,
+    day19b,
+  )
+where
 
-module AOC.Challenge.Day19 (
-    day19a
-  , day19b
-  ) where
-
-import           AOC.Prelude
-
-import qualified Data.Graph.Inductive           as G
-import qualified Data.IntMap                    as IM
-import qualified Data.IntSet                    as IS
-import qualified Data.List.NonEmpty             as NE
-import qualified Data.List.PointedList          as PL
+import AOC.Prelude
+import qualified Data.Graph.Inductive as G
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import qualified Data.List.NonEmpty as NE
+import qualified Data.List.PointedList as PL
 import qualified Data.List.PointedList.Circular as PLC
-import qualified Data.Map                       as M
-import qualified Data.OrdPSQ                    as PSQ
-import qualified Data.Sequence                  as Seq
-import qualified Data.Set                       as S
-import qualified Data.Text                      as T
-import qualified Data.Vector                    as V
-import qualified Linear                         as L
-import qualified Text.Megaparsec                as P
-import qualified Text.Megaparsec.Char           as P
-import qualified Text.Megaparsec.Char.Lexer     as PP
+import qualified Data.Map as M
+import qualified Data.OrdPSQ as PSQ
+import qualified Data.Sequence as Seq
+import qualified Data.Set as S
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Linear as L
+import qualified Text.Megaparsec as P
+import qualified Text.Megaparsec.Char as P
+import qualified Text.Megaparsec.Char.Lexer as PP
 
 -- qs{s>3448:A,lnx}
 
 data XMAS = X | M | A | S
-  deriving (Eq, Ord, Show, Generic)
+  deriving stock (Eq, Ord, Show, Generic, Enum)
 
 instance NFData XMAS
 
-chunky :: String -> (Maybe String, [Either String (XMAS,Ordering,Int,Maybe String)])
-chunky str = (mfilter (not . null) (Just inp), map go chunks)
+xmasMap :: Map Char XMAS
+xmasMap = M.fromList $ zip "xmas" [X .. S]
+
+opMap :: Map Char Ordering
+opMap = M.fromList $ zip "<=>" [LT, EQ, GT]
+
+data Result a = Reject | Accept | Defer a
+  deriving stock (Eq, Ord, Show, Generic)
+
+instance (NFData a) => NFData (Result a)
+
+data Rule a = Rule
+  { rXmas :: XMAS,
+    rOp :: Ordering,
+    rVal :: Int,
+    rResult :: Result a
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+
+instance (NFData a) => NFData (Rule a)
+
+data Workflow a = Workflow
+  { wfRules :: [Rule a],
+    wfDefault :: Result a
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+
+instance (NFData a) => NFData (Workflow a)
+
+chunky :: String -> (String, [Either String (XMAS, Ordering, Int, Maybe String)])
+chunky str = (inp, map go chunks)
   where
-    (inp, str') = span (/='{') str
+    (inp, str') = span (/= '{') str
     chunks = splitOn "," $ filter (`notElem` "{}") str'
     go x = maybe (Left x) Right do
-      a:(o:x') <- pure x
-      a' <- case a of
-        'x' -> Just X
-        'm' -> Just M
-        'a' -> Just A
-        's' -> Just S
-        _ -> Nothing
-      o' <- case o of
-        '<' -> Just LT
-        '>' -> Just GT
-        '=' -> Just EQ
-        _ -> Nothing
-      (b,x'') <- pure $ span isDigit x'
+      a : o : x' <- pure x
+      a' <- M.lookup a xmasMap
+      o' <- M.lookup o opMap
+      let (b, x'') = span isDigit x'
       b' <- readMaybe b
       pure (a', o', b', tailMay x'')
 
-processFilter :: String -> Maybe (String, ([(XMAS, Ordering, Int, Either Bool String)], Either Bool String))
+processFilter :: String -> Maybe (String, Workflow String)
 processFilter str = do
-  (Just x, parts) <- pure $ chunky str
-  filts <- for (init parts) \case
-    Right (a,b,c,d) -> (a,b,c,) . classify <$> d
-    Left _ -> Nothing
-  Left bu <- pure $ last parts
-  pure (x, (filts, classify bu))
+  (conds, Left backup) <- unsnoc filterParts
+  rules <- for conds \case
+    Right (a, b, c, Just d) -> Just $ Rule a b c (classify d)
+    _ -> Nothing
+  pure (key, Workflow rules (classify backup))
   where
+    (key, filterParts) = chunky str
     classify = \case
-      "R" -> Left False
-      "A" -> Left True
-      p -> Right p
+      "R" -> Reject
+      "A" -> Accept
+      p -> Defer p
 
 processInp :: String -> Maybe (Map XMAS Int)
-processInp str = M.fromList <$> for parts (\case Right (x,_,n,_) -> Just (x, n); _ -> Nothing)
+processInp = fmap M.fromList . traverse go . snd . chunky
   where
-    (_, parts) = chunky str
+    go = \case
+      Right (x, _, n, _) -> Just (x, n)
+      _ -> Nothing
 
+accepted ::
+  Map String (Workflow String) ->
+  Map XMAS Int ->
+  Bool
+accepted filts mp = go "in"
+  where
+    go i = case determine (filts M.! i) of
+      Defer j -> go j
+      Accept -> True
+      Reject -> False
+    determine Workflow {..} = foldr go' wfDefault wfRules
+      where
+        go' Rule {..} rest
+          | compare (mp M.! rXmas) rVal == rOp = rResult
+          | otherwise = rest
 
 day19a :: _ :~> _
-day19a = MkSol
-    { sParse = \inp -> case splitOn "\n\n" inp of
-                         [a,b] -> (,)  <$> fmap M.fromList (traverse processFilter (lines a))
-                                       <*> traverse processInp (lines b)
-                         _ -> Nothing
-    , sShow  = show
-    , sSolve = \(filts, xs) -> Just . sum . map sum . filter (accepted filts) $ xs
+day19a =
+  MkSol
+    { sParse = \inp -> do
+        (a, b) <- listTup $ splitOn "\n\n" inp
+        (,)
+          <$> fmap M.fromList (traverse processFilter (lines a))
+          <*> traverse processInp (lines b),
+      sShow = show,
+      sSolve = \(filts, xs) -> Just . sum . map sum . filter (accepted filts) $ xs
     }
-  where
-    accepted filts mp = go "in"
-      where
-        go i = case determine (filts M.! i) of
-          Right j -> go j
-          Left b -> b
-        determine (fs, x) = foldr go' x fs
-          where
-            go' (y, o, n, next) rest
-                | compare (mp M.! y) n == o = next
-                | otherwise = rest
 
 day19b :: _ :~> _
-day19b = MkSol
-    { sParse = sParse day19a
-    , sShow  = show
-    , sSolve = noFail $
+day19b =
+  MkSol
+    { sParse = sParse day19a,
+      sShow = show,
+      sSolve =
+        noFail $
           id
     }