advent19/src/advent19mega.hs

   1 -- import Debug.Trace
   2
   3 import Data.Text (Text)
   4 import qualified Data.Text as T
   5 import qualified Data.Text.IO as TIO
   6
   7 import Data.Void (Void)
   8
   9 import Text.Megaparsec hiding (State)
  10 import Text.Megaparsec.Char
  11 import qualified Text.Megaparsec.Char.Lexer as L
  12 import qualified Control.Applicative as CA
  13
  14 import qualified Data.IntMap.Strict as M
  15 import Data.IntMap.Strict ((!))
  16 import Data.Functor (void)
  17 import Prelude hiding (take)
  18 import Data.Either
  19
  20
  21 data Rule = Letter Char
  22           | Then [Rule]
  23           | Or Rule Rule
  24           | See Int
  25           deriving (Show, Eq)
  26
  27 type RuleSet = M.IntMap Rule
  28
  29
  30 main :: IO ()
  31 main =
  32   do  text <- TIO.readFile "data/advent19.txt"
  33       let (rules, messages) = successfulParse text
  34       let messagesT = map T.pack messages
  35       -- TIO.writeFile "rules19.mega.txt" $ T.pack $ show rules
  36       print $ length rules
  37       print $ length messages
  38       print $ part1 rules messagesT
  39       print $ part2 rules messagesT
  40
  41 setup fname =
  42   do text <- TIO.readFile fname
  43      let (rules, messages) = successfulParse text
  44      let messagesT = map T.pack messages
  45      let Right newRules = parse rulesP "rules" "8: 42 | 42 8\n11: 42 31 | 42 11 31"
  46      let updatedRules = M.union newRules rules
  47      let myParser = (makeParser updatedRules (See 0)) -- <* eof
  48      return (myParser, updatedRules, messagesT)
  49
  50
  51 part1 = countMatches
  52
  53 part2 rules messages = countMatches updatedRules messages
  54   where Right newRules = parse rulesP "rules" "8: 42 | 42 8\n11: 42 31 | 42 11 31"
  55         updatedRules = M.union newRules rules
  56
  57 countMatches rules messages
  58   = length
  59   $ filter isRight
  60   $ map (parse myParser "message") messages
  61   where myParser = (makeParser rules (See 0)) <* eof
  62
  63 prettyResults rs = map p rs
  64   where p (Left e) = errorBundlePretty e
  65         p (Right r) = "^" ++ show r
  66
  67 -- Generate the rules
  68
  69 makeParser :: RuleSet -> Rule -> Parser ()
  70 makeParser m (Letter c) = void $ char c
  71 makeParser m (Then rs) = mapM_ (\r -> try (makeParser m r)) rs
  72 makeParser m (Or a b) = (try (makeParser m a)) <|> (makeParser m b)
  73 makeParser m (See i) = makeParser m (m!i)
  74
  75
  76 -- Parse the input
  77
  78 type Parser = Parsec Void Text
  79
  80 sc :: Parser ()
  81 sc = L.space (skipSome (char ' ')) CA.empty CA.empty
  82
  83 lexeme  = L.lexeme sc
  84 integer = lexeme L.decimal
  85 symb = L.symbol sc
  86 colonP = symb ":"
  87 pipeP = symb "|"
  88 quoteP = symb "\""
  89
  90
  91 rulesP = M.fromList <$> ruleP `sepEndBy` newline
  92 ruleP = (,) <$> integer <* colonP <*> ruleBodyP
  93 ruleBodyP = choice [(try letterRuleP), (try orRuleP), (try thenRuleP), (try seeRuleP)]
  94
  95 letterRuleP = Letter <$> between quoteP quoteP letterChar
  96 orRuleP = Or <$> thenRuleP <* pipeP <*> thenRuleP
  97 thenRuleP = Then <$> some seeRuleP
  98 seeRuleP = See <$> integer
  99
 100
 101 inputP = (,) <$> rulesP <* (some newline) <*> messagesP
 102
 103 messagesP = messageP `sepBy` newline
 104 messageP = some letterChar
 105
 106
 107 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 108 successfulParse input =
 109   case parse inputP "input" input of
 110     Left  _err -> (M.empty, []) -- TIO.putStr $ T.pack $ parseErrorPretty err
 111     Right expressions -> expressions