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