{-# LANGUAGE OverloadedStrings #-}

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

module AOC.Challenge.Day16 (
    day16a
  , day16b
  ) where

import           AOC.Common                 (CharParser, withAllSized, pickUnique)
import           AOC.Solver                 ((:~>)(..), dyno_)
import           Control.DeepSeq            (NFData)
import           Data.Char                  (isAlpha, isSpace)
import           Data.Distributive          (distribute)
import           Data.IntervalMap.Strict    (IntervalMap)
import           Data.List.NonEmpty         (NonEmpty(..))
import           Data.Maybe                 (listToMaybe, mapMaybe)
import           Data.Set                   (Set)
import           Data.Text                  (Text)
import           GHC.Generics               (Generic)
import qualified Data.ExtendedReal          as ER
import qualified Data.Interval              as I
import qualified Data.IntervalMap.Strict    as IM
import qualified Data.Map                   as M
import qualified Data.Set                   as S
import qualified Data.Text                  as T
import qualified Data.Vector.Sized          as V
import qualified Text.Megaparsec            as P
import qualified Text.Megaparsec.Char       as P
import qualified Text.Megaparsec.Char.Lexer as PP

type Passport = [Int]
data Info = Info
      { Info -> IntervalMap Int (Set Text)
iFields :: IntervalMap Int (Set Text)
      , Info -> Passport
iYours  :: Passport
      , Info -> [Passport]
iTheirs :: [Passport]
      }
    deriving (Int -> Info -> ShowS
[Info] -> ShowS
Info -> String
(Int -> Info -> ShowS)
-> (Info -> String) -> ([Info] -> ShowS) -> Show Info
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Info] -> ShowS
$cshowList :: [Info] -> ShowS
show :: Info -> String
$cshow :: Info -> String
showsPrec :: Int -> Info -> ShowS
$cshowsPrec :: Int -> Info -> ShowS
Show, Info -> Info -> Bool
(Info -> Info -> Bool) -> (Info -> Info -> Bool) -> Eq Info
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Info -> Info -> Bool
$c/= :: Info -> Info -> Bool
== :: Info -> Info -> Bool
$c== :: Info -> Info -> Bool
Eq, (forall x. Info -> Rep Info x)
-> (forall x. Rep Info x -> Info) -> Generic Info
forall x. Rep Info x -> Info
forall x. Info -> Rep Info x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Info x -> Info
$cfrom :: forall x. Info -> Rep Info x
Generic)
instance NFData Info

day16a :: Info :~> Int
day16a :: Info :~> Int
day16a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe Info
sParse = Parsec Void String Info -> String -> Maybe Info
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
P.parseMaybe Parsec Void String Info
parseInfo
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => Info -> Maybe Int
sSolve = \Info{Passport
[Passport]
IntervalMap Int (Set Text)
iTheirs :: [Passport]
iYours :: Passport
iFields :: IntervalMap Int (Set Text)
iTheirs :: Info -> [Passport]
iYours :: Info -> Passport
iFields :: Info -> IntervalMap Int (Set Text)
..} -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Passport -> Int) -> Passport -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Passport -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Passport -> Maybe Int) -> Passport -> Maybe Int
forall a b. (a -> b) -> a -> b
$
        [ Int
n
        | Passport
ns <- [Passport]
iTheirs
        , Int
n  <- Passport
ns
        , Int
n Int -> IntervalMap Int (Set Text) -> Bool
forall k a. Ord k => k -> IntervalMap k a -> Bool
`IM.notMember` IntervalMap Int (Set Text)
iFields
        ]
    }

day16b :: Info :~> [Int]
day16b :: Info :~> Passport
day16b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe Info
sParse = (Info :~> Int) -> String -> Maybe Info
forall a b. (a :~> b) -> String -> Maybe a
sParse Info :~> Int
day16a
    , sShow :: Passport -> String
sShow  = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Passport -> Int) -> Passport -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Passport -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product
    , sSolve :: (?dyno::DynoMap) => Info -> Maybe Passport
sSolve = \Info{Passport
[Passport]
IntervalMap Int (Set Text)
iTheirs :: [Passport]
iYours :: Passport
iFields :: IntervalMap Int (Set Text)
iTheirs :: Info -> [Passport]
iYours :: Info -> Passport
iFields :: Info -> IntervalMap Int (Set Text)
..} -> do
        [Set Text]
th : [[Set Text]]
ths <- [[Set Text]] -> Maybe [[Set Text]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Set Text]] -> Maybe [[Set Text]])
-> [[Set Text]] -> Maybe [[Set Text]]
forall a b. (a -> b) -> a -> b
$ (Passport -> Maybe [Set Text]) -> [Passport] -> [[Set Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Int -> Maybe (Set Text)) -> Passport -> Maybe [Set Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int -> IntervalMap Int (Set Text) -> Maybe (Set Text)
forall k a. Ord k => k -> IntervalMap k a -> Maybe a
`IM.lookup` IntervalMap Int (Set Text)
iFields)) [Passport]
iTheirs
        NonEmpty [Set Text]
-> (forall (n :: Nat).
    KnownNat n =>
    NonEmpty (Vector Vector n (Set Text)) -> Maybe Passport)
-> Maybe Passport
forall (v :: * -> *) a r.
Vector v a =>
NonEmpty [a]
-> (forall (n :: Nat).
    KnownNat n =>
    NonEmpty (Vector v n a) -> Maybe r)
-> Maybe r
withAllSized ([Set Text]
th [Set Text] -> [[Set Text]] -> NonEmpty [Set Text]
forall a. a -> [a] -> NonEmpty a
:| [[Set Text]]
ths) ((forall (n :: Nat).
  KnownNat n =>
  NonEmpty (Vector Vector n (Set Text)) -> Maybe Passport)
 -> Maybe Passport)
-> (forall (n :: Nat).
    KnownNat n =>
    NonEmpty (Vector Vector n (Set Text)) -> Maybe Passport)
-> Maybe Passport
forall a b. (a -> b) -> a -> b
$ \NonEmpty (Vector Vector n (Set Text))
vths -> do
          Vector n Int
yours      <- Passport -> Maybe (Vector n Int)
forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
V.fromList Passport
iYours
          let candidates :: [(Finite n, Set Text)]
candidates = Vector n (Finite n, Set Text) -> [(Finite n, Set Text)]
forall (n :: Nat) a. Vector n a -> [a]
V.toList (Vector n (Finite n, Set Text) -> [(Finite n, Set Text)])
-> (Vector Vector n (NonEmpty (Set Text))
    -> Vector n (Finite n, Set Text))
-> Vector Vector n (NonEmpty (Set Text))
-> [(Finite n, Set Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Vector n (Set Text) -> Vector n (Finite n, Set Text)
forall (n :: Nat) a. Vector n a -> Vector n (Finite n, a)
V.indexed
                         (Vector Vector n (Set Text) -> Vector n (Finite n, Set Text))
-> (Vector Vector n (NonEmpty (Set Text))
    -> Vector Vector n (Set Text))
-> Vector Vector n (NonEmpty (Set Text))
-> Vector n (Finite n, Set Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (Set Text) -> Set Text)
-> Vector Vector n (NonEmpty (Set Text))
-> Vector Vector n (Set Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Set Text -> Set Text -> Set Text)
-> NonEmpty (Set Text) -> Set Text
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
S.intersection)
                         (Vector Vector n (NonEmpty (Set Text)) -> [(Finite n, Set Text)])
-> Vector Vector n (NonEmpty (Set Text)) -> [(Finite n, Set Text)]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Vector Vector n (Set Text))
-> Vector Vector n (NonEmpty (Set Text))
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
distribute NonEmpty (Vector Vector n (Set Text))
vths
          Map (Finite n) Text
validMap   <- [Map (Finite n) Text] -> Maybe (Map (Finite n) Text)
forall a. [a] -> Maybe a
listToMaybe ([Map (Finite n) Text] -> Maybe (Map (Finite n) Text))
-> [Map (Finite n) Text] -> Maybe (Map (Finite n) Text)
forall a b. (a -> b) -> a -> b
$ [(Finite n, Set Text)] -> [Map (Finite n) Text]
forall k a. (Ord k, Ord a) => [(k, Set a)] -> [Map k a]
pickUnique [(Finite n, Set Text)]
candidates
          pure
            [ Vector n Int
yours Vector n Int -> Finite n -> Int
forall (n :: Nat) a. Vector n a -> Finite n -> a
`V.index` Finite n
i
            | (Finite n
i, Text
k) <- Map (Finite n) Text -> [(Finite n, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Finite n) Text
validMap
            , String -> Text -> Text
forall a. (Typeable a, ?dyno::DynoMap) => String -> a -> a
dyno_ String
"prefix" Text
"departure" Text -> Text -> Bool
`T.isPrefixOf` Text
k
            ]
    }

parseInfo :: CharParser Info
parseInfo :: Parsec Void String Info
parseInfo = do
    IntervalMap Int (Set Text)
iFields <- (Set Text -> Set Text -> Set Text)
-> [(Interval Int, Set Text)] -> IntervalMap Int (Set Text)
forall k a.
Ord k =>
(a -> a -> a) -> [(Interval k, a)] -> IntervalMap k a
IM.fromListWith Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
(<>) ([(Interval Int, Set Text)] -> IntervalMap Int (Set Text))
-> ([[(Interval Int, Set Text)]] -> [(Interval Int, Set Text)])
-> [[(Interval Int, Set Text)]]
-> IntervalMap Int (Set Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Interval Int, Set Text)]] -> [(Interval Int, Set Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Interval Int, Set Text)]] -> IntervalMap Int (Set Text))
-> ParsecT Void String Identity [[(Interval Int, Set Text)]]
-> ParsecT Void String Identity (IntervalMap Int (Set Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity [(Interval Int, Set Text)]
-> ParsecT Void String Identity [[(Interval Int, Set Text)]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (ParsecT Void String Identity [(Interval Int, Set Text)]
-> ParsecT Void String Identity [(Interval Int, Set Text)]
forall {f :: * -> *} {e} {s} {a}.
(MonadParsec e s f, Token s ~ Char) =>
f a -> f a
tok (ParsecT Void String Identity [(Interval Int, Set Text)]
-> ParsecT Void String Identity [(Interval Int, Set Text)]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT Void String Identity [(Interval Int, Set Text)]
fieldParser))
    ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall {f :: * -> *} {e} {s} {a}.
(MonadParsec e s f, Token s ~ Char) =>
f a -> f a
tok ParsecT Void String Identity String
"your ticket:"
    Passport
iYours  <- ParsecT Void String Identity Passport
-> ParsecT Void String Identity Passport
forall {f :: * -> *} {e} {s} {a}.
(MonadParsec e s f, Token s ~ Char) =>
f a -> f a
tok (ParsecT Void String Identity Passport
 -> ParsecT Void String Identity Passport)
-> ParsecT Void String Identity Passport
-> ParsecT Void String Identity Passport
forall a b. (a -> b) -> a -> b
$ ParsecT Void String Identity Passport
passportParser
    ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall {f :: * -> *} {e} {s} {a}.
(MonadParsec e s f, Token s ~ Char) =>
f a -> f a
tok ParsecT Void String Identity String
"nearby tickets:"
    [Passport]
iTheirs <- ParsecT Void String Identity Passport
passportParser ParsecT Void String Identity Passport
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity [Passport]
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 Info :: IntervalMap Int (Set Text) -> Passport -> [Passport] -> Info
Info{Passport
[Passport]
IntervalMap Int (Set Text)
iTheirs :: [Passport]
iYours :: Passport
iFields :: IntervalMap Int (Set Text)
iTheirs :: [Passport]
iYours :: Passport
iFields :: IntervalMap Int (Set Text)
..}
  where
    tok :: f a -> f a
tok f a
p = f a
p f a -> f String -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* f Char -> f String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some f Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.newline
    fieldParser :: ParsecT Void String Identity [(Interval Int, Set Text)]
fieldParser = do
      String
k  <- ((Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy (\Token String
c -> Char -> Bool
isAlpha Char
Token String
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
Token String
c) ParsecT Void String Identity Char
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`P.manyTill` ParsecT Void String Identity String
":") 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
" "
      [Interval Int]
vs <- ParsecT Void String Identity (Interval Int)
rangeParser ParsecT Void String Identity (Interval Int)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity [Interval Int]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`P.sepBy` Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Tokens String
" or "
      pure $ (,Text -> Set Text
forall a. a -> Set a
S.singleton (String -> Text
T.pack String
k)) (Interval Int -> (Interval Int, Set Text))
-> [Interval Int] -> [(Interval Int, Set Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Interval Int]
vs
    rangeParser :: ParsecT Void String Identity (Interval Int)
rangeParser = Extended Int -> Extended Int -> Interval Int
forall r. Ord r => Extended r -> Extended r -> Interval r
(I.<=..<=)
              (Extended Int -> Extended Int -> Interval Int)
-> ParsecT Void String Identity (Extended Int)
-> ParsecT Void String Identity (Extended Int -> Interval Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Extended Int
forall r. r -> Extended r
ER.Finite (Int -> Extended Int)
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity (Extended Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PP.decimal ParsecT Void String Identity (Extended Int)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity (Extended Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
"-")
              ParsecT Void String Identity (Extended Int -> Interval Int)
-> ParsecT Void String Identity (Extended Int)
-> ParsecT Void String Identity (Interval Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Extended Int
forall r. r -> Extended r
ER.Finite (Int -> Extended Int)
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity (Extended Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PP.decimal)
    passportParser :: ParsecT Void String Identity Passport
passportParser = ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PP.decimal ParsecT Void String Identity Int
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Passport
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`P.sepBy` ParsecT Void String Identity String
","