content: {-# LANGUAGE OverloadedStrings #-}
  
  -- |
  -- Module      : AOC.Challenge.Day22
  -- License     : BSD3
  --
  -- Stability   : experimental
  -- Portability : non-portable
  --
  -- Day 22.  See "AOC.Solver" for the types used in this module!
  
  module AOC.Challenge.Day22 (
      day22a
    , day22b
    ) where
  
  import           AOC.Solver                 ((:~>)(..))
  import           Control.DeepSeq            (NFData)
  import           Control.Monad              (guard)
  import           Data.Foldable              (toList)
  import           Data.HashSet               (HashSet)
  import           Data.Hashable              (Hashable(..))
  import           Data.Sequence              (Seq(..))
  import           Data.Sequence.NonEmpty     (NESeq(..))
  import           Data.Void                  (Void)
  import           GHC.Generics               (Generic)
  import qualified Data.HashSet               as HS
  import qualified Data.Sequence              as Seq
  import qualified Text.Megaparsec            as P
  import qualified Text.Megaparsec.Char       as P
  import qualified Text.Megaparsec.Char.Lexer as PP
  
  type Deck   = Seq Int
  type NEDeck = NESeq Int
  
  data Player = P1 | P2
    deriving (Show, Eq, Ord, Generic)
  instance NFData Player
  
  data GameState = GS Deck Deck
    deriving Eq
  instance Hashable GameState where
      hashWithSalt s (GS xs ys) =
        hashWithSalt s
          ( take 2 (toList xs)
          , take 2 (toList ys)
          , Seq.length xs
          )
  
  score :: Deck -> Int
  score = sum . zipWith (*) [1..] . reverse . toList
  
  playGameWith
      :: (NEDeck -> NEDeck -> Maybe Player)       -- ^ recurse
      -> Deck
      -> Deck
      -> (Player, Deck)
  playGameWith f = go HS.empty
    where
      go :: HashSet GameState -> Deck -> Deck -> (Player, Deck)
      go !seen !xs0 !ys0
        | GS xs0 ys0 `HS.member` seen = (P1, xs0)
        | otherwise = case (xs0, ys0) of
            (x :<| xs, y :<| ys) ->
              let winner = case f (x :<|| xs) (y :<|| ys) of
                    Nothing -> if x > y then P1 else P2
                    Just p  -> p
              in  case winner of
                    P1 -> go seen' (xs :|> x :|> y) ys
                    P2 -> go seen' xs (ys :|> y :|> x)
            (Empty, _    ) -> (P2, ys0)
            (_    , Empty) -> (P1, xs0)
        where
          seen' = HS.insert (GS xs0 ys0) seen
  {-# INLINE playGameWith #-}
  
  game1 :: Deck -> Deck -> (Player, Deck)
  game1 = playGameWith $ \_ _ -> Nothing
  {-# INLINE game1 #-}
  
  game2 :: Deck -> Deck -> (Player, Deck)
  game2 = playGameWith $ \(x :<|| xs) (y :<|| ys) -> do
      xs' <- takeExactly x xs
      ys' <- takeExactly y ys
      let xMax = maximum xs'
          yMax = maximum ys'
          -- P1 has unbeatable card
      pure if xMax > yMax
        then P1
        else fst $ game2 xs' ys'
  {-# INLINE game2 #-}
  
  day22a :: (Deck, Deck) :~> Deck
  day22a = MkSol
      { sParse = P.parseMaybe gameParser
      , sShow  = show . score
      , sSolve = Just . snd . uncurry game1
      }
  
  day22b :: (Deck, Deck) :~> Deck
  day22b = MkSol
      { sParse = P.parseMaybe gameParser
      , sShow  = show . score
      , sSolve = Just . snd . uncurry game2
      }
  
  takeExactly :: Int -> Seq a -> Maybe (Seq a)
  takeExactly n xs = Seq.take n xs <$ guard (Seq.length xs >= n)
  {-# INLINE takeExactly #-}
  
  gameParser :: P.Parsec Void String (Deck, Deck)
  gameParser = (,) <$> deckParser <*> deckParser
    where
      deckParser = do
        _ :: Int <- "Player " *> PP.decimal <* ":" <* P.newline
        fmap Seq.fromList . P.many $ PP.decimal <* P.many P.newline
  
  