[hs] Solve 2020_19 part 1

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
 

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)
   ]

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

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