module Dovin.Actions (
step
, fork
, cast
, castFromLocation
, counter
, flashback
, jumpstart
, resolve
, resolveTop
, resolveMentor
, splice
, tapForMana
, target
, targetInLocation
, activate
, activatePlaneswalker
, addEffect
, attackWith
, combatDamage
, copySpell
, damage
, destroy
, discard
, exert
, exile
, fight
, gainLife
, loseLife
, modifyStrength
, moveTo
, sacrifice
, setLife
, transitionTo
, transitionToForced
, trigger
, triggerMentor
, with
, validate
, validateCanCastSorcery
, validateLife
, validatePhase
, validateRemoved
, runStateBasedActions
, withStateBasedActions
, addMana
, move
, remove
, spendMana
, tap
, untap
) where
import Dovin.Attributes
import Dovin.Helpers
import Dovin.Prelude
import Dovin.Types
import Dovin.Builder
import Dovin.Monad
import Dovin.Matchers
import Dovin.Effects (resolveEffects)
import qualified Data.HashMap.Strict as M
import Data.Maybe (listToMaybe)
import qualified Data.List
import Control.Arrow (second)
import Control.Monad.Reader (local)
import Control.Monad.State
import Control.Monad.Writer
import Control.Lens
action :: String -> GameMonad () -> GameMonad ()
action :: String -> GameMonad () -> GameMonad ()
action String
name GameMonad ()
m = GameMonad ()
m
addMana :: ManaString -> GameMonad ()
addMana :: String -> GameMonad ()
addMana String
amount = do
Player
p <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
ASetter Board Board String String
-> (String -> String) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
(Player -> ASetter Board Board String String
forall (f :: * -> *).
Functor f =>
Player -> (String -> f String) -> Board -> f Board
manaPoolFor Player
p)
(String -> String
parseMana String
amount String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)
cast :: ManaPool -> CardName -> GameMonad ()
cast :: String -> String -> GameMonad ()
cast String
mana String
cn = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
CardLocation -> String -> String -> GameMonad ()
castFromLocation (Player
actor, Location
Hand) String
mana String
cn
castFromLocation :: CardLocation -> ManaPool -> CardName -> GameMonad ()
castFromLocation :: CardLocation -> String -> String -> GameMonad ()
castFromLocation CardLocation
loc String
mana String
name = String -> GameMonad () -> GameMonad ()
action String
"castFromLocation" (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
Card
card <- String -> CardMatcher -> GameMonad Card
requireCard String
name CardMatcher
forall a. Monoid a => a
mempty
CardMatcher -> String -> GameMonad ()
validate (CardLocation -> CardMatcher
matchLocation CardLocation
loc) String
name
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(String -> Card -> Bool
hasAttribute String
instant Card
card Bool -> Bool -> Bool
|| String -> Card -> Bool
hasAttribute String
flash Card
card)
GameMonad ()
validateCanCastSorcery
ASetter Card Card Location Location
-> (Location -> Location) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ((CardLocation -> Identity CardLocation) -> Card -> Identity Card
Lens' Card CardLocation
location ((CardLocation -> Identity CardLocation) -> Card -> Identity Card)
-> ((Location -> Identity Location)
-> CardLocation -> Identity CardLocation)
-> ASetter Card Card Location Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> Identity Location)
-> CardLocation -> Identity CardLocation
forall s t a b. Field2 s t a b => Lens s t a b
_2) (Location -> Location -> Location
forall a b. a -> b -> a
const Location
Stack) String
name
Card
card <- String -> CardMatcher -> GameMonad Card
requireCard String
name CardMatcher
forall a. Monoid a => a
mempty
String -> GameMonad ()
spendMana String
mana
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(String -> Card -> Bool
hasAttribute String
sorcery Card
card Bool -> Bool -> Bool
|| String -> Card -> Bool
hasAttribute String
instant Card
card) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
ASetter Board Board Int Int -> (Int -> Int) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
((HashMap String Int -> Identity (HashMap String Int))
-> Board -> Identity Board
Lens' Board (HashMap String Int)
counters ((HashMap String Int -> Identity (HashMap String Int))
-> Board -> Identity Board)
-> ((Int -> Identity Int)
-> HashMap String Int -> Identity (HashMap String Int))
-> ASetter Board Board Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap String Int)
-> Lens'
(HashMap String Int) (Maybe (IxValue (HashMap String Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (HashMap String Int)
storm ((Maybe Int -> Identity (Maybe Int))
-> HashMap String Int -> Identity (HashMap String Int))
-> ((Int -> Identity Int) -> Maybe Int -> Identity (Maybe Int))
-> (Int -> Identity Int)
-> HashMap String Int
-> Identity (HashMap String Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0)
(Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
ASetter Board Board [String] [String]
-> ([String] -> [String]) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
ASetter Board Board [String] [String]
Lens' Board [String]
stack
((:) String
name)
counter :: CardName -> GameMonad ()
counter :: String -> GameMonad ()
counter String
expectedName = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
expectedName (CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$
String -> CardMatcher -> CardMatcher
labelMatch String
"on stack" (CardLocation -> CardMatcher
matchLocation (Player
actor, Location
Stack))
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> CardMatcher -> CardMatcher
invert ( String -> CardMatcher
matchAttribute String
triggered
CardMatcher -> CardMatcher -> CardMatcher
`matchOr` String -> CardMatcher
matchAttribute String
activated)
Location -> String -> GameMonad ()
moveTo Location
Graveyard String
expectedName
ASetter Board Board [String] [String]
-> ([String] -> [String]) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
ASetter Board Board [String] [String]
Lens' Board [String]
stack
(String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
Data.List.delete String
expectedName)
flashback :: ManaPool -> CardName -> GameMonad ()
flashback :: String -> String -> GameMonad ()
flashback String
mana String
castName = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
String -> GameMonad ()
spendMana String
mana
CardLocation -> String -> String -> GameMonad ()
castFromLocation (Player
actor, Location
Graveyard) String
"" String
castName
String -> String -> GameMonad ()
gainAttribute String
exileWhenLeaveStack String
castName
jumpstart :: ManaPool -> CardName -> CardName -> GameMonad ()
jumpstart :: String -> String -> String -> GameMonad ()
jumpstart String
mana String
discardName String
castName = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
String -> GameMonad ()
spendMana String
mana
String -> GameMonad ()
discard String
discardName
CardLocation -> String -> String -> GameMonad ()
castFromLocation (Player
actor, Location
Graveyard) String
"" String
castName
String -> String -> GameMonad ()
gainAttribute String
exileWhenLeaveStack String
castName
resolve :: CardName -> GameMonad ()
resolve :: String -> GameMonad ()
resolve String
expectedName = do
[String]
s <- Getting [String] Board [String]
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
[String]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [String] Board [String]
Lens' Board [String]
stack
case [String]
s of
[] -> String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
"stack is empty, expecting " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expectedName
(String
name:[String]
ss) -> do
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expectedName) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
"unexpected top of stack: expected "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expectedName
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", got "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
GameMonad ()
resolveTop
resolveTop :: GameMonad ()
resolveTop :: GameMonad ()
resolveTop = String -> GameMonad () -> GameMonad ()
action String
"resolveTop" (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
[String]
s <- Getting [String] Board [String]
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
[String]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [String] Board [String]
Lens' Board [String]
stack
case [String]
s of
[] -> String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"stack is empty"
(String
x:[String]
xs) -> do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
x CardMatcher
forall a. Monoid a => a
mempty
if String -> Card -> Bool
hasAttribute String
instant Card
c Bool -> Bool -> Bool
|| String -> Card -> Bool
hasAttribute String
sorcery Card
c then
Location -> String -> GameMonad ()
moveTo Location
Graveyard String
x
else if String -> Card -> Bool
hasAttribute String
triggered Card
c Bool -> Bool -> Bool
|| String -> Card -> Bool
hasAttribute String
activated Card
c then
String -> GameMonad ()
remove String
x
else
Location -> String -> GameMonad ()
moveTo Location
Play String
x
ASetter Board Board [String] [String] -> [String] -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter Board Board [String] [String]
Lens' Board [String]
stack [String]
xs
resolveMentor :: String -> String -> GameMonad ()
resolveMentor String
targetName String
sourceName = do
let triggerName :: String
triggerName = String
"Mentor " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
targetName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sourceName
String -> GameMonad ()
resolve String
triggerName
Card
source <- String -> CardMatcher -> GameMonad Card
requireCard String
sourceName CardMatcher
forall a. Monoid a => a
mempty
Card
_ <- String -> CardMatcher -> GameMonad Card
requireCard String
targetName (CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$
String -> CardMatcher
matchAttribute String
attacking
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> Int -> CardMatcher
matchLesserPower (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
cardPower Card
source)
(Int, Int) -> String -> GameMonad ()
modifyStrength (Int
1, Int
1) String
targetName
sacrifice :: CardName -> GameMonad ()
sacrifice :: String -> GameMonad ()
sacrifice String
cn = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
CardMatcher -> String -> GameMonad ()
validate (Player -> CardMatcher
matchController Player
actor CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> CardMatcher
matchInPlay) String
cn
Location -> String -> GameMonad ()
moveTo Location
Graveyard String
cn
splice :: CardName -> ManaString -> CardName -> GameMonad ()
splice :: String -> String -> String -> GameMonad ()
splice String
target String
cost String
name = String -> GameMonad () -> GameMonad ()
action String
"splice" (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
CardMatcher -> String -> GameMonad ()
validate (String -> CardMatcher
matchAttribute String
arcane) String
target
CardMatcher -> String -> GameMonad ()
validate (CardLocation -> CardMatcher
matchLocation (Player
actor, Location
Stack)) String
target
GameMonad () -> (String -> GameMonad ()) -> GameMonad ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` GameMonad () -> String -> GameMonad ()
forall a b. a -> b -> a
const (String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
target String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not on stack")
CardMatcher -> String -> GameMonad ()
validate (CardLocation -> CardMatcher
matchLocation (Player
actor, Location
Hand)) String
name
GameMonad () -> (String -> GameMonad ()) -> GameMonad ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` GameMonad () -> String -> GameMonad ()
forall a b. a -> b -> a
const (String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not in hand")
String -> GameMonad ()
spendMana String
cost
tapForMana :: ManaString -> CardName -> GameMonad ()
tapForMana :: String -> String -> GameMonad ()
tapForMana String
amount String
name = do
String -> GameMonad ()
tap String
name
String -> GameMonad ()
addMana String
amount
transitionTo :: Phase -> GameMonad ()
transitionTo :: Phase -> GameMonad ()
transitionTo Phase
newPhase = do
Phase
actual <- Getting Phase Board Phase
-> ExceptT
String (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 () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Phase
newPhase Phase -> Phase -> Bool
forall a. Ord a => a -> a -> Bool
<= Phase
actual) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
"phase "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Phase -> String
forall a. Show a => a -> String
show Phase
newPhase
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not occur after "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Phase -> String
forall a. Show a => a -> String
show Phase
actual
Phase -> GameMonad ()
transitionToForced Phase
newPhase
transitionToForced :: Phase -> GameMonad ()
transitionToForced :: Phase -> GameMonad ()
transitionToForced Phase
newPhase = do
ASetter Board Board (HashMap Player String) (HashMap Player String)
-> HashMap Player String -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter Board Board (HashMap Player String) (HashMap Player String)
Lens' Board (HashMap Player String)
manaPool HashMap Player String
forall a. Monoid a => a
mempty
ASetter Board Board Phase Phase -> Phase -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter Board Board Phase Phase
Lens' Board Phase
phase Phase
newPhase
trigger :: CardName -> CardName -> GameMonad ()
trigger :: String -> String -> GameMonad ()
trigger String
triggerName String
sourceName = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
Card
card <-
String -> CardMatcher -> GameMonad Card
requireCard
String
sourceName
( Player -> CardMatcher
matchController Player
actor
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher -> CardMatcher
labelMatch String
"in play or graveyard" (
CardLocation -> CardMatcher
matchLocation (Player
actor, Location
Play)
CardMatcher -> CardMatcher -> CardMatcher
`matchOr`
CardLocation -> CardMatcher
matchLocation (Player
actor, Location
Graveyard)
)
)
Location -> GameMonad () -> GameMonad ()
withLocation Location
Stack (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String -> GameMonad () -> GameMonad ()
withAttribute String
triggered (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String -> GameMonad ()
addCard String
triggerName
ASetter Board Board [String] [String]
-> ([String] -> [String]) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
ASetter Board Board [String] [String]
Lens' Board [String]
stack
((:) String
triggerName)
triggerMentor :: CardName -> CardName -> GameMonad ()
triggerMentor :: String -> String -> GameMonad ()
triggerMentor String
targetName String
sourceName = do
Card
source <- String -> CardMatcher -> GameMonad Card
requireCard String
sourceName (CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ [String] -> CardMatcher
matchAttributes [String
attacking, String
mentor]
Card
_ <- String -> CardMatcher -> GameMonad Card
requireCard String
targetName (CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$
String -> CardMatcher
matchAttribute String
attacking
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> Int -> CardMatcher
matchLesserPower (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
cardPower Card
source)
String -> String -> GameMonad ()
trigger (String
"Mentor " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
targetName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sourceName) String
sourceName
with :: CardName -> (CardName -> GameMonad ()) -> GameMonad ()
with :: String -> (String -> GameMonad ()) -> GameMonad ()
with String
x String -> GameMonad ()
f = String -> GameMonad ()
f String
x
move :: CardLocation -> CardLocation -> CardName -> GameMonad ()
move :: CardLocation -> CardLocation -> String -> GameMonad ()
move CardLocation
from CardLocation
to String
name = String -> GameMonad () -> GameMonad ()
action String
"move" (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
name (CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardLocation -> CardMatcher
matchLocation CardLocation
from
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardLocation
from CardLocation -> CardLocation -> Bool
forall a. Eq a => a -> a -> Bool
== CardLocation
to) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"cannot move to same location"
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
to Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
Stack) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"cannot move directly to stack"
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Card -> Bool
hasAttribute String
token Card
c Bool -> Bool -> Bool
&& CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
from Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
/= Location
Play) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"cannot move token from non-play location"
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Card -> Bool
hasAttribute String
copy Card
c Bool -> Bool -> Bool
&& CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
from Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
/= Location
Stack) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"cannot move copy from non-stack location"
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
from Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
Stack) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
ASetter Board Board [String] [String]
-> ([String] -> [String]) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter Board Board [String] [String]
Lens' Board [String]
stack ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
name))
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
to Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
Play) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> String -> GameMonad ()
gainAttribute String
summoned String
name
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
from Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
Play Bool -> Bool -> Bool
&& CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
to Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
/= Location
Play) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
ASetter Card Card Int Int -> (Int -> Int) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card Int Int
Lens' Card Int
cardPlusOneCounters (Int -> Int -> Int
forall a b. a -> b -> a
const Int
0) String
name
ASetter Card Card Int Int -> (Int -> Int) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card Int Int
Lens' Card Int
cardDamage (Int -> Int -> Int
forall a b. a -> b -> a
const Int
0) String
name
ASetter Card Card CardAttributes CardAttributes
-> (CardAttributes -> CardAttributes) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card CardAttributes CardAttributes
Lens' Card CardAttributes
cardAttributes (CardAttributes -> CardAttributes -> CardAttributes
forall a b. a -> b -> a
const (CardAttributes -> CardAttributes -> CardAttributes)
-> CardAttributes -> CardAttributes -> CardAttributes
forall a b. (a -> b) -> a -> b
$ Getting CardAttributes Card CardAttributes
-> Card -> CardAttributes
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardAttributes Card CardAttributes
Lens' Card CardAttributes
cardDefaultAttributes Card
c) String
name
ASetter Card Card CardStrength CardStrength
-> (CardStrength -> CardStrength) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card CardStrength CardStrength
Lens' Card CardStrength
cardStrengthModifier (CardStrength -> CardStrength -> CardStrength
forall a b. a -> b -> a
const CardStrength
forall a. Monoid a => a
mempty) String
name
if String -> Card -> Bool
hasAttribute String
exileWhenLeaveStack Card
c then
do
String -> String -> GameMonad ()
loseAttribute String
exileWhenLeaveStack String
name
Location -> String -> GameMonad ()
moveTo Location
Exile String
name
else if CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
from Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
Play Bool -> Bool -> Bool
&& CardLocation -> Location
forall a b. (a, b) -> b
snd CardLocation
to Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
Graveyard Bool -> Bool -> Bool
&& 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
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& String -> Card -> Bool
hasAttribute String
undying Card
c then
String -> ASetter Card Card Int Int -> (Int -> Int) -> GameMonad ()
forall a b.
String -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated String
name ASetter Card Card Int Int
Lens' Card Int
cardPlusOneCounters (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
else
String
-> ((CardLocation -> Identity CardLocation)
-> Card -> Identity Card)
-> (CardLocation -> CardLocation)
-> GameMonad ()
forall a b.
String -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated String
name (CardLocation -> Identity CardLocation) -> Card -> Identity Card
Lens' Card CardLocation
location (CardLocation -> CardLocation -> CardLocation
forall a b. a -> b -> a
const CardLocation
to)
target :: CardName -> GameMonad ()
target :: String -> GameMonad ()
target String
name = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
Card
card <- String -> CardMatcher -> GameMonad Card
requireCard String
name CardMatcher
matchInPlay
let controller :: Player
controller = Getting Player Card Player -> Card -> Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((CardLocation -> Const Player CardLocation)
-> Card -> Const Player Card
Lens' Card CardLocation
cardLocation ((CardLocation -> Const Player CardLocation)
-> Card -> Const Player Card)
-> ((Player -> Const Player Player)
-> CardLocation -> Const Player CardLocation)
-> Getting Player Card Player
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Player -> Const Player Player)
-> CardLocation -> Const Player CardLocation
forall s t a b. Field1 s t a b => Lens s t a b
_1) Card
card
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Player
actor Player -> Player -> Bool
forall a. Eq a => a -> a -> Bool
== Player
controller) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
CardMatcher -> String -> GameMonad ()
validate (String -> CardMatcher
missingAttribute String
hexproof) String
name
targetInLocation :: CardLocation -> CardName -> GameMonad ()
targetInLocation :: CardLocation -> String -> GameMonad ()
targetInLocation CardLocation
zone = CardMatcher -> String -> GameMonad ()
validate (CardLocation -> CardMatcher
matchLocation CardLocation
zone)
activate :: CardName -> ManaPool -> CardName -> GameMonad ()
activate :: String -> String -> String -> GameMonad ()
activate String
stackName String
mana String
targetName = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
Card
card <-
String -> CardMatcher -> GameMonad Card
requireCard
String
targetName
( Player -> CardMatcher
matchController Player
actor
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher -> CardMatcher
labelMatch String
"in play or graveyard" (
CardLocation -> CardMatcher
matchLocation (Player
actor, Location
Play)
CardMatcher -> CardMatcher -> CardMatcher
`matchOr`
CardLocation -> CardMatcher
matchLocation (Player
actor, Location
Graveyard)
)
)
String -> GameMonad ()
spendMana String
mana
Location -> GameMonad () -> GameMonad ()
withLocation Location
Stack (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String -> GameMonad () -> GameMonad ()
withAttribute String
activated (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String -> GameMonad ()
addCard String
stackName
ASetter Board Board [String] [String]
-> ([String] -> [String]) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
ASetter Board Board [String] [String]
Lens' Board [String]
stack
((:) String
stackName)
activatePlaneswalker :: CardName -> Int -> CardName -> GameMonad ()
activatePlaneswalker :: String -> Int -> String -> GameMonad ()
activatePlaneswalker String
stackName Int
loyalty String
targetName = do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
targetName CardMatcher
matchInPlay
if 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
cardLoyalty Card
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
loyalty Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
targetName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not have enough loyalty"
else
do
ASetter Card Card Int Int -> (Int -> Int) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card Int Int
Lens' Card Int
cardLoyalty (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
loyalty) String
targetName
String -> String -> String -> GameMonad ()
activate String
stackName String
"" String
targetName
attackWith :: [CardName] -> GameMonad ()
attackWith :: [String] -> GameMonad ()
attackWith [String]
cs = do
Phase -> GameMonad ()
transitionTo Phase
DeclareAttackers
[String] -> (String -> GameMonad ()) -> GameMonad ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
cs ((String -> GameMonad ()) -> GameMonad ())
-> (String -> GameMonad ()) -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ \String
cn -> do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
cn
(CardMatcher
matchInPlay
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
"creature"
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
missingAttribute String
"defender"
CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher -> CardMatcher
labelMatch String
"does not have summoning sickness" (
String -> CardMatcher
matchAttribute String
haste
CardMatcher -> CardMatcher -> CardMatcher
`matchOr`
String -> CardMatcher
missingAttribute String
summoned
))
CardMatcher -> (String -> GameMonad ()) -> GameMonad ()
forCards
(String -> CardMatcher
matchName String
cn CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
missingAttribute String
vigilance)
String -> GameMonad ()
tap
String -> String -> GameMonad ()
gainAttribute String
attacking String
cn
combatDamage :: [CardName] -> CardName -> GameMonad ()
combatDamage :: [String] -> String -> GameMonad ()
combatDamage [String]
blockerNames String
attackerName = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
Card
attacker <- String -> CardMatcher -> GameMonad Card
requireCard String
attackerName
(CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
attacking CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> Player -> CardMatcher
matchController Player
actor
[Card]
blockers <-
(String -> GameMonad Card)
-> [String]
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
[Card]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(\String
cn -> String -> CardMatcher -> GameMonad Card
requireCard String
cn (CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
creature)
[String]
blockerNames
let power :: Int
power = 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
cardPower Card
attacker
Int
rem <- (Int
-> Card
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int)
-> Int
-> [Card]
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Card
-> Int
-> Card
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
forall p.
p
-> Int
-> Card
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
folder Card
attacker) Int
power [Card]
blockers
if String -> Card -> Bool
hasAttribute String
trample Card
attacker Bool -> Bool -> Bool
|| [Card] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Card]
blockers then
(Card -> Int) -> Target -> String -> GameMonad ()
damage (Int -> Card -> Int
forall a b. a -> b -> a
const Int
rem) (Player -> Target
targetPlayer (Player -> Target) -> (Player -> Player) -> Player -> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Player -> Player
opposing (Player -> Target) -> Player -> Target
forall a b. (a -> b) -> a -> b
$ Player
actor) String
attackerName
else
GameMonad ()
-> (Card -> GameMonad ()) -> Maybe Card -> GameMonad ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(() -> GameMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\Card
x -> (Card -> Int) -> Target -> String -> GameMonad ()
damage
(Int -> Card -> Int
forall a b. a -> b -> a
const Int
rem)
(String -> Target
targetCard (String -> Target) -> (Card -> String) -> Card -> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting String Card String -> Card -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Card String
Lens' Card String
cardName (Card -> Target) -> Card -> Target
forall a b. (a -> b) -> a -> b
$ Card
x)
String
attackerName
)
([Card] -> Maybe Card
forall a. [a] -> Maybe a
listToMaybe ([Card] -> Maybe Card)
-> ([Card] -> [Card]) -> [Card] -> Maybe Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Card] -> [Card]
forall a. [a] -> [a]
reverse ([Card] -> Maybe Card) -> [Card] -> Maybe Card
forall a b. (a -> b) -> a -> b
$ [Card]
blockers)
where
folder :: p
-> Int
-> Card
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
folder p
attacker Int
rem Card
blocker = do
let blockerName :: String
blockerName = Getting String Card String -> Card -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Card String
Lens' Card String
cardName Card
blocker
let blockerPower :: Int
blockerPower = 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
cardPower Card
blocker
let blockerToughness :: Int
blockerToughness = 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
cardToughness Card
blocker
let attackPower :: Int
attackPower = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int
blockerToughness, Int
rem]
(Card -> Int) -> Target -> String -> GameMonad ()
damage
(Int -> Card -> Int
forall a b. a -> b -> a
const Int
attackPower)
(String -> Target
targetCard String
blockerName)
String
attackerName
(Card -> Int) -> Target -> String -> GameMonad ()
damage
(Int -> Card -> Int
forall a b. a -> b -> a
const Int
blockerPower)
(String -> Target
targetCard String
attackerName)
String
blockerName
Int
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int)
-> Int
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
forall a b. (a -> b) -> a -> b
$ Int
rem Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
attackPower
copySpell :: String -> String -> GameMonad ()
copySpell String
newName String
targetName = do
Card
card <- String -> CardMatcher -> GameMonad Card
requireCard String
targetName (String -> CardMatcher -> CardMatcher
labelMatch String
"on stack" (CardMatcher -> CardMatcher) -> CardMatcher -> CardMatcher
forall a b. (a -> b) -> a -> b
$
CardLocation -> CardMatcher
matchLocation (Player
Active, Location
Stack)
CardMatcher -> CardMatcher -> CardMatcher
`matchOr` CardLocation -> CardMatcher
matchLocation (Player
Opponent, Location
Stack)
)
let newCard :: Card
newCard = String -> Card -> Card
setAttribute String
copy (Card -> Card) -> (Card -> Card) -> Card -> Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Card Card String String -> String -> Card -> Card
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Card Card String String
Lens' Card String
cardName String
newName (Card -> Card) -> Card -> Card
forall a b. (a -> b) -> a -> b
$ Card
card
ASetter
Board Board (HashMap String BaseCard) (HashMap String BaseCard)
-> (HashMap String BaseCard -> HashMap String BaseCard)
-> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
ASetter
Board Board (HashMap String BaseCard) (HashMap String BaseCard)
Lens' Board (HashMap String BaseCard)
cards
(String
-> BaseCard -> HashMap String BaseCard -> HashMap String BaseCard
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert String
newName (BaseCard -> HashMap String BaseCard -> HashMap String BaseCard)
-> BaseCard -> HashMap String BaseCard -> HashMap String BaseCard
forall a b. (a -> b) -> a -> b
$ Card -> BaseCard
BaseCard Card
newCard)
ASetter Board Board [String] [String]
-> ([String] -> [String]) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
ASetter Board Board [String] [String]
Lens' Board [String]
stack
((:) String
newName)
GameMonad ()
resolveEffects
damage ::
(Card -> Int)
-> Target
-> CardName
-> GameMonad ()
damage :: (Card -> Int) -> Target -> String -> GameMonad ()
damage Card -> Int
f Target
t String
source = String -> GameMonad () -> GameMonad ()
action String
"damage" (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
source CardMatcher
forall a. Monoid a => a
mempty
let dmg :: Int
dmg = Card -> Int
f Card
c
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dmg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
"damage must be positive, was " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
dmg
Int -> Target -> Card -> GameMonad ()
damage' Int
dmg Target
t Card
c
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Card -> Bool
hasAttribute String
lifelink Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
ASetter Board Board Int Int -> (Int -> Int) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board
Lens' Board (HashMap Player Int)
life ((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board)
-> ((Int -> Identity Int)
-> HashMap Player Int -> Identity (HashMap Player Int))
-> ASetter Board Board Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Player Int)
-> Lens'
(HashMap Player Int) (Maybe (IxValue (HashMap Player Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (CardLocation -> Player
forall a b. (a, b) -> a
fst (CardLocation -> Player)
-> (Card -> CardLocation) -> Card -> Player
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CardLocation Card CardLocation -> Card -> CardLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardLocation Card CardLocation
Lens' Card CardLocation
location (Card -> Player) -> Card -> Player
forall a b. (a -> b) -> a -> b
$ Card
c) ((Maybe Int -> Identity (Maybe Int))
-> HashMap Player Int -> Identity (HashMap Player Int))
-> ((Int -> Identity Int) -> Maybe Int -> Identity (Maybe Int))
-> (Int -> Identity Int)
-> HashMap Player Int
-> Identity (HashMap Player Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dmg)
GameMonad ()
resolveEffects
where
damage' :: Int -> Target -> Card -> GameMonad ()
damage' Int
dmg (TargetPlayer Player
t) Card
c =
ASetter Board Board Int Int -> (Int -> Int) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board
Lens' Board (HashMap Player Int)
life ((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board)
-> ((Int -> Identity Int)
-> HashMap Player Int -> Identity (HashMap Player Int))
-> ASetter Board Board Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Player Int)
-> Lens'
(HashMap Player Int) (Maybe (IxValue (HashMap Player Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Player Int)
Player
t ((Maybe Int -> Identity (Maybe Int))
-> HashMap Player Int -> Identity (HashMap Player Int))
-> ((Int -> Identity Int) -> Maybe Int -> Identity (Maybe Int))
-> (Int -> Identity Int)
-> HashMap Player Int
-> Identity (HashMap Player Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0)
(\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dmg)
damage' Int
dmg (TargetCard String
tn) Card
c = do
Card
t <- String -> CardMatcher -> GameMonad Card
requireCard String
tn (CardMatcher -> GameMonad Card) -> CardMatcher -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<>
(String -> CardMatcher
matchAttribute String
creature CardMatcher -> CardMatcher -> CardMatcher
`matchOr` String -> CardMatcher
matchAttribute String
planeswalker)
String -> GameMonad ()
target String
tn
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Card -> Bool
hasAttribute String
creature Card
t) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
String -> ASetter Card Card Int Int -> (Int -> Int) -> GameMonad ()
forall a b.
String -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated String
tn ASetter Card Card Int Int
Lens' Card Int
cardDamage (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dmg)
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dmg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& String -> Card -> Bool
hasAttribute String
deathtouch Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> String -> GameMonad ()
gainAttribute String
deathtouched String
tn
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Card -> Bool
hasAttribute String
planeswalker Card
t) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> ASetter Card Card Int Int -> (Int -> Int) -> GameMonad ()
forall a b.
String -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated String
tn ASetter Card Card Int Int
Lens' Card Int
cardLoyalty (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dmg)
destroy :: CardName -> GameMonad ()
destroy :: String -> GameMonad ()
destroy String
targetName = do
CardMatcher -> String -> GameMonad ()
validate (CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
missingAttribute String
indestructible) String
targetName
Location -> String -> GameMonad ()
moveTo Location
Graveyard String
targetName
discard :: CardName -> GameMonad ()
discard :: String -> GameMonad ()
discard String
cn = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
CardLocation -> CardLocation -> String -> GameMonad ()
move (Player
actor, Location
Hand) (Player
actor, Location
Graveyard) String
cn
exert :: CardName -> GameMonad ()
exert :: String -> GameMonad ()
exert String
cn = do
CardMatcher -> String -> GameMonad ()
validate (String -> CardMatcher
matchAttribute String
tapped) String
cn
String -> String -> GameMonad ()
gainAttribute String
exerted String
cn
exile :: CardName -> GameMonad ()
exile :: String -> GameMonad ()
exile = Location -> String -> GameMonad ()
moveTo Location
Exile
fight :: CardName -> CardName -> GameMonad ()
fight :: String -> String -> GameMonad ()
fight String
x String
y = do
CardMatcher -> String -> GameMonad ()
validate (CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
creature) String
x
CardMatcher -> String -> GameMonad ()
validate (CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
creature) String
y
String -> String -> GameMonad ()
fight' String
x String
y
String -> String -> GameMonad ()
fight' String
y String
x
where
fight' :: String -> String -> GameMonad ()
fight' String
src String
dst = (Card -> Int) -> Target -> String -> GameMonad ()
damage (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
cardPower) (String -> Target
targetCard String
dst) String
src
modifyStrength :: (Int, Int) -> CardName -> GameMonad ()
modifyStrength :: (Int, Int) -> String -> GameMonad ()
modifyStrength (Int, Int)
strength String
cn = do
Card
_ <- String -> CardMatcher -> GameMonad Card
requireCard String
cn (CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
creature)
ASetter Card Card CardStrength CardStrength
-> (CardStrength -> CardStrength) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card CardStrength CardStrength
Lens' Card CardStrength
cardStrengthModifier ((Int, Int) -> CardStrength
mkStrength (Int, Int)
strength CardStrength -> CardStrength -> CardStrength
forall a. Semigroup a => a -> a -> a
<>) String
cn
moveTo :: Location -> CardName -> GameMonad ()
moveTo :: Location -> String -> GameMonad ()
moveTo Location
dest String
cn = do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
cn CardMatcher
forall a. Monoid a => a
mempty
let location :: CardLocation
location = Getting CardLocation Card CardLocation -> Card -> CardLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardLocation Card CardLocation
Lens' Card CardLocation
cardLocation Card
c
CardLocation -> CardLocation -> String -> GameMonad ()
move CardLocation
location ((Location -> Location) -> CardLocation -> CardLocation
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Location -> Location -> Location
forall a b. a -> b -> a
const Location
dest) CardLocation
location) String
cn
remove :: CardName -> GameMonad ()
remove :: String -> GameMonad ()
remove String
cn = do
ASetter
Board Board (HashMap String BaseCard) (HashMap String BaseCard)
-> (HashMap String BaseCard -> HashMap String BaseCard)
-> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
Board Board (HashMap String BaseCard) (HashMap String BaseCard)
Lens' Board (HashMap String BaseCard)
cards (String -> HashMap String BaseCard -> HashMap String BaseCard
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete String
cn)
ASetter Board Board [String] [String]
-> ([String] -> [String]) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter Board Board [String] [String]
Lens' Board [String]
stack ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
cn))
GameMonad ()
resolveEffects
spendMana :: ManaString -> GameMonad ()
spendMana :: String -> GameMonad ()
spendMana String
amount =
String -> (Char -> GameMonad ()) -> GameMonad ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> String
parseMana String
amount) ((Char -> GameMonad ()) -> GameMonad ())
-> (Char -> GameMonad ()) -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ \Char
mana -> do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
String
pool <- Getting String Board String
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
String
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting String Board String
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
String)
-> Getting String Board String
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
String
forall a b. (a -> b) -> a -> b
$ Player -> Getting String Board String
forall (f :: * -> *).
Functor f =>
Player -> (String -> f String) -> Board -> f Board
manaPoolFor Player
actor
if Char
mana Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
pool) Bool -> Bool -> Bool
|| Char
mana Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
pool then
ASetter Board Board String String
-> (String -> String) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
(Player -> ASetter Board Board String String
forall (f :: * -> *).
Functor f =>
Player -> (String -> f String) -> Board -> f Board
manaPoolFor Player
actor)
((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
deleteFirst (if Char
mana Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' then Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True else Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
mana))
else
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
"Mana pool (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pool String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") does not contain (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
mana] String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
where
deleteFirst :: (a -> Bool) -> [a] -> [a]
deleteFirst a -> Bool
_ [] = []
deleteFirst a -> Bool
f (a
b:[a]
bc) | a -> Bool
f a
b = [a]
bc
| Bool
otherwise = a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
deleteFirst a -> Bool
f [a]
bc
tap :: CardName -> GameMonad ()
tap :: String -> GameMonad ()
tap String
name = do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
name (CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
missingAttribute String
tapped)
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardMatcher -> Card -> Bool
applyMatcher (String -> CardMatcher
matchAttribute String
creature) Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
CardMatcher -> String -> GameMonad ()
validate (String -> CardMatcher -> CardMatcher
labelMatch String
"does not have summoning sickness" (
String -> CardMatcher
matchAttribute String
haste
CardMatcher -> CardMatcher -> CardMatcher
`matchOr`
String -> CardMatcher
missingAttribute String
summoned
)) String
name
String -> String -> GameMonad ()
gainAttribute String
tapped String
name
untap :: CardName -> GameMonad ()
untap :: String -> GameMonad ()
untap String
name = do
CardMatcher -> String -> GameMonad ()
validate (CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
tapped) String
name
String -> String -> GameMonad ()
loseAttribute String
tapped String
name
validate :: CardMatcher -> CardName -> GameMonad ()
validate :: CardMatcher -> String -> GameMonad ()
validate CardMatcher
reqs String
targetName = do
Card
_ <- String -> CardMatcher -> GameMonad Card
requireCard String
targetName CardMatcher
reqs
() -> GameMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
validateRemoved :: CardName -> GameMonad ()
validateRemoved :: String -> GameMonad ()
validateRemoved String
targetName = do
Maybe BaseCard
card <- Getting (Maybe BaseCard) Board (Maybe BaseCard)
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(Maybe BaseCard)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting (Maybe BaseCard) Board (Maybe BaseCard)
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(Maybe BaseCard))
-> Getting (Maybe BaseCard) Board (Maybe BaseCard)
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
(Maybe BaseCard)
forall a b. (a -> b) -> a -> b
$ (HashMap String BaseCard
-> Const (Maybe BaseCard) (HashMap String BaseCard))
-> Board -> Const (Maybe BaseCard) Board
Lens' Board (HashMap String BaseCard)
cards ((HashMap String BaseCard
-> Const (Maybe BaseCard) (HashMap String BaseCard))
-> Board -> Const (Maybe BaseCard) Board)
-> ((Maybe BaseCard -> Const (Maybe BaseCard) (Maybe BaseCard))
-> HashMap String BaseCard
-> Const (Maybe BaseCard) (HashMap String BaseCard))
-> Getting (Maybe BaseCard) Board (Maybe BaseCard)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap String BaseCard)
-> Lens'
(HashMap String BaseCard)
(Maybe (IxValue (HashMap String BaseCard)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (HashMap String BaseCard)
targetName
case Maybe BaseCard
card of
Maybe BaseCard
Nothing -> () -> GameMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just BaseCard
_ -> String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
"Card should be removed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
targetName
validatePhase :: Phase -> GameMonad ()
validatePhase :: Phase -> GameMonad ()
validatePhase Phase
expected = do
Phase
actual <- Getting Phase Board Phase
-> ExceptT
String (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 () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Phase
actual Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
/= Phase
expected) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String
"phase was "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Phase -> String
forall a. Show a => a -> String
show Phase
actual
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", expected "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Phase -> String
forall a. Show a => a -> String
show Phase
expected
validateCanCastSorcery :: GameMonad ()
validateCanCastSorcery :: GameMonad ()
validateCanCastSorcery = do
Phase -> GameMonad ()
validatePhase Phase
FirstMain
GameMonad () -> (String -> GameMonad ()) -> GameMonad ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` GameMonad () -> String -> GameMonad ()
forall a b. a -> b -> a
const (Phase -> GameMonad ()
validatePhase Phase
SecondMain)
GameMonad () -> (String -> GameMonad ()) -> GameMonad ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` GameMonad () -> String -> GameMonad ()
forall a b. a -> b -> a
const (String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"not in a main phase")
[String]
s <- Getting [String] Board [String]
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
[String]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [String] Board [String]
Lens' Board [String]
stack
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
s) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"stack is not empty"
validateLife :: Int -> Player -> GameMonad ()
validateLife :: Int -> Player -> GameMonad ()
validateLife Int
n Player
player = do
Int
current <- Getting Int Board Int
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((HashMap Player Int -> Const Int (HashMap Player Int))
-> Board -> Const Int Board
Lens' Board (HashMap Player Int)
life ((HashMap Player Int -> Const Int (HashMap Player Int))
-> Board -> Const Int Board)
-> ((Int -> Const Int Int)
-> HashMap Player Int -> Const Int (HashMap Player Int))
-> Getting Int Board Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Player Int)
-> Lens'
(HashMap Player Int) (Maybe (IxValue (HashMap Player Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Player Int)
Player
player ((Maybe Int -> Const Int (Maybe Int))
-> HashMap Player Int -> Const Int (HashMap Player Int))
-> ((Int -> Const Int Int) -> Maybe Int -> Const Int (Maybe Int))
-> (Int -> Const Int Int)
-> HashMap Player Int
-> Const Int (HashMap Player Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0)
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
current Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> GameMonad ()) -> String -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ Player -> String
forall a. Show a => a -> String
show Player
player
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" life was "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
current
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", expected "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
withStateBasedActions :: GameMonad a -> GameMonad a
withStateBasedActions :: GameMonad a -> GameMonad a
withStateBasedActions GameMonad a
m = do
a
x <- (Env -> Env) -> GameMonad a -> GameMonad a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Env Env Bool Bool -> Bool -> Env -> Env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Env Env Bool Bool
Lens' Env Bool
envSBAEnabled Bool
False) GameMonad a
m
GameMonad ()
runStateBasedActions
a -> GameMonad a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
runStateBasedActions :: GameMonad ()
runStateBasedActions :: GameMonad ()
runStateBasedActions = do
Bool
enabled <- Getting Bool Env Bool
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool Env Bool
Lens' Env Bool
envSBAEnabled
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enabled (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
(Env -> Env) -> GameMonad () -> GameMonad ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Env Env Bool Bool -> Bool -> Env -> Env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Env Env Bool Bool
Lens' Env Bool
envSBAEnabled Bool
False) GameMonad ()
runStateBasedActions'
where
sbaCounter :: Control.Lens.Lens' Board Int
sbaCounter :: (Int -> f Int) -> Board -> f Board
sbaCounter = (HashMap String Int -> f (HashMap String Int)) -> Board -> f Board
Lens' Board (HashMap String Int)
counters ((HashMap String Int -> f (HashMap String Int))
-> Board -> f Board)
-> ((Int -> f Int) -> HashMap String Int -> f (HashMap String Int))
-> (Int -> f Int)
-> Board
-> f Board
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap String Int)
-> Lens'
(HashMap String Int) (Maybe (IxValue (HashMap String Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (HashMap String Int)
"sba-counter" ((Maybe Int -> f (Maybe Int))
-> HashMap String Int -> f (HashMap String Int))
-> ((Int -> f Int) -> Maybe Int -> f (Maybe Int))
-> (Int -> f Int)
-> HashMap String Int
-> f (HashMap String Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0
runStateBasedActions' :: GameMonad ()
runStateBasedActions' = do
ASetter Board Board Int Int -> Int -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter Board Board Int Int
Lens' Board Int
sbaCounter Int
0
let incrementCounter :: GameMonad ()
incrementCounter = ASetter Board Board Int Int -> (Int -> Int) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter Board Board Int Int
Lens' Board Int
sbaCounter (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
CardMatcher -> (String -> GameMonad ()) -> GameMonad ()
forCards CardMatcher
forall a. Monoid a => a
mempty ((String -> GameMonad ()) -> GameMonad ())
-> (String -> GameMonad ()) -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ \String
cn -> do
Card
c <- String -> CardMatcher -> GameMonad Card
requireCard String
cn CardMatcher
forall a. Monoid a => a
mempty
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardMatcher -> Card -> Bool
applyMatcher (CardMatcher
matchInPlay CardMatcher -> CardMatcher -> CardMatcher
forall a. Semigroup a => a -> a -> a
<> String -> CardMatcher
matchAttribute String
creature) Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
let dmg :: Int
dmg = 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
cardDamage Card
c
let toughness :: Int
toughness = 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
cardToughness Card
c
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Card -> Bool
hasAttribute String
indestructible Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dmg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
toughness Bool -> Bool -> Bool
|| String -> Card -> Bool
hasAttribute String
deathtouched Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
Location -> String -> GameMonad ()
moveTo Location
Graveyard String
cn GameMonad () -> GameMonad () -> GameMonad ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GameMonad ()
incrementCounter
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardMatcher -> Card -> Bool
applyMatcher (CardMatcher -> CardMatcher
invert CardMatcher
matchInPlay) Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Card -> Bool
hasAttribute String
token Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
remove String
cn GameMonad () -> GameMonad () -> GameMonad ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GameMonad ()
incrementCounter
let p1 :: Int
p1 = 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
c
let m1 :: Int
m1 = 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
cardMinusOneCounters Card
c
let p1' :: Int
p1' = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int
0, Int
p1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m1]
let m1' :: Int
m1' = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int
0, Int
m1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
p1]
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
p1' Bool -> Bool -> Bool
|| Int
m1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
m1') (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$ do
ASetter Card Card Int Int -> (Int -> Int) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card Int Int
Lens' Card Int
cardPlusOneCounters (Int -> Int -> Int
forall a b. a -> b -> a
const Int
p1') String
cn
ASetter Card Card Int Int -> (Int -> Int) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card Int Int
Lens' Card Int
cardMinusOneCounters (Int -> Int -> Int
forall a b. a -> b -> a
const Int
m1') String
cn
GameMonad ()
incrementCounter
let matchStack :: CardMatcher
matchStack =
CardLocation -> CardMatcher
matchLocation (Player
Active, Location
Stack)
CardMatcher -> CardMatcher -> CardMatcher
`matchOr` CardLocation -> CardMatcher
matchLocation (Player
Opponent, Location
Stack)
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CardMatcher -> Card -> Bool
applyMatcher (CardMatcher -> CardMatcher
invert CardMatcher
matchStack) Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Card -> Bool
hasAttribute String
copy Card
c) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
String -> GameMonad ()
remove String
cn GameMonad () -> GameMonad () -> GameMonad ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GameMonad ()
incrementCounter
Int
n <- Getting Int Board Int
-> ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int Board Int
Lens' Board Int
sbaCounter
Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) GameMonad ()
runStateBasedActions'
step :: String -> GameMonad a -> GameMonad a
step :: String -> GameMonad a -> GameMonad a
step String
desc GameMonad a
m = GameMonad a -> GameMonad a
forall a. GameMonad a -> GameMonad a
withStateBasedActions (GameMonad a -> GameMonad a) -> GameMonad a -> GameMonad a
forall a b. (a -> b) -> a -> b
$ do
Board
b <- ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Board
forall s (m :: * -> *). MonadState s m => m s
get
let (Either String a
e, Board
b', [Step]
_) = Board -> GameMonad a -> (Either String a, Board, [Step])
forall a. Board -> GameMonad a -> (Either String a, Board, [Step])
runMonad Board
b GameMonad a
m
let b'' :: Board
b'' = ASetter Board Board StepIdentifier StepIdentifier
-> (StepIdentifier -> StepIdentifier) -> Board -> Board
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Board Board StepIdentifier StepIdentifier
Lens' Board StepIdentifier
currentStep StepIdentifier -> StepIdentifier
incrementStep Board
b'
[Step] -> GameMonad ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [StepIdentifier -> String -> Board -> Step
mkStep (Getting StepIdentifier Board StepIdentifier
-> Board -> StepIdentifier
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting StepIdentifier Board StepIdentifier
Lens' Board StepIdentifier
currentStep Board
b'') String
desc Board
b'']
Board -> GameMonad ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Board
b''
case Either String a
e of
Left String
x -> String -> GameMonad a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
x
Right a
y -> a -> GameMonad a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y
fork :: String -> GameMonad () -> GameMonad ()
fork :: String -> GameMonad () -> GameMonad ()
fork String
label GameMonad ()
m = do
Board
b <- ExceptT
String (ReaderT Env (StateT Board (WriterT [Step] Identity))) Board
forall s (m :: * -> *). MonadState s m => m s
get
ASetter Board Board (Maybe String) (Maybe String)
-> (Maybe String -> Maybe String) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
(ASetter Board Board StepIdentifier StepIdentifier
Lens' Board StepIdentifier
currentStep ASetter Board Board StepIdentifier StepIdentifier
-> ((Maybe String -> Identity (Maybe String))
-> StepIdentifier -> Identity StepIdentifier)
-> ASetter Board Board (Maybe String) (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> Identity (Maybe String))
-> StepIdentifier -> Identity StepIdentifier
forall s t a b. Field1 s t a b => Lens s t a b
_1)
(String -> Maybe String -> Maybe String
f String
label)
GameMonad ()
m
Board -> GameMonad ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Board
b
where
f :: String -> Maybe String -> Maybe String
f String
label Maybe String
Nothing = String -> Maybe String
forall a. a -> Maybe a
Just String
label
f String
label (Just String
existing) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
existing String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" - " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
label
gainLife :: Int -> GameMonad ()
gainLife :: Int -> GameMonad ()
gainLife Int
amount = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
ASetter Board Board Int Int -> (Int -> Int) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board
Lens' Board (HashMap Player Int)
life ((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board)
-> ((Int -> Identity Int)
-> HashMap Player Int -> Identity (HashMap Player Int))
-> ASetter Board Board Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Player Int)
-> Lens'
(HashMap Player Int) (Maybe (IxValue (HashMap Player Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Player Int)
Player
actor ((Maybe Int -> Identity (Maybe Int))
-> HashMap Player Int -> Identity (HashMap Player Int))
-> ((Int -> Identity Int) -> Maybe Int -> Identity (Maybe Int))
-> (Int -> Identity Int)
-> HashMap Player Int
-> Identity (HashMap Player Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0)
(Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
amount)
GameMonad ()
resolveEffects
loseLife :: Int -> GameMonad ()
loseLife :: Int -> GameMonad ()
loseLife Int
amount = Int -> GameMonad ()
gainLife (-Int
amount)
setLife :: Int -> GameMonad ()
setLife :: Int -> GameMonad ()
setLife Int
n = do
Player
actor <- Getting Player Env Player
-> ExceptT
String
(ReaderT Env (StateT Board (WriterT [Step] Identity)))
Player
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Player Env Player
Lens' Env Player
envActor
ASetter Board Board (Maybe Int) (Maybe Int)
-> Maybe Int -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board
Lens' Board (HashMap Player Int)
life ((HashMap Player Int -> Identity (HashMap Player Int))
-> Board -> Identity Board)
-> ((Maybe Int -> Identity (Maybe Int))
-> HashMap Player Int -> Identity (HashMap Player Int))
-> ASetter Board Board (Maybe Int) (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Player Int)
-> Lens'
(HashMap Player Int) (Maybe (IxValue (HashMap Player Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Player Int)
Player
actor) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
addEffect :: LayeredEffectPart -> CardName -> GameMonad ()
addEffect :: LayeredEffectPart -> String -> GameMonad ()
addEffect LayeredEffectPart
e String
cn = do
Timestamp
now <- GameMonad Timestamp
getTimestamp
ASetter Card Card [AbilityEffect] [AbilityEffect]
-> ([AbilityEffect] -> [AbilityEffect]) -> String -> GameMonad ()
forall a b.
ASetter Card Card a b -> (a -> b) -> String -> GameMonad ()
modifyCard ASetter Card Card [AbilityEffect] [AbilityEffect]
Lens' Card [AbilityEffect]
cardAbilityEffects (Timestamp -> EffectDuration -> [LayeredEffectPart] -> AbilityEffect
AbilityEffect Timestamp
now EffectDuration
EndOfTurn [LayeredEffectPart
e]AbilityEffect -> [AbilityEffect] -> [AbilityEffect]
forall a. a -> [a] -> [a]
:) String
cn