{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      : AOC.Challenge.Day07
-- License     : BSD3
--
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 7.  See "AOC.Solver" for the types used in this module!

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
    ]

-- | Recursively fold up a monoid value for each vertex and all of its
-- children's monoid values.  You can transform the value in-transit before
-- it is accumulated if you want.
foldMapGraph
    :: (Ord v, Monoid m)
    => (v -> m)         -- ^ embed the vertex
    -> (e -> m -> m)    -- ^ transform with edge before it is accumulated
    -> 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     -- the node is embedded as itself
    (\e
_ -> Set v -> Set v
forall a. a -> a
id)      -- ignore the edge

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)                   -- ignore the nodes
    (\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))   -- the edge multiplies the accumulator plus one

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
    }