{-# LANGUAGE ScopedTypeVariables #-}
module Dovin.Helpers where
import Dovin.Types
import Dovin.Prelude
import Dovin.Matchers
import Dovin.Effects (resolveEffects)
import Data.List (sort)
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Control.Lens (ASetter, _Just)
import Control.Monad.Reader (ask)
import Text.Parsec
hasAttribute :: CardAttribute -> Card -> Bool
hasAttribute CardAttribute
attr = CardAttribute -> Set CardAttribute -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member CardAttribute
attr (Set CardAttribute -> Bool)
-> (Card -> Set CardAttribute) -> Card -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set CardAttribute) Card (Set CardAttribute)
-> Card -> Set CardAttribute
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set CardAttribute) Card (Set CardAttribute)
Lens' Card (Set CardAttribute)
cardAttributes
manaSpec :: ParsecT CardAttribute u Identity CardAttribute
manaSpec = [CardAttribute] -> CardAttribute
forall a. Monoid a => [a] -> a
mconcat ([CardAttribute] -> CardAttribute)
-> ParsecT CardAttribute u Identity [CardAttribute]
-> ParsecT CardAttribute u Identity CardAttribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity [CardAttribute]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT CardAttribute u Identity CardAttribute
forall u. ParsecT CardAttribute u Identity CardAttribute
colorless ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity CardAttribute
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT CardAttribute u Identity CardAttribute
forall u. ParsecT CardAttribute u Identity CardAttribute
colored)
where
colorless :: ParsecT CardAttribute u Identity CardAttribute
colorless = do
Int
n <- CardAttribute -> Int
forall a. Read a => CardAttribute -> a
read (CardAttribute -> Int)
-> ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CardAttribute u Identity Char
-> ParsecT CardAttribute u Identity CardAttribute
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT CardAttribute u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
CardAttribute -> ParsecT CardAttribute u Identity CardAttribute
forall (m :: * -> *) a. Monad m => a -> m a
return (CardAttribute -> ParsecT CardAttribute u Identity CardAttribute)
-> CardAttribute -> ParsecT CardAttribute u Identity CardAttribute
forall a b. (a -> b) -> a -> b
$ Int -> Char -> CardAttribute
forall a. Int -> a -> [a]
replicate Int
n Char
'X'
colored :: ParsecT CardAttribute u Identity CardAttribute
colored = ParsecT CardAttribute u Identity Char
-> ParsecT CardAttribute u Identity CardAttribute
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (CardAttribute -> ParsecT CardAttribute u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
CardAttribute -> ParsecT s u m Char
oneOf CardAttribute
"RUGBW")
parseMana :: String -> ManaPool
parseMana :: CardAttribute -> CardAttribute
parseMana CardAttribute
pool =
case Parsec CardAttribute () CardAttribute
-> CardAttribute
-> CardAttribute
-> Either ParseError CardAttribute
forall s t a.
Stream s Identity t =>
Parsec s () a -> CardAttribute -> s -> Either ParseError a
parse Parsec CardAttribute () CardAttribute
forall u. ParsecT CardAttribute u Identity CardAttribute
manaSpec CardAttribute
"mana" CardAttribute
pool of
Left ParseError
err -> CardAttribute
forall a. Monoid a => a
mempty
Right CardAttribute
x -> CardAttribute -> CardAttribute
forall a. Ord a => [a] -> [a]
sort CardAttribute
x
requireCard :: CardName -> CardMatcher -> GameMonad Card
requireCard :: CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
name CardMatcher
f = do
Maybe Card
maybeCard <- Getting (Maybe Card) Board (Maybe Card)
-> ExceptT
CardAttribute
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(Maybe Card)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting (Maybe Card) Board (Maybe Card)
-> ExceptT
CardAttribute
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(Maybe Card))
-> Getting (Maybe Card) Board (Maybe Card)
-> ExceptT
CardAttribute
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(Maybe Card)
forall a b. (a -> b) -> a -> b
$ (HashMap CardAttribute Card
-> Const (Maybe Card) (HashMap CardAttribute Card))
-> Board -> Const (Maybe Card) Board
Lens' Board (HashMap CardAttribute Card)
resolvedCards ((HashMap CardAttribute Card
-> Const (Maybe Card) (HashMap CardAttribute Card))
-> Board -> Const (Maybe Card) Board)
-> ((Maybe Card -> Const (Maybe Card) (Maybe Card))
-> HashMap CardAttribute Card
-> Const (Maybe Card) (HashMap CardAttribute Card))
-> Getting (Maybe Card) Board (Maybe Card)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap CardAttribute Card)
-> Lens'
(HashMap CardAttribute Card)
(Maybe (IxValue (HashMap CardAttribute Card)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at CardAttribute
Index (HashMap CardAttribute Card)
name
case Maybe Card
maybeCard of
Maybe Card
Nothing -> CardAttribute -> GameMonad Card
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CardAttribute -> GameMonad Card)
-> CardAttribute -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardAttribute
"Card does not exist: " CardAttribute -> CardAttribute -> CardAttribute
forall a. Semigroup a => a -> a -> a
<> CardAttribute
name
Just Card
card ->
case CardMatcher -> Card -> Either CardAttribute ()
applyMatcherWithDesc CardMatcher
f Card
card of
Right () -> Card -> GameMonad Card
forall (m :: * -> *) a. Monad m => a -> m a
return Card
card
Left CardAttribute
msg ->
CardAttribute -> GameMonad Card
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CardAttribute -> GameMonad Card)
-> CardAttribute -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardAttribute
name CardAttribute -> CardAttribute -> CardAttribute
forall a. Semigroup a => a -> a -> a
<> CardAttribute
" does not match requirements: " CardAttribute -> CardAttribute -> CardAttribute
forall a. Semigroup a => a -> a -> a
<> CardAttribute
msg
allCards :: GameMonad [Card]
allCards :: GameMonad [Card]
allCards = HashMap CardAttribute Card -> [Card]
forall k v. HashMap k v -> [v]
M.elems (HashMap CardAttribute Card -> [Card])
-> ExceptT
CardAttribute
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(HashMap CardAttribute Card)
-> GameMonad [Card]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
(HashMap CardAttribute Card) Board (HashMap CardAttribute Card)
-> ExceptT
CardAttribute
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(HashMap CardAttribute Card)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(HashMap CardAttribute Card) Board (HashMap CardAttribute Card)
Lens' Board (HashMap CardAttribute Card)
resolvedCards
modifyCardDeprecated :: CardName -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated :: CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
name ASetter Card Card a b
lens a -> b
f = do
ASetter Board Board BaseCard BaseCard
-> (BaseCard -> BaseCard) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
((HashMap CardAttribute BaseCard
-> Identity (HashMap CardAttribute BaseCard))
-> Board -> Identity Board
Lens' Board (HashMap CardAttribute BaseCard)
cards ((HashMap CardAttribute BaseCard
-> Identity (HashMap CardAttribute BaseCard))
-> Board -> Identity Board)
-> ((BaseCard -> Identity BaseCard)
-> HashMap CardAttribute BaseCard
-> Identity (HashMap CardAttribute BaseCard))
-> ASetter Board Board BaseCard BaseCard
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap CardAttribute BaseCard)
-> Lens'
(HashMap CardAttribute BaseCard)
(Maybe (IxValue (HashMap CardAttribute BaseCard)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at CardAttribute
Index (HashMap CardAttribute BaseCard)
name ((Maybe BaseCard -> Identity (Maybe BaseCard))
-> HashMap CardAttribute BaseCard
-> Identity (HashMap CardAttribute BaseCard))
-> ((BaseCard -> Identity BaseCard)
-> Maybe BaseCard -> Identity (Maybe BaseCard))
-> (BaseCard -> Identity BaseCard)
-> HashMap CardAttribute BaseCard
-> Identity (HashMap CardAttribute BaseCard)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BaseCard -> Identity BaseCard)
-> Maybe BaseCard -> Identity (Maybe BaseCard)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
(\(BaseCard Card
c) -> Card -> BaseCard
BaseCard (Card -> BaseCard) -> Card -> BaseCard
forall a b. (a -> b) -> a -> b
$ ASetter Card Card a b -> (a -> b) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card a b
lens a -> b
f Card
c)
Card
card <- CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
name CardMatcher
forall a. Monoid a => a
mempty
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Int Card Int -> Card -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int Card Int
Lens' Card Int
cardPlusOneCounters Card
card Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
CardAttribute -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CardAttribute
"Cannot reduce +1/+1 counters to less than 0"
GameMonad ()
resolveEffects
modifyCard :: ASetter Card Card a b -> (a -> b) -> CardName -> GameMonad ()
modifyCard :: ASetter Card Card a b -> (a -> b) -> CardAttribute -> GameMonad ()
modifyCard ASetter Card Card a b
lens a -> b
f CardAttribute
name = CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
forall a b.
CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
name ASetter Card Card a b
lens a -> b
f
loseAttribute :: CardAttribute -> CardAttribute -> GameMonad ()
loseAttribute CardAttribute
attr CardAttribute
cn = do
Card
c <- CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
cn CardMatcher
forall a. Monoid a => a
mempty
CardAttribute
-> ASetter Card Card Card Card -> (Card -> Card) -> GameMonad ()
forall a b.
CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
cn ASetter Card Card Card Card
forall a. a -> a
id (CardAttribute -> Card -> Card
removeAttribute CardAttribute
attr)
removeAttribute :: CardAttribute -> Card -> Card
removeAttribute :: CardAttribute -> Card -> Card
removeAttribute CardAttribute
attr = ASetter Card Card (Set CardAttribute) (Set CardAttribute)
-> (Set CardAttribute -> Set CardAttribute) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card (Set CardAttribute) (Set CardAttribute)
Lens' Card (Set CardAttribute)
cardAttributes (CardAttribute -> Set CardAttribute -> Set CardAttribute
forall a. Ord a => a -> Set a -> Set a
S.delete CardAttribute
attr)
gainAttribute :: CardAttribute -> CardAttribute -> GameMonad ()
gainAttribute CardAttribute
attr CardAttribute
cn = do
Card
c <- CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
cn CardMatcher
forall a. Monoid a => a
mempty
CardAttribute
-> ASetter Card Card Card Card -> (Card -> Card) -> GameMonad ()
forall a b.
CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
cn ASetter Card Card Card Card
forall a. a -> a
id (CardAttribute -> Card -> Card
setAttribute CardAttribute
attr)
setAttribute :: CardAttribute -> Card -> Card
setAttribute :: CardAttribute -> Card -> Card
setAttribute CardAttribute
attr = ASetter Card Card (Set CardAttribute) (Set CardAttribute)
-> (Set CardAttribute -> Set CardAttribute) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card (Set CardAttribute) (Set CardAttribute)
Lens' Card (Set CardAttribute)
cardAttributes (CardAttribute -> Set CardAttribute -> Set CardAttribute
forall a. Ord a => a -> Set a -> Set a
S.insert CardAttribute
attr)
forCards :: CardMatcher -> (CardName -> GameMonad ()) -> GameMonad ()
forCards :: CardMatcher -> (CardAttribute -> GameMonad ()) -> GameMonad ()
forCards CardMatcher
matcher CardAttribute -> GameMonad ()
f = do
[Card]
cs <- GameMonad [Card]
allCards
let matchingCs :: [Card]
matchingCs = (Card -> Bool) -> [Card] -> [Card]
forall a. (a -> Bool) -> [a] -> [a]
filter (CardMatcher -> Card -> Bool
applyMatcher CardMatcher
matcher) [Card]
cs
[CardAttribute] -> (CardAttribute -> GameMonad ()) -> GameMonad ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Card -> CardAttribute) -> [Card] -> [CardAttribute]
forall a b. (a -> b) -> [a] -> [b]
map (Getting CardAttribute Card CardAttribute -> Card -> CardAttribute
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardAttribute Card CardAttribute
Lens' Card CardAttribute
cardName) [Card]
matchingCs) CardAttribute -> GameMonad ()
f
gameFinished :: GameMonad Bool
gameFinished :: GameMonad Bool
gameFinished = do
Phase
state <- Getting Phase Board Phase
-> ExceptT
CardAttribute
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Phase
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Phase Board Phase
Lens' Board Phase
phase
Bool -> GameMonad Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> GameMonad Bool) -> Bool -> GameMonad Bool
forall a b. (a -> b) -> a -> b
$ case Phase
state of
Won Player
_ -> Bool
True
Phase
_ -> Bool
False
getTimestamp :: GameMonad Timestamp
getTimestamp :: GameMonad Timestamp
getTimestamp = Getting Timestamp Board Timestamp -> GameMonad Timestamp
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Timestamp Board Timestamp
Lens' Board Timestamp
currentTime