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/advent19b.txt"
  33       -- print text
  34       let (rules, messages) = successfulParse text
  35       let messagesT = map T.pack messages
  36       -- print rules
  37       -- print messages
  38       print $ part1 rules messagesT
  39       print $ part2 rules messagesT
  40       -- print $ part2 text
  41
  42 setup fname =
  43   do text <- TIO.readFile fname
  44      let (rules, messages) = successfulParse text
  45      let messagesT = map T.pack messages
  46      let Right newRules = parse rulesP "rules" "8: 42 | 42 8\n11: 42 31 | 42 11 31"
  47      let updatedRules = M.union newRules rules
  48      let myParser = (makeParser updatedRules (See 0)) -- <* eof
  49      return (myParser, updatedRules, messagesT)
  50
  51
  52
  53 part1 = countMatches
  54
  55 part2 rules messages = countMatches updatedRules messages
  56   where Right newRules = parse rulesP "rules" "8: 42 | 42 8\n11: 42 31 | 42 11 31"
  57         updatedRules = M.union newRules rules
  58
  59 countMatches rules messages
  60   = length
  61   $ filter isRight
  62   $ map (parse myParser "message") messages
  63   where myParser = (makeParser rules (See 0)) -- <* eof
  64
  65 prettyResults rs = map p rs
  66   where p (Left e) = errorBundlePretty e
  67         p (Right r) = "^" ++ show r
  68
  69
  70 -- Generate the rules
  71
  72 makeParser :: RuleSet -> Rule -> Parser ()
  73 makeParser m (Letter c) = void $ char c
  74 makeParser m (Then rs) = mapM_ (makeParser m) rs
  75 makeParser m (Or a b) = (try (makeParser m a)) <|> (makeParser m b)
  76 makeParser m (See i) = makeParser m (m!i)
  77
  78
  79 -- Parse the input
  80
  81 type Parser = Parsec Void Text
  82
  83 sc :: Parser ()
  84 sc = L.space (skipSome (char ' ')) CA.empty CA.empty
  85
  86 lexeme  = L.lexeme sc
  87 integer = lexeme L.decimal
  88 symb = L.symbol sc
  89 colonP = symb ":"
  90 pipeP = symb "|"
  91 quoteP = symb "\""
  92
  93
  94 rulesP = M.fromList <$> ruleP `sepEndBy` newline
  95 ruleP = (,) <$> integer <* colonP <*> ruleBodyP
  96 ruleBodyP = choice [(try letterRuleP), (try orRuleP), (try thenRuleP), (try seeRuleP)]
  97
  98 letterRuleP = Letter <$> between quoteP quoteP letterChar
  99 orRuleP = Or <$> thenRuleP <* pipeP <*> thenRuleP
 100 thenRuleP = Then <$> some seeRuleP
 101 seeRuleP = See <$> integer
 102
 103
 104 inputP = (,) <$> rulesP <* (some newline) <*> messagesP
 105
 106 messagesP = messageP `sepBy` newline
 107 messageP = some letterChar
 108
 109
 110 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 111 successfulParse input =
 112   case parse inputP "input" input of
 113     Left  _err -> (M.empty, []) -- TIO.putStr $ T.pack $ parseErrorPretty err
 114     Right expressions -> expressions