{-# LANGUAGE OverloadedStrings        #-}

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

module AOC.Challenge.Day21 (
    day21a
  , day21b
  ) where

import           AOC.Common           (parseLines, pickUnique, countTrue)
import           AOC.Solver           ((:~>)(..))
import           Data.Foldable        (toList)
import           Data.Functor         ((<&>))
import           Data.List            (intercalate)
import           Data.Maybe           (listToMaybe)
import           Data.Set             (Set)
import           Data.Void            (Void)
import qualified Data.Map             as M
import qualified Data.Set             as S
import qualified Text.Megaparsec      as P
import qualified Text.Megaparsec.Char as P

assembleOptions
    :: (Ord k, Ord a)
    => [(Set a, Set k)]
    -> [(k, Set a)]
assembleOptions :: forall k a. (Ord k, Ord a) => [(Set a, Set k)] -> [(k, Set a)]
assembleOptions [(Set a, Set k)]
info = Map k (Set a) -> [(k, Set a)]
forall k a. Map k a -> [(k, a)]
M.toList (Map k (Set a) -> [(k, Set a)])
-> ([Map k (Set a)] -> Map k (Set a))
-> [Map k (Set a)]
-> [(k, Set a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set a -> Set a -> Set a) -> [Map k (Set a)] -> Map k (Set a)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.intersection ([Map k (Set a)] -> [(k, Set a)])
-> [Map k (Set a)] -> [(k, Set a)]
forall a b. (a -> b) -> a -> b
$
    [(Set a, Set k)]
info [(Set a, Set k)]
-> ((Set a, Set k) -> Map k (Set a)) -> [Map k (Set a)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Set a
igr, Set k
alg) -> (k -> Set a) -> Set k -> Map k (Set a)
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (Set a -> k -> Set a
forall a b. a -> b -> a
const Set a
igr) Set k
alg

day21a :: [(Set String, Set String)] :~> Int
day21a :: [(Set String, Set String)] :~> Int
day21a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe [(Set String, Set String)]
sParse = Parsec Void String (Set String, Set String)
-> String -> Maybe [(Set String, Set String)]
forall a. Parsec Void String a -> String -> Maybe [a]
parseLines Parsec Void String (Set String, Set String)
lineParser
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => [(Set String, Set String)] -> Maybe Int
sSolve = \[(Set String, Set String)]
igrsAlgs ->
          (Set String -> Int) -> Maybe (Set String) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> Set String -> Int
forall {f :: * -> *} {a}.
(Foldable f, Ord a) =>
f a -> Set a -> Int
countNotIn (((Set String, Set String) -> [String])
-> [(Set String, Set String)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Set String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set String -> [String])
-> ((Set String, Set String) -> Set String)
-> (Set String, Set String)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set String, Set String) -> Set String
forall a b. (a, b) -> a
fst) [(Set String, Set String)]
igrsAlgs))
        (Maybe (Set String) -> Maybe Int)
-> ([(String, Set String)] -> Maybe (Set String))
-> [(String, Set String)]
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set String] -> Maybe (Set String)
forall a. [a] -> Maybe a
listToMaybe
        ([Set String] -> Maybe (Set String))
-> ([(String, Set String)] -> [Set String])
-> [(String, Set String)]
-> Maybe (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map String String -> Set String)
-> [Map String String] -> [Set String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> (Map String String -> [String])
-> Map String String
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
        ([Map String String] -> [Set String])
-> ([(String, Set String)] -> [Map String String])
-> [(String, Set String)]
-> [Set String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Set String)] -> [Map String String]
forall k a. (Ord k, Ord a) => [(k, Set a)] -> [Map k a]
pickUnique
        ([(String, Set String)] -> Maybe Int)
-> [(String, Set String)] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [(Set String, Set String)] -> [(String, Set String)]
forall k a. (Ord k, Ord a) => [(Set a, Set k)] -> [(k, Set a)]
assembleOptions [(Set String, Set String)]
igrsAlgs
    }
  where
    countNotIn :: f a -> Set a -> Int
countNotIn f a
xs Set a
bad = (a -> Bool) -> f a -> Int
forall (f :: * -> *) a. Foldable f => (a -> Bool) -> f a -> Int
countTrue (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set a
bad) f a
xs

day21b :: [(Set String, Set String)] :~> [String]
day21b :: [(Set String, Set String)] :~> [String]
day21b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe [(Set String, Set String)]
sParse = Parsec Void String (Set String, Set String)
-> String -> Maybe [(Set String, Set String)]
forall a. Parsec Void String a -> String -> Maybe [a]
parseLines Parsec Void String (Set String, Set String)
lineParser
    , sShow :: [String] -> String
sShow  = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
","
    , sSolve :: (?dyno::DynoMap) => [(Set String, Set String)] -> Maybe [String]
sSolve = (Map String String -> [String])
-> Maybe (Map String String) -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map String String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (Map String String) -> Maybe [String])
-> ([(Set String, Set String)] -> Maybe (Map String String))
-> [(Set String, Set String)]
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Map String String] -> Maybe (Map String String)
forall a. [a] -> Maybe a
listToMaybe ([Map String String] -> Maybe (Map String String))
-> ([(Set String, Set String)] -> [Map String String])
-> [(Set String, Set String)]
-> Maybe (Map String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Set String)] -> [Map String String]
forall k a. (Ord k, Ord a) => [(k, Set a)] -> [Map k a]
pickUnique ([(String, Set String)] -> [Map String String])
-> ([(Set String, Set String)] -> [(String, Set String)])
-> [(Set String, Set String)]
-> [Map String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Set String, Set String)] -> [(String, Set String)]
forall k a. (Ord k, Ord a) => [(Set a, Set k)] -> [(k, Set a)]
assembleOptions
    }

type Parser = P.Parsec Void String

lineParser :: Parser (Set String, Set String)
lineParser :: Parsec Void String (Set String, Set String)
lineParser =
    (,) (Set String -> Set String -> (Set String, Set String))
-> ParsecT Void String Identity (Set String)
-> ParsecT
     Void String Identity (Set String -> (Set String, Set String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> ParsecT Void String Identity [String]
-> ParsecT Void String Identity (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
-> ParsecT Void String Identity [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some 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 String
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
" "))
        ParsecT
  Void String Identity (Set String -> (Set String, Set String))
-> ParsecT Void String Identity (Set String)
-> Parsec Void String (Set String, Set String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> ParsecT Void String Identity [String]
-> ParsecT Void String Identity (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity [String]
-> ParsecT Void String Identity [String]
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 String
"contains " ParsecT Void String Identity String
-> ParsecT Void String Identity [String]
-> ParsecT Void String Identity [String]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some 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 String
-> ParsecT Void String Identity [String]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`P.sepBy` ParsecT Void String Identity String
", ")
            )