From e8f3e01617a1aaa92dd9560a8ba74ac292eda5a4 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Sat, 19 Dec 2020 15:53:27 +0000
Subject: [PATCH] [hs] Solve 2020_19 part 1

---
 hs/src/Aoc/Parse.hs     |  4 +++
 hs/src/Aoc/Y2020.hs     |  2 ++
 hs/src/Aoc/Y2020/D18.hs |  5 ++-
 hs/src/Aoc/Y2020/D19.hs | 71 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 79 insertions(+), 3 deletions(-)
 create mode 100644 hs/src/Aoc/Y2020/D19.hs

diff --git a/hs/src/Aoc/Parse.hs b/hs/src/Aoc/Parse.hs
index 3c4b769..5f73980 100644
--- a/hs/src/Aoc/Parse.hs
+++ b/hs/src/Aoc/Parse.hs
@@ -11,6 +11,7 @@ module Aoc.Parse
   , lineSatisfy
   , line
   , lineChar
+  , lineSpace
   , word
   , digit
   ) where
@@ -67,6 +68,9 @@ line = lineWhile (const True)
 lineChar :: Parser Char
 lineChar = lineSatisfy (const True)
 
+lineSpace :: Parser T.Text
+lineSpace = lineWhile isSpace
+
 word :: Parser T.Text
 word = takeWhileP (Just "alphanumeric character") isAlphaNum
 
diff --git a/hs/src/Aoc/Y2020.hs b/hs/src/Aoc/Y2020.hs
index 264f9cd..880ca75 100644
--- a/hs/src/Aoc/Y2020.hs
+++ b/hs/src/Aoc/Y2020.hs
@@ -21,6 +21,7 @@ import qualified Aoc.Y2020.D15 as D15
 import qualified Aoc.Y2020.D16 as D16
 import qualified Aoc.Y2020.D17 as D17
 import qualified Aoc.Y2020.D18 as D18
+import qualified Aoc.Y2020.D19 as D19
 
 year :: Year
 year = Year 2020
@@ -42,4 +43,5 @@ year = Year 2020
   , (16, D16.day)
   , (17, D17.day)
   , (18, D18.day)
+  , (19, D19.day)
   ]
diff --git a/hs/src/Aoc/Y2020/D18.hs b/hs/src/Aoc/Y2020/D18.hs
index 45a1e19..7c2d7fe 100644
--- a/hs/src/Aoc/Y2020/D18.hs
+++ b/hs/src/Aoc/Y2020/D18.hs
@@ -5,7 +5,6 @@ module Aoc.Y2020.D18
   ) where
 
 import           Control.Monad
-import           Data.Char
 
 import           Control.Monad.Combinators.Expr
 import qualified Data.Text                      as T
@@ -15,10 +14,10 @@ import           Aoc.Day
 import           Aoc.Parse
 
 lexeme :: Parser a -> Parser a
-lexeme = L.lexeme (void $ lineWhile isSpace)
+lexeme = L.lexeme (void lineSpace)
 
 symbol :: T.Text -> Parser T.Text
-symbol = L.symbol (void $ lineWhile isSpace)
+symbol = L.symbol (void lineSpace)
 
 parser :: [[Operator Parser Int]] -> Parser [Int]
 parser table = manyLines expr
diff --git a/hs/src/Aoc/Y2020/D19.hs b/hs/src/Aoc/Y2020/D19.hs
new file mode 100644
index 0000000..f6e439f
--- /dev/null
+++ b/hs/src/Aoc/Y2020/D19.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Aoc.Y2020.D19
+  ( day
+  ) where
+
+import           Control.Monad
+import           Data.Foldable
+
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.State
+import qualified Data.Map                   as Map
+import qualified Data.Text                  as T
+import qualified Text.Megaparsec.Char.Lexer as L
+
+import           Aoc.Day
+import           Aoc.Parse
+
+data Rule = Leaf Char | Branch [[Int]]
+  deriving (Show)
+
+type Rules = Map.Map Int Rule
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme (void lineSpace)
+
+symbol :: T.Text -> Parser T.Text
+symbol = L.symbol (void lineSpace)
+
+parser :: Parser (Rules, [String])
+parser = do
+  rules <- Map.fromList <$> many (rule <* newline)
+  void newline
+  msgs <- map T.unpack <$> manyLines line
+  pure (rules, msgs)
+  where
+    leaf = Leaf <$> (char '"' *> lineChar <* char '"')
+    branch = Branch <$> some (lexeme decimal) `sepBy1` symbol "|"
+    rule = do
+      name <- decimal <* symbol ":"
+      content <- leaf <|> branch
+      pure (name, content)
+
+type SolveM = StateT String []
+
+consume :: Char -> SolveM ()
+consume c = get >>= \case
+  (x:xs) | x == c -> put xs
+  _               -> empty
+
+apply :: Rules -> Int -> SolveM ()
+apply rules ruleId = case rules Map.! ruleId of
+  Leaf c         -> consume c
+  Branch options -> traverse_ (apply rules) =<< lift options
+
+applyFully :: Rules -> Int -> SolveM ()
+applyFully rules ruleId = do
+  apply rules ruleId
+  guard . null =<< get
+
+isValid :: Rules -> String -> Bool
+isValid rules msg = not $ null $ runStateT (applyFully rules 0) msg
+
+solver :: (Rules, [String]) -> IO ()
+solver (rules, msgs) = do
+  putStrLn ">> Part 1"
+  print $ length $ filter (isValid rules) msgs
+
+day :: Day
+day = dayParse parser solver