{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : AOC.Challenge.Day19
-- License     : BSD3
--
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 19.  See "AOC.Solver" for the types used in this module!

module AOC.Challenge.Day19 (
    day19a
  , day19b
  ) where

import           AOC.Common                 (countTrue, pTok)
import           AOC.Solver                 ((:~>)(..))
import           Control.Applicative        (empty)
import           Control.DeepSeq            (NFData)
import           Control.Monad              ((>=>), guard)
import           Data.Bifunctor             (first)
import           Data.Functor.Foldable      (hylo)
import           Data.IntMap                (IntMap)
import           Data.Void                  (Void)
import           GHC.Generics               (Generic)
import qualified Data.IntMap                as IM
import qualified Text.Megaparsec            as P
import qualified Text.Megaparsec.Char       as P
import qualified Text.Megaparsec.Char.Lexer as PP

data Rule a = Simple Char
            | Compound [[a]]
  deriving (Int -> Rule a -> ShowS
[Rule a] -> ShowS
Rule a -> String
(Int -> Rule a -> ShowS)
-> (Rule a -> String) -> ([Rule a] -> ShowS) -> Show (Rule a)
forall a. Show a => Int -> Rule a -> ShowS
forall a. Show a => [Rule a] -> ShowS
forall a. Show a => Rule a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rule a] -> ShowS
$cshowList :: forall a. Show a => [Rule a] -> ShowS
show :: Rule a -> String
$cshow :: forall a. Show a => Rule a -> String
showsPrec :: Int -> Rule a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Rule a -> ShowS
Show, Rule a -> Rule a -> Bool
(Rule a -> Rule a -> Bool)
-> (Rule a -> Rule a -> Bool) -> Eq (Rule a)
forall a. Eq a => Rule a -> Rule a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rule a -> Rule a -> Bool
$c/= :: forall a. Eq a => Rule a -> Rule a -> Bool
== :: Rule a -> Rule a -> Bool
$c== :: forall a. Eq a => Rule a -> Rule a -> Bool
Eq, Eq (Rule a)
Eq (Rule a)
-> (Rule a -> Rule a -> Ordering)
-> (Rule a -> Rule a -> Bool)
-> (Rule a -> Rule a -> Bool)
-> (Rule a -> Rule a -> Bool)
-> (Rule a -> Rule a -> Bool)
-> (Rule a -> Rule a -> Rule a)
-> (Rule a -> Rule a -> Rule a)
-> Ord (Rule a)
Rule a -> Rule a -> Bool
Rule a -> Rule a -> Ordering
Rule a -> Rule a -> Rule a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Rule a)
forall a. Ord a => Rule a -> Rule a -> Bool
forall a. Ord a => Rule a -> Rule a -> Ordering
forall a. Ord a => Rule a -> Rule a -> Rule a
min :: Rule a -> Rule a -> Rule a
$cmin :: forall a. Ord a => Rule a -> Rule a -> Rule a
max :: Rule a -> Rule a -> Rule a
$cmax :: forall a. Ord a => Rule a -> Rule a -> Rule a
>= :: Rule a -> Rule a -> Bool
$c>= :: forall a. Ord a => Rule a -> Rule a -> Bool
> :: Rule a -> Rule a -> Bool
$c> :: forall a. Ord a => Rule a -> Rule a -> Bool
<= :: Rule a -> Rule a -> Bool
$c<= :: forall a. Ord a => Rule a -> Rule a -> Bool
< :: Rule a -> Rule a -> Bool
$c< :: forall a. Ord a => Rule a -> Rule a -> Bool
compare :: Rule a -> Rule a -> Ordering
$ccompare :: forall a. Ord a => Rule a -> Rule a -> Ordering
Ord, (forall x. Rule a -> Rep (Rule a) x)
-> (forall x. Rep (Rule a) x -> Rule a) -> Generic (Rule a)
forall x. Rep (Rule a) x -> Rule a
forall x. Rule a -> Rep (Rule a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Rule a) x -> Rule a
forall a x. Rule a -> Rep (Rule a) x
$cto :: forall a x. Rep (Rule a) x -> Rule a
$cfrom :: forall a x. Rule a -> Rep (Rule a) x
Generic, (forall a b. (a -> b) -> Rule a -> Rule b)
-> (forall a b. a -> Rule b -> Rule a) -> Functor Rule
forall a b. a -> Rule b -> Rule a
forall a b. (a -> b) -> Rule a -> Rule b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Rule b -> Rule a
$c<$ :: forall a b. a -> Rule b -> Rule a
fmap :: forall a b. (a -> b) -> Rule a -> Rule b
$cfmap :: forall a b. (a -> b) -> Rule a -> Rule b
Functor)

instance NFData a => NFData (Rule a)

matchRuleAlg :: Rule (String -> [String]) -> String -> [String]
matchRuleAlg :: Rule (String -> [String]) -> String -> [String]
matchRuleAlg = \case
    Simple Char
c -> \case
      []   -> [String]
forall (f :: * -> *) a. Alternative f => f a
empty
      Char
d:String
ds -> String
ds String -> [()] -> [String]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d)
    Compound [[String -> [String]]]
xs -> \String
str ->
      ([String -> [String]] -> [String])
-> [[String -> [String]]] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[String -> [String]]
ys -> ((String -> [String])
 -> (String -> [String]) -> String -> [String])
-> (String -> [String])
-> [String -> [String]]
-> String
-> [String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> [String]) -> (String -> [String]) -> String -> [String]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
(>=>) String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> [String]]
ys String
str) [[String -> [String]]]
xs

matcher :: IntMap (Rule Int) -> String -> [String]
matcher :: IntMap (Rule Int) -> String -> [String]
matcher IntMap (Rule Int)
rules = (Rule (String -> [String]) -> String -> [String])
-> (Int -> Rule Int) -> Int -> String -> [String]
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
hylo Rule (String -> [String]) -> String -> [String]
matchRuleAlg (IntMap (Rule Int)
rules IntMap (Rule Int) -> Int -> Rule Int
forall a. IntMap a -> Int -> a
IM.!) Int
0

solver :: IntMap (Rule Int) -> [String] -> Int
solver :: IntMap (Rule Int) -> [String] -> Int
solver IntMap (Rule Int)
rules = (String -> Bool) -> [String] -> Int
forall (f :: * -> *) a. Foldable f => (a -> Bool) -> f a -> Int
countTrue ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> (String -> [String]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (Rule Int) -> String -> [String]
matcher IntMap (Rule Int)
rules)

day19a :: (IntMap (Rule Int), [String]) :~> Int
day19a :: (IntMap (Rule Int), [String]) :~> Int
day19a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (IntMap (Rule Int), [String])
sParse = Parsec Void String (IntMap (Rule Int), [String])
-> String -> Maybe (IntMap (Rule Int), [String])
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
P.parseMaybe Parsec Void String (IntMap (Rule Int), [String])
inputParser
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => (IntMap (Rule Int), [String]) -> Maybe Int
sSolve = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ((IntMap (Rule Int), [String]) -> Int)
-> (IntMap (Rule Int), [String])
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap (Rule Int) -> [String] -> Int)
-> (IntMap (Rule Int), [String]) -> Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IntMap (Rule Int) -> [String] -> Int
solver
    }

day19b :: (IntMap (Rule Int), [String]) :~> Int
day19b :: (IntMap (Rule Int), [String]) :~> Int
day19b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (IntMap (Rule Int), [String])
sParse = ((IntMap (Rule Int), [String]) :~> Int)
-> String -> Maybe (IntMap (Rule Int), [String])
forall a b. (a :~> b) -> String -> Maybe a
sParse (IntMap (Rule Int), [String]) :~> Int
day19a
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => (IntMap (Rule Int), [String]) -> Maybe Int
sSolve = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ((IntMap (Rule Int), [String]) -> Int)
-> (IntMap (Rule Int), [String])
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap (Rule Int) -> [String] -> Int)
-> (IntMap (Rule Int), [String]) -> Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IntMap (Rule Int) -> [String] -> Int
solver ((IntMap (Rule Int), [String]) -> Int)
-> ((IntMap (Rule Int), [String]) -> (IntMap (Rule Int), [String]))
-> (IntMap (Rule Int), [String])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap (Rule Int) -> IntMap (Rule Int))
-> (IntMap (Rule Int), [String]) -> (IntMap (Rule Int), [String])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (IntMap (Rule Int)
extraRules IntMap (Rule Int) -> IntMap (Rule Int) -> IntMap (Rule Int)
forall a. Semigroup a => a -> a -> a
<>)
    }

extraRules :: IntMap (Rule Int)
extraRules :: IntMap (Rule Int)
extraRules = [(Int, Rule Int)] -> IntMap (Rule Int)
forall a. [(Int, a)] -> IntMap a
IM.fromList [
    (Int
8 , [[Int]] -> Rule Int
forall a. [[a]] -> Rule a
Compound [[Int
42],[Int
42,Int
8]])
  , (Int
11, [[Int]] -> Rule Int
forall a. [[a]] -> Rule a
Compound [[Int
42,Int
31],[Int
42,Int
11,Int
31]])
  ]

-- for fun: generate all matching strings
_genAlg :: Rule [String] -> [String]
_genAlg :: Rule [String] -> [String]
_genAlg = \case
    Simple Char
c -> [[Char
c]]
    Compound [[[String]]]
xs -> ([[String]] -> [String]) -> [[[String]]] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([String] -> String) -> [[String]] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> ([[String]] -> [[String]]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [[String]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence) [[[String]]]
xs

type Parser' = P.Parsec Void String

ruleParser :: Parser' (Int, Rule Int)
ruleParser :: Parser' (Int, Rule Int)
ruleParser = do
    Int
i <- Parsec Void String Int -> Parsec Void String Int
forall s e a.
(Stream s, Token s ~ Char, Ord e) =>
Parsec e s a -> Parsec e s a
pTok (Parsec Void String Int -> Parsec Void String Int)
-> Parsec Void String Int -> Parsec Void String Int
forall a b. (a -> b) -> a -> b
$ Parsec Void String Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PP.decimal Parsec Void String Int
-> ParsecT Void String Identity String -> Parsec Void String Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
":"
    Rule Int
r <- [ParsecT Void String Identity (Rule Int)]
-> ParsecT Void String Identity (Rule Int)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
      [ ParsecT Void String Identity (Rule Int)
-> ParsecT Void String Identity (Rule Int)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (ParsecT Void String Identity (Rule Int)
 -> ParsecT Void String Identity (Rule Int))
-> ParsecT Void String Identity (Rule Int)
-> ParsecT Void String Identity (Rule Int)
forall a b. (a -> b) -> a -> b
$ Char -> Rule Int
forall a. Char -> Rule a
Simple (Char -> Rule Int)
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity (Rule Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Char
simpleParser
      , [[Int]] -> Rule Int
forall a. [[a]] -> Rule a
Compound ([[Int]] -> Rule Int)
-> ParsecT Void String Identity [[Int]]
-> ParsecT Void String Identity (Rule Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity [[Int]]
compoundParser
      ]
    pure (Int
i, Rule Int
r)
  where
    simpleParser :: ParsecT Void String Identity Char
simpleParser   = ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
P.between ParsecT Void String Identity String
"\"" ParsecT Void String Identity String
"\"" ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.letterChar
    compoundParser :: ParsecT Void String Identity [[Int]]
compoundParser = Parsec Void String Int -> ParsecT Void String Identity [Int]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (Parsec Void String Int -> Parsec Void String Int
forall s e a.
(Stream s, Token s ~ Char, Ord e) =>
Parsec e s a -> Parsec e s a
pTok Parsec Void String Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PP.decimal) ParsecT Void String Identity [Int]
-> Parsec Void String (Tokens String)
-> ParsecT Void String Identity [[Int]]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`P.sepBy` Parsec Void String (Tokens String)
-> Parsec Void String (Tokens String)
forall s e a.
(Stream s, Token s ~ Char, Ord e) =>
Parsec e s a -> Parsec e s a
pTok Parsec Void String (Tokens String)
"|"

inputParser :: Parser' (IntMap (Rule Int), [String])
inputParser :: Parsec Void String (IntMap (Rule Int), [String])
inputParser = do
    IntMap (Rule Int)
rs <- [(Int, Rule Int)] -> IntMap (Rule Int)
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, Rule Int)] -> IntMap (Rule Int))
-> ParsecT Void String Identity [(Int, Rule Int)]
-> ParsecT Void String Identity (IntMap (Rule Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser' (Int, Rule Int)
-> ParsecT Void String Identity [(Int, Rule Int)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (Parser' (Int, Rule Int)
ruleParser Parser' (Int, Rule Int)
-> ParsecT Void String Identity Char -> Parser' (Int, Rule Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.newline)
    ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.newline
    [String]
ss <- ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.letterChar ParsecT Void String Identity String
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity [String]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`P.sepBy` ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.newline
    pure (IntMap (Rule Int)
rs, [String]
ss)