From 4ac9d933e7f5683f3607703de4f3ce6ae0fb6f1a Mon Sep 17 00:00:00 2001
From: Jordan Doyle <jordan@doyle.la>
Date: Mon, 25 Dec 2023 02:23:36 +0000
Subject: [PATCH] Add day 19

---
 2023/19.hs | 150 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 150 insertions(+)
 create mode 100755 2023/19.hs

diff --git a/2023/19.hs b/2023/19.hs
new file mode 100755
index 0000000..f4efced
--- /dev/null
+++ b/2023/19.hs
@@ -0,0 +1,150 @@
+#!/usr/bin/env nix-shell
+#!nix-shell --pure -i "runghc -- -i../" -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [ ])"
+
+import Aoc (readAndParseStdin)
+import Data.Bifunctor (Bifunctor (first))
+import Data.Map (Map, adjust, elems, (!))
+import qualified Data.Map as Map
+import Data.Set (Set, intersection)
+import qualified Data.Set as Set
+import Text.Parsec (between, char, choice, digit, endBy, endBy1, getInput, letter, many1, optionMaybe, sepBy, sepBy1, string, try)
+import Text.Parsec.Char (noneOf)
+import Text.Parsec.String (Parser)
+
+main = do
+  input <- readAndParseStdin parse
+  print $ part1 input
+  print $ part2 input
+
+part1 :: Game -> Int
+part1 input = sum $ map (sum . elems) $ filter (evaluateInput "in" (workflows input)) (inputs input)
+
+part2 :: Game -> Int
+part2 input = sum $ map (product . fst) $ filter ((== Accept) . snd) $ map (first $ elems . Map.map Set.size) $ calculateAllowedBounds $ findAllCompletionBounds "in" $ workflows input
+
+-- Given a list of conditions, calculate all the allowed values for each of x, m, a & s
+calculateAllowedBounds :: [([Cond], Action)] -> [(Map ItemKey (Set Int), Action)]
+calculateAllowedBounds =
+  let rangeSet = Set.fromList [1 .. 4000]
+      initAcc = Map.fromList [(X, rangeSet), (M, rangeSet), (A, rangeSet), (S, rangeSet)]
+   in map (first $ calcSet initAcc)
+  where
+    buildRange :: Cond -> Set Int
+    buildRange cond = case cond of
+      Cond (_, Lt, v) -> Set.fromList [1 .. v - 1]
+      Cond (_, Gt, v) -> Set.fromList [v + 1 .. 4000]
+    calcSet :: Map ItemKey (Set Int) -> [Cond] -> Map ItemKey (Set Int)
+    calcSet acc [] = acc
+    calcSet acc (x : xs) =
+      let Cond (k, _, _) = x
+       in calcSet (adjust (`intersection` buildRange x) k acc) xs
+
+-- Traverse each workflow branch until a "completion" is found and return all the conditions that led up to
+-- that particular action
+findAllCompletionBounds :: String -> Map String [(Maybe Cond, Action)] -> [([Cond], Action)]
+findAllCompletionBounds entryPoint workflows = recurse [] (workflows ! entryPoint)
+  where
+    recurse :: [Cond] -> [(Maybe Cond, Action)] -> [([Cond], Action)]
+    recurse cacc [] = []
+    recurse cacc ((cond, action) : xs) =
+      let nextCacc = case cond of
+            Just c -> c : cacc
+            Nothing -> cacc
+          inverseCacc = case cond of
+            Just c -> invertCond c : cacc
+            Nothing -> cacc
+       in case action of
+            Reject -> (nextCacc, Reject) : recurse inverseCacc xs
+            Accept -> (nextCacc, Accept) : recurse inverseCacc xs
+            Redirect s -> recurse nextCacc (workflows ! s) ++ recurse inverseCacc xs
+      where
+        invertCond (Cond (k, Lt, v)) = Cond (k, Gt, v - 1)
+        invertCond (Cond (k, Gt, v)) = Cond (k, Lt, v + 1)
+
+-- Calculate whether the given input is allowed by the workflow
+evaluateInput :: String -> Map String [(Maybe Cond, Action)] -> Map ItemKey Int -> Bool
+evaluateInput entryPoint workflows input = go entryPoint
+  where
+    go workflow = case evaluateSingleWorkflow (workflows ! workflow) input of
+      Accept -> True
+      Reject -> False
+      Redirect s -> go s
+    evaluateSingleWorkflow workflow input = go workflow
+      where
+        go [] = error "no fallback"
+        go ((cond, action) : xs) = case cond of
+          Nothing -> action
+          Just (Cond (k, Lt, v)) -> if (input ! k) < v then action else go xs
+          Just (Cond (k, Gt, v)) -> if (input ! k) > v then action else go xs
+
+parse :: Parser Game
+parse = do
+  workflows <- Map.fromList <$> parseWorkflow `endBy1` char '\n'
+  _ <- char '\n'
+  inputs <- (Map.fromList <$> parseInput) `sepBy` char '\n'
+  return
+    Game
+      { workflows,
+        inputs
+      }
+
+parseInput :: Parser [(ItemKey, Int)]
+parseInput = braced $ kvPair `sepBy` char ','
+  where
+    kvPair = do
+      key <- parseItemKey <* char '='
+      value <- read <$> many1 digit
+      return (key, value)
+
+braced = between (char '{') (char '}')
+
+parseWorkflow :: Parser (String, [(Maybe Cond, Action)])
+parseWorkflow = do
+  key <- many1 (noneOf "{\n")
+  conds <- braced $ parseWorkflowItem `sepBy` char ','
+  return (key, conds)
+
+parseWorkflowItem :: Parser (Maybe Cond, Action)
+parseWorkflowItem = do
+  cond <- optionMaybe (try parseCond <* char ':')
+  action <-
+    choice
+      [ Accept <$ char 'A',
+        Reject <$ char 'R',
+        Redirect <$> many1 letter
+      ]
+  return (cond, action)
+
+parseCond :: Parser Cond
+parseCond = do
+  item <- parseItemKey
+  cond <-
+    choice
+      [ Lt <$ char '<',
+        Gt <$ char '>'
+      ]
+  val <- read <$> many1 digit
+  return $ Cond (item, cond, val)
+
+parseItemKey :: Parser ItemKey
+parseItemKey =
+  choice
+    [ X <$ char 'x',
+      M <$ char 'm',
+      A <$ char 'a',
+      S <$ char 's'
+    ]
+
+data Game = Game
+  { workflows :: Map String [(Maybe Cond, Action)],
+    inputs :: [Map ItemKey Int]
+  }
+  deriving (Show)
+
+newtype Cond = Cond (ItemKey, CondOp, Int) deriving (Show)
+
+data CondOp = Lt | Gt deriving (Enum, Show)
+
+data Action = Accept | Reject | Redirect String deriving (Show, Eq)
+
+data ItemKey = X | M | A | S deriving (Enum, Show, Ord, Eq)
--
libgit2 1.7.2