{-# LANGUAGE OverloadedStrings #-}
module AOC.Challenge.Day07 (
day07a
, day07b
, bagParser
) where
import AOC.Common (pWord, parseLines, CharParser)
import AOC.Solver ((:~>)(..))
import Control.Applicative (many)
import Data.Map (Map)
import Data.Semigroup (Sum(..))
import Data.Set (Set)
import Data.Text (Text)
import Text.Megaparsec (try)
import Text.Megaparsec.Char (space)
import Text.Megaparsec.Char.Lexer (decimal)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
type Bag = (Text, Text)
type Graph v e = Map v (Map v e)
target :: Bag
target :: Bag
target = (Text
"shiny", Text
"gold")
bagParser :: CharParser (Bag, Map Bag Int)
bagParser :: CharParser (Bag, Map Bag Int)
bagParser = do
Bag
nm <- CharParser Bag
bagName CharParser Bag
-> ParsecT Void String Identity String -> CharParser Bag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
forall s e. (Stream s, Token s ~ Char, Ord e) => Parsec e s String
pWord
Map Bag Int
bs <- ([(Bag, Int)] -> Map Bag Int)
-> ParsecT Void String Identity [(Bag, Int)]
-> ParsecT Void String Identity (Map Bag Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Bag, Int)] -> Map Bag Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (ParsecT Void String Identity [(Bag, Int)]
-> ParsecT Void String Identity (Map Bag Int))
-> (ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity [(Bag, Int)])
-> ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity (Map Bag Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity [(Bag, Int)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity [(Bag, Int)])
-> (ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity (Bag, Int))
-> ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity [(Bag, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity (Bag, Int)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity (Map Bag Int))
-> ParsecT Void String Identity (Bag, Int)
-> ParsecT Void String Identity (Map Bag Int)
forall a b. (a -> b) -> a -> b
$ do
Int
n <- ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal ParsecT Void String Identity Int
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Bag
b <- CharParser Bag
bagName
pure (Bag
b, Int
n)
pure (Bag
nm, Map Bag Int
bs)
where
bagName :: CharParser Bag
bagName :: CharParser Bag
bagName = (,) (Text -> Text -> Bag)
-> ParsecT Void String Identity Text
-> ParsecT Void String Identity (Text -> Bag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Text
T.pack (String -> Text)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
forall s e. (Stream s, Token s ~ Char, Ord e) => Parsec e s String
pWord) ParsecT Void String Identity (Text -> Bag)
-> ParsecT Void String Identity Text -> CharParser Bag
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Text
T.pack (String -> Text)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
forall s e. (Stream s, Token s ~ Char, Ord e) => Parsec e s String
pWord ParsecT Void String Identity Text
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
forall s e. (Stream s, Token s ~ Char, Ord e) => Parsec e s String
pWord)
flipGraph :: Ord v => Graph v e -> Graph v e
flipGraph :: forall v e. Ord v => Graph v e -> Graph v e
flipGraph Graph v e
mp = (Map v e -> Map v e -> Map v e) -> [(v, Map v e)] -> Graph v e
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Map v e -> Map v e -> Map v e
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
[ (v
m, v -> e -> Map v e
forall k a. k -> a -> Map k a
M.singleton v
n e
e)
| (v
n, Map v e
ms) <- Graph v e -> [(v, Map v e)]
forall k a. Map k a -> [(k, a)]
M.toList Graph v e
mp
, (v
m, e
e ) <- Map v e -> [(v, e)]
forall k a. Map k a -> [(k, a)]
M.toList Map v e
ms
]
foldMapGraph
:: (Ord v, Monoid m)
=> (v -> m)
-> (e -> m -> m)
-> Graph v e
-> Map v m
foldMapGraph :: forall v m e.
(Ord v, Monoid m) =>
(v -> m) -> (e -> m -> m) -> Graph v e -> Map v m
foldMapGraph v -> m
f e -> m -> m
g Graph v e
gr = Map v m
res
where
res :: Map v m
res = (v -> e -> m) -> Map v e -> m
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
M.foldMapWithKey (\v
s e
v -> v -> m
f v
s m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (m -> m) -> Maybe m -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (e -> m -> m
g e
v) (v -> Map v m -> Maybe m
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
s Map v m
res))
(Map v e -> m) -> Graph v e -> Map v m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph v e
gr
allDescendants :: Ord v => Graph v e -> Map v (Set v)
allDescendants :: forall v e. Ord v => Graph v e -> Map v (Set v)
allDescendants = (v -> Set v) -> (e -> Set v -> Set v) -> Graph v e -> Map v (Set v)
forall v m e.
(Ord v, Monoid m) =>
(v -> m) -> (e -> m -> m) -> Graph v e -> Map v m
foldMapGraph
v -> Set v
forall a. a -> Set a
S.singleton
(\e
_ -> Set v -> Set v
forall a. a -> a
id)
usageCounts :: Ord v => Graph v Int -> Map v (Sum Int)
usageCounts :: forall v. Ord v => Graph v Int -> Map v (Sum Int)
usageCounts = (v -> Sum Int)
-> (Int -> Sum Int -> Sum Int) -> Graph v Int -> Map v (Sum Int)
forall v m e.
(Ord v, Monoid m) =>
(v -> m) -> (e -> m -> m) -> Graph v e -> Map v m
foldMapGraph
(Sum Int -> v -> Sum Int
forall a b. a -> b -> a
const Sum Int
0)
(\Int
n Sum Int
x -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
n Sum Int -> Sum Int -> Sum Int
forall a. Num a => a -> a -> a
* (Sum Int
x Sum Int -> Sum Int -> Sum Int
forall a. Num a => a -> a -> a
+ Sum Int
1))
day07a :: Graph Bag Int :~> Int
day07a :: Graph Bag Int :~> Int
day07a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
{ sParse :: String -> Maybe (Graph Bag Int)
sParse = ([(Bag, Map Bag Int)] -> Graph Bag Int)
-> Maybe [(Bag, Map Bag Int)] -> Maybe (Graph Bag Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Bag, Map Bag Int)] -> Graph Bag Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (Maybe [(Bag, Map Bag Int)] -> Maybe (Graph Bag Int))
-> (String -> Maybe [(Bag, Map Bag Int)])
-> String
-> Maybe (Graph Bag Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharParser (Bag, Map Bag Int)
-> String -> Maybe [(Bag, Map Bag Int)]
forall a. Parsec Void String a -> String -> Maybe [a]
parseLines CharParser (Bag, Map Bag Int)
bagParser
, sShow :: Int -> String
sShow = Int -> String
forall a. Show a => a -> String
show
, sSolve :: (?dyno::DynoMap) => Graph Bag Int -> Maybe Int
sSolve = Bag -> Map Bag Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Bag
target (Map Bag Int -> Maybe Int)
-> (Graph Bag Int -> Map Bag Int) -> Graph Bag Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Bag -> Int) -> Map Bag (Set Bag) -> Map Bag Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Bag -> Int
forall a. Set a -> Int
S.size (Map Bag (Set Bag) -> Map Bag Int)
-> (Graph Bag Int -> Map Bag (Set Bag))
-> Graph Bag Int
-> Map Bag Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph Bag Int -> Map Bag (Set Bag)
forall v e. Ord v => Graph v e -> Map v (Set v)
allDescendants (Graph Bag Int -> Map Bag (Set Bag))
-> (Graph Bag Int -> Graph Bag Int)
-> Graph Bag Int
-> Map Bag (Set Bag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph Bag Int -> Graph Bag Int
forall v e. Ord v => Graph v e -> Graph v e
flipGraph
}
day07b :: Map Bag (Map Bag Int) :~> Int
day07b :: Graph Bag Int :~> Int
day07b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
{ sParse :: String -> Maybe (Graph Bag Int)
sParse = ([(Bag, Map Bag Int)] -> Graph Bag Int)
-> Maybe [(Bag, Map Bag Int)] -> Maybe (Graph Bag Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Bag, Map Bag Int)] -> Graph Bag Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (Maybe [(Bag, Map Bag Int)] -> Maybe (Graph Bag Int))
-> (String -> Maybe [(Bag, Map Bag Int)])
-> String
-> Maybe (Graph Bag Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharParser (Bag, Map Bag Int)
-> String -> Maybe [(Bag, Map Bag Int)]
forall a. Parsec Void String a -> String -> Maybe [a]
parseLines CharParser (Bag, Map Bag Int)
bagParser
, sShow :: Int -> String
sShow = Int -> String
forall a. Show a => a -> String
show
, sSolve :: (?dyno::DynoMap) => Graph Bag Int -> Maybe Int
sSolve = Bag -> Map Bag Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Bag
target (Map Bag Int -> Maybe Int)
-> (Graph Bag Int -> Map Bag Int) -> Graph Bag Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sum Int -> Int) -> Map Bag (Sum Int) -> Map Bag Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Sum Int -> Int
forall a. Sum a -> a
getSum (Map Bag (Sum Int) -> Map Bag Int)
-> (Graph Bag Int -> Map Bag (Sum Int))
-> Graph Bag Int
-> Map Bag Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph Bag Int -> Map Bag (Sum Int)
forall v. Ord v => Graph v Int -> Map v (Sum Int)
usageCounts
}