{-# LANGUAGE OverloadedStrings #-}
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
", ")
)