Day 19: Aplenty

README.md

@@ -23,3 +23,4 @@ Development occurs in language-specific directories:
 |[Day16.hs](hs/src/Day16.hs)|[Day16.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day16.kt)|[day16.py](py/aoc2023/day16.py)|[day16.rs](rs/src/day16.rs)|
 |[Day17.hs](hs/src/Day17.hs)|[Day17.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day17.kt)|[day17.py](py/aoc2023/day17.py)|[day17.rs](rs/src/day17.rs)|
 |[Day18.hs](hs/src/Day18.hs)|[Day18.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day18.kt)|[day18.py](py/aoc2023/day18.py)|[day18.rs](rs/src/day18.rs)|
+|[Day19.hs](hs/src/Day19.hs)||||

hs/aoc2023.cabal

@@ -38,7 +38,8 @@ library
         Day15,
         Day16,
         Day17,
-        Day18
+        Day18,
+        Day19
 
     -- Modules included in this library but not exported.
     other-modules:
@@ -107,7 +108,8 @@ test-suite aoc2023-test
         Day15Spec,
         Day16Spec,
         Day17Spec,
-        Day18Spec
+        Day18Spec,
+        Day19Spec
     build-depends:
         aoc2023,
         base ^>=4.17.2.0,

hs/app/Main.hs

@@ -19,6 +19,7 @@ import qualified Day15 (part1, part2)
 import qualified Day16 (part1, part2)
 import qualified Day17 (part1, part2)
 import qualified Day18 (part1, part2)
+import qualified Day19 (part1, part2)
 
 import Control.Monad (ap, when)
 import Data.Foldable (find)
@@ -67,3 +68,4 @@ main = do
     run 16 print [Day16.part1, Day16.part2]
     run 17 (maybe (fail "error") print) [Day17.part1, Day17.part2]
     run 18 (either (fail . errorBundlePretty) print) [Day18.part1, Day18.part2]
+    run 19 (either (fail . errorBundlePretty) print) [Day19.part1, Day19.part2]

hs/bench/Main.hs

@@ -24,6 +24,7 @@ import qualified Day15 (part1, part2)
 import qualified Day16 (part1, part2)
 import qualified Day17 (part1, part2)
 import qualified Day18 (part1, part2)
+import qualified Day19 (part1, part2)
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 import System.FilePath (combine)
 
@@ -113,4 +114,8 @@ main = defaultMain
       [ bench "part 1" $ nf Day18.part1 input
       , bench "part 2" $ nf Day18.part2 input
       ]
+  , env (getDayInput 19) $ \input -> bgroup "Day 19"
+      [ bench "part 1" $ nf Day19.part1 input
+      , bench "part 2" $ nf Day19.part2 input
+      ]
   ]

hs/src/Day19.hs

@@ -0,0 +1,59 @@
+{-|
+Module:         Day19
+Description:    <https://adventofcode.com/2023/day/19 Day 19: Aplenty>
+-}
+{-# LANGUAGE OverloadedStrings #-}
+module Day19 (part1, part2) where
+
+import Data.Char (isAlphaNum)
+import Data.Functor (($>))
+import Data.Ix (rangeSize)
+import Data.List (find, foldl')
+import Data.Map (Map)
+import qualified Data.Map as Map ((!?), fromList, insertWith)
+import Data.Text (Text)
+import Data.Void (Void)
+import Text.Megaparsec (MonadParsec, ParseErrorBundle, Stream, Token, Tokens, (<|>), between, choice, eof, optional, parse, sepBy, sepEndBy, takeWhile1P, try)
+import Text.Megaparsec.Char (char, newline)
+import Text.Megaparsec.Char.Lexer (decimal)
+
+data Category = X | M | A | S deriving (Eq, Ord, Show)
+data a :<> b = a :< b | a :> b deriving (Show)
+
+parseRule :: (MonadParsec e s m, Token s ~ Char, Num a) => m (Tokens s, [(Tokens s, Maybe (Category :<> a))])
+parseRule = (,) <$> name <*> between (char '{') (char '}') (rule `sepBy` char ',') where
+    rule = flip (,) <$> optional (try cmp <* char ':') <*> name
+    cmp = flip ($) <$> choice (zipWith (($>) . char) "xmas" [X, M, A, S]) <*>
+        (char '<' $> (:<) <|> char '>' $> (:>)) <*> decimal
+    name = takeWhile1P (Just "name") isAlphaNum
+
+parsePoint :: (MonadParsec e s m, Token s ~ Char, Num a) => m (Map Category a)
+parsePoint = between (char '{') (char '}') $ Map.fromList <$> part `sepBy` char ',' where
+    part = (,) <$> choice (zipWith (($>) . char) "xmas" [X, M, A, S]) <*> (char '=' *> decimal)
+
+part1, part2 :: Text -> Either (ParseErrorBundle Text Void) Int
+part1 input = do
+    let parser = (,) . Map.fromList <$> parseRule `sepEndBy` newline <*> (newline *> parsePoint `sepEndBy` newline)
+    (rules, points) <- parse (parser <* eof) "" input
+    let ok "A" _ = True
+        ok "R" _ = False
+        ok name p = maybe False (flip ok p . fst) $ rules Map.!? name >>= find (ok' . snd) where
+            ok' (Just (k :< b)) | Just a <- p Map.!? k = a < b
+            ok' (Just (k :> b)) | Just a <- p Map.!? k = a > b
+            ok' _ = True
+    pure <$> sum $ sum <$> filter (ok "in") points
+part2 input = do
+    rules <- Map.fromList <$> parse (parseRule `sepEndBy` newline) "" input
+    let f "A" p = [foldl' (flip $ (*) . rangeSize) 1 p]
+        f name p | any (uncurry (>)) p = [] | otherwise = maybe [] (g p) $ rules Map.!? name
+        g _ [] = []
+        g p _ | any (uncurry (>)) p = []
+        g p ((name, Nothing):_) = f name p
+        g p ((name, Just cmp):rest) = g p2 rest <> f name p1 where
+          (key, r1, r2)
+            | key :< a <- cmp = (key, (minBound, a - 1), (a, maxBound))
+            | key :> a <- cmp = (key, (a + 1, maxBound), (minBound, a))
+          p1 = Map.insertWith intersectRange key r1 p
+          p2 = Map.insertWith intersectRange key r2 p
+        intersectRange (a, b) (c, d) = (max a c, min b d)
+    pure . sum . f "in" $ Map.fromList $ (, (1, 4000 :: Int)) <$> [X, M, A, S]

hs/test/Day19Spec.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day19Spec (spec) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unlines)
+import Day19 (part1, part2)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example = T.unlines
+  [ "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}"
+  , ""
+  , "{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}"
+  ]
+
+spec :: Spec
+spec = do
+    describe "part 1" $ do
+        it "examples" $ do
+            part1 example `shouldBe` Right 19114
+    describe "part 2" $ do
+        it "examples" $ do
+            part2 example `shouldBe` Right 167409079868000