{-# 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 (Int -> Player -> ShowS
[Player] -> ShowS
Player -> String
(Int -> Player -> ShowS)
-> (Player -> String) -> ([Player] -> ShowS) -> Show Player
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Player] -> ShowS
$cshowList :: [Player] -> ShowS
show :: Player -> String
$cshow :: Player -> String
showsPrec :: Int -> Player -> ShowS
$cshowsPrec :: Int -> Player -> ShowS
Show, Player -> Player -> Bool
(Player -> Player -> Bool)
-> (Player -> Player -> Bool) -> Eq Player
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Player -> Player -> Bool
$c/= :: Player -> Player -> Bool
== :: Player -> Player -> Bool
$c== :: Player -> Player -> Bool
Eq, Eq Player
Eq Player
-> (Player -> Player -> Ordering)
-> (Player -> Player -> Bool)
-> (Player -> Player -> Bool)
-> (Player -> Player -> Bool)
-> (Player -> Player -> Bool)
-> (Player -> Player -> Player)
-> (Player -> Player -> Player)
-> Ord Player
Player -> Player -> Bool
Player -> Player -> Ordering
Player -> Player -> Player
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Player -> Player -> Player
$cmin :: Player -> Player -> Player
max :: Player -> Player -> Player
$cmax :: Player -> Player -> Player
>= :: Player -> Player -> Bool
$c>= :: Player -> Player -> Bool
> :: Player -> Player -> Bool
$c> :: Player -> Player -> Bool
<= :: Player -> Player -> Bool
$c<= :: Player -> Player -> Bool
< :: Player -> Player -> Bool
$c< :: Player -> Player -> Bool
compare :: Player -> Player -> Ordering
$ccompare :: Player -> Player -> Ordering
Ord, (forall x. Player -> Rep Player x)
-> (forall x. Rep Player x -> Player) -> Generic Player
forall x. Rep Player x -> Player
forall x. Player -> Rep Player x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Player x -> Player
$cfrom :: forall x. Player -> Rep Player x
Generic)
instance NFData Player

data GameState = GS Deck Deck
  deriving GameState -> GameState -> Bool
(GameState -> GameState -> Bool)
-> (GameState -> GameState -> Bool) -> Eq GameState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GameState -> GameState -> Bool
$c/= :: GameState -> GameState -> Bool
== :: GameState -> GameState -> Bool
$c== :: GameState -> GameState -> Bool
Eq
instance Hashable GameState where
    hashWithSalt :: Int -> GameState -> Int
hashWithSalt Int
s (GS Deck
xs Deck
ys) =
      Int -> ([Int], [Int], Int) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s
        ( Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
2 (Deck -> [Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Deck
xs)
        , Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
2 (Deck -> [Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Deck
ys)
        , Deck -> Int
forall a. Seq a -> Int
Seq.length Deck
xs
        )

score :: Deck -> Int
score :: Deck -> Int
score = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Deck -> [Int]) -> Deck -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(*) [Int
1..] ([Int] -> [Int]) -> (Deck -> [Int]) -> Deck -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> (Deck -> [Int]) -> Deck -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deck -> [Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

playGameWith
    :: (NEDeck -> NEDeck -> Maybe Player)       -- ^ recurse
    -> Deck
    -> Deck
    -> (Player, Deck)
playGameWith :: (NEDeck -> NEDeck -> Maybe Player)
-> Deck -> Deck -> (Player, Deck)
playGameWith NEDeck -> NEDeck -> Maybe Player
f = HashSet GameState -> Deck -> Deck -> (Player, Deck)
go HashSet GameState
forall a. HashSet a
HS.empty
  where
    go :: HashSet GameState -> Deck -> Deck -> (Player, Deck)
    go :: HashSet GameState -> Deck -> Deck -> (Player, Deck)
go !HashSet GameState
seen !Deck
xs0 !Deck
ys0
      | Deck -> Deck -> GameState
GS Deck
xs0 Deck
ys0 GameState -> HashSet GameState -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet GameState
seen = (Player
P1, Deck
xs0)
      | Bool
otherwise = case (Deck
xs0, Deck
ys0) of
          (Int
x :<| Deck
xs, Int
y :<| Deck
ys) ->
            let winner :: Player
winner = case NEDeck -> NEDeck -> Maybe Player
f (Int
x Int -> Deck -> NEDeck
forall a. a -> Seq a -> NESeq a
:<|| Deck
xs) (Int
y Int -> Deck -> NEDeck
forall a. a -> Seq a -> NESeq a
:<|| Deck
ys) of
                  Maybe Player
Nothing -> if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
y then Player
P1 else Player
P2
                  Just Player
p  -> Player
p
            in  case Player
winner of
                  Player
P1 -> HashSet GameState -> Deck -> Deck -> (Player, Deck)
go HashSet GameState
seen' (Deck
xs Deck -> Int -> Deck
forall a. Seq a -> a -> Seq a
:|> Int
x Deck -> Int -> Deck
forall a. Seq a -> a -> Seq a
:|> Int
y) Deck
ys
                  Player
P2 -> HashSet GameState -> Deck -> Deck -> (Player, Deck)
go HashSet GameState
seen' Deck
xs (Deck
ys Deck -> Int -> Deck
forall a. Seq a -> a -> Seq a
:|> Int
y Deck -> Int -> Deck
forall a. Seq a -> a -> Seq a
:|> Int
x)
          (Deck
Empty, Deck
_    ) -> (Player
P2, Deck
ys0)
          (Deck
_    , Deck
Empty) -> (Player
P1, Deck
xs0)
      where
        seen' :: HashSet GameState
seen' = GameState -> HashSet GameState -> HashSet GameState
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert (Deck -> Deck -> GameState
GS Deck
xs0 Deck
ys0) HashSet GameState
seen
{-# INLINE playGameWith #-}

game1 :: Deck -> Deck -> (Player, Deck)
game1 :: Deck -> Deck -> (Player, Deck)
game1 = (NEDeck -> NEDeck -> Maybe Player)
-> Deck -> Deck -> (Player, Deck)
playGameWith ((NEDeck -> NEDeck -> Maybe Player)
 -> Deck -> Deck -> (Player, Deck))
-> (NEDeck -> NEDeck -> Maybe Player)
-> Deck
-> Deck
-> (Player, Deck)
forall a b. (a -> b) -> a -> b
$ \NEDeck
_ NEDeck
_ -> Maybe Player
forall a. Maybe a
Nothing
{-# INLINE game1 #-}

game2 :: Deck -> Deck -> (Player, Deck)
game2 :: Deck -> Deck -> (Player, Deck)
game2 = (NEDeck -> NEDeck -> Maybe Player)
-> Deck -> Deck -> (Player, Deck)
playGameWith ((NEDeck -> NEDeck -> Maybe Player)
 -> Deck -> Deck -> (Player, Deck))
-> (NEDeck -> NEDeck -> Maybe Player)
-> Deck
-> Deck
-> (Player, Deck)
forall a b. (a -> b) -> a -> b
$ \(Int
x :<|| Deck
xs) (Int
y :<|| Deck
ys) -> do
    Deck
xs' <- Int -> Deck -> Maybe Deck
forall a. Int -> Seq a -> Maybe (Seq a)
takeExactly Int
x Deck
xs
    Deck
ys' <- Int -> Deck -> Maybe Deck
forall a. Int -> Seq a -> Maybe (Seq a)
takeExactly Int
y Deck
ys
    let xMax :: Int
xMax = Deck -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Deck
xs'
        yMax :: Int
yMax = Deck -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Deck
ys'
        -- P1 has unbeatable card
    Player -> Maybe Player
forall (f :: * -> *) a. Applicative f => a -> f a
pure if Int
xMax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
yMax
      then Player
P1
      else (Player, Deck) -> Player
forall a b. (a, b) -> a
fst ((Player, Deck) -> Player) -> (Player, Deck) -> Player
forall a b. (a -> b) -> a -> b
$ Deck -> Deck -> (Player, Deck)
game2 Deck
xs' Deck
ys'
{-# INLINE game2 #-}

day22a :: (Deck, Deck) :~> Deck
day22a :: (Deck, Deck) :~> Deck
day22a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (Deck, Deck)
sParse = Parsec Void String (Deck, Deck) -> String -> Maybe (Deck, Deck)
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
P.parseMaybe Parsec Void String (Deck, Deck)
gameParser
    , sShow :: Deck -> String
sShow  = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Deck -> Int) -> Deck -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deck -> Int
score
    , sSolve :: (?dyno::DynoMap) => (Deck, Deck) -> Maybe Deck
sSolve = Deck -> Maybe Deck
forall a. a -> Maybe a
Just (Deck -> Maybe Deck)
-> ((Deck, Deck) -> Deck) -> (Deck, Deck) -> Maybe Deck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Player, Deck) -> Deck
forall a b. (a, b) -> b
snd ((Player, Deck) -> Deck)
-> ((Deck, Deck) -> (Player, Deck)) -> (Deck, Deck) -> Deck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Deck -> Deck -> (Player, Deck)) -> (Deck, Deck) -> (Player, Deck)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Deck -> Deck -> (Player, Deck)
game1
    }

day22b :: (Deck, Deck) :~> Deck
day22b :: (Deck, Deck) :~> Deck
day22b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (Deck, Deck)
sParse = Parsec Void String (Deck, Deck) -> String -> Maybe (Deck, Deck)
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
P.parseMaybe Parsec Void String (Deck, Deck)
gameParser
    , sShow :: Deck -> String
sShow  = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Deck -> Int) -> Deck -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deck -> Int
score
    , sSolve :: (?dyno::DynoMap) => (Deck, Deck) -> Maybe Deck
sSolve = Deck -> Maybe Deck
forall a. a -> Maybe a
Just (Deck -> Maybe Deck)
-> ((Deck, Deck) -> Deck) -> (Deck, Deck) -> Maybe Deck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Player, Deck) -> Deck
forall a b. (a, b) -> b
snd ((Player, Deck) -> Deck)
-> ((Deck, Deck) -> (Player, Deck)) -> (Deck, Deck) -> Deck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Deck -> Deck -> (Player, Deck)) -> (Deck, Deck) -> (Player, Deck)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Deck -> Deck -> (Player, Deck)
game2
    }

takeExactly :: Int -> Seq a -> Maybe (Seq a)
takeExactly :: forall a. Int -> Seq a -> Maybe (Seq a)
takeExactly Int
n Seq a
xs = Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Seq.take Int
n Seq a
xs Seq a -> Maybe () -> Maybe (Seq a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n)
{-# INLINE takeExactly #-}

gameParser :: P.Parsec Void String (Deck, Deck)
gameParser :: Parsec Void String (Deck, Deck)
gameParser = (,) (Deck -> Deck -> (Deck, Deck))
-> ParsecT Void String Identity Deck
-> ParsecT Void String Identity (Deck -> (Deck, Deck))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Deck
deckParser ParsecT Void String Identity (Deck -> (Deck, Deck))
-> ParsecT Void String Identity Deck
-> Parsec Void String (Deck, Deck)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void String Identity Deck
deckParser
  where
    deckParser :: ParsecT Void String Identity Deck
deckParser = do
      Int
_ :: Int <- ParsecT Void String Identity String
"Player " ParsecT Void String Identity String
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> 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 Int
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
":" ParsecT Void String Identity Int
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.newline
      ([Int] -> Deck)
-> ParsecT Void String Identity [Int]
-> ParsecT Void String Identity Deck
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Deck
forall a. [a] -> Seq a
Seq.fromList (ParsecT Void String Identity [Int]
 -> ParsecT Void String Identity Deck)
-> (ParsecT Void String Identity Int
    -> ParsecT Void String Identity [Int])
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Deck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void String Identity Int
-> ParsecT Void String Identity [Int]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (ParsecT Void String Identity Int
 -> ParsecT Void String Identity Deck)
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Deck
forall a b. (a -> b) -> a -> 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 Int
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.newline