{-# LANGUAGE OverloadedStrings #-}
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)
-> 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'
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