{-|
Actions correspond to things you can do in Magic. They progress the state
machine while verifying applicable properties. The all run inside a
'GameMonad'.

Actions will modify the state as specified by the effects listed in their
documentation. If any of the validation steps fail away, the proof will fail.
Actions are /not/ atomic: if one fails, some effects may have already been
applied.
-}
module Dovin.Actions (
  step
  , fork
  -- * Casting
  , cast
  , castFromLocation
  , counter
  , flashback
  , jumpstart
  , resolve
  , resolveTop
  , resolveMentor
  , splice
  , tapForMana
  , target
  , targetInLocation
  -- * Uncategorized
  , activate
  , activatePlaneswalker
  , addEffect
  , attackWith
  , combatDamage
  , copySpell
  , damage
  , destroy
  , discard
  , exert
  , exile
  , fight
  , gainLife
  , loseLife
  , modifyStrength
  , moveTo
  , sacrifice
  , setLife
  , transitionTo
  , transitionToForced
  , trigger
  , triggerMentor
  , with
  -- * Validations
  , validate
  , validateCanCastSorcery
  , validateLife
  , validatePhase
  , validateRemoved
  -- * State-based Actions
  -- | Fine-grained control over when state-based actions are run. By default,
  -- all actions will 'runStateBasedEffects' on completion, so most of the time
  -- you don't need to use these functions explicitly.
  , runStateBasedActions
  , withStateBasedActions
  -- * Low-level
  -- | These actions provide low-level control over the game. Where possible,
  -- try to use the more descriptive higher-level actions.
  , 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

-- | Add mana to actor's mana pool.
--
-- > addMana "2RG"
--
-- [Validates]:
--
--   * Mana specification is valid.
--
-- [Effects]:
--
--   * Mana pool is increased.
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
<>)

-- | Casts a card from actor's hand. See 'castFromLocation' for specification.
--
-- > cast "R" "Shock"
--
-- [Validates]:
--
--   * Card exists in hand.
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

-- | Move a card to the stack, spending the specified mana. If not tracking
-- mana, use the empty string to cast for no mana. Typically you will want to
-- 'resolve' after casting. For the common case of casting from hand, see
-- 'cast'. See 'spendMana' for additional mana validations and effects.
--
-- > castFromLocation "1B" "Oathsworn Vampire" >> resolveTop
--
-- [Validates]:
--
--   * Card exists in location.
--   * If not an instant or has flash, see 'validateCanCastSorcery` for extra
--     validations.
--
-- [Effects]:
--
--   * Card moved to top of stack.
--   * Counter 'storm' incremented if card has 'instant' or 'sorcery'
--     attribute.
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)

-- | Remove a spell from the stack.
--
-- > counter "Shock"
--
-- [Validates]
--
--   * Card is on stack.
--   * Card is not a triggered or activated ability.
--
-- [Effects]
--
--   * Card is moved to graveyard. (See 'move' for alternate effects.)
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)

-- | Cast a card from actor's graveyard, exiling it when it leaves
-- the stack. See 'castFromLocation' for further specification.
--
-- > flashback "R" "Shock"
--
-- Does not validate whether the card actually has a flashback cost. If
-- important, use a wrapper function in your solution:
--
-- @
-- flashbackSnapped mana castName = do
--   validate (matchAttribute "snapcastered") castName
--   flashback mana castName
-- @
--
-- [Validates]
--
--   * Card is in actor's graveyard.
--
-- [Effects]
--
--   * Card gains 'exileWhenLeaveStack'.
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

-- | Cast a card from active player's graveyard, discarding a card in
-- addition to its mana cost, exiling it when it leaves the stack. See
-- 'castFromLocation' for further specification.
--
-- > jumpstart "R" "Mountain" "Shock"
--
-- [Validates]
--
--   * Card is in actor's graveyard.
--   * Discard card is in actor's hand.
--
-- [Effects]
--
--   * Card gains 'exileWhenLeaveStack'.
--   * Discard card moved to graveyard.
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

-- | Resolves a card on the stack.
--
-- > cast "R" "Shock" >> resolve "Shock"
--
-- [Validates]
--
--     * Stack is not empty.
--     * Card is on top of stack.
--
-- [Effects]
--
--     * See 'resolveTop'.
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

-- | Resolves the top card of the stack. Use this for simple cast-and-resolve
-- scenarios. For more complicated stack states, prefer 'resolve' with a named
-- spell to ensure the expected one is resolving.
--
-- [Validates]
--
--     * Stack is not empty.
--
-- [Effects]
--
--     * If spell, move card to graveyard of owner.
--     * If permanent, move card to play area of owner.
--     * If trigger, remove card.
--     * See 'move' for possible alternate effects, depending on card
--       attributes.
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

-- | Resolves a trigger created by `triggerMentor`. Adds +1/+1 to target card
-- if still a valid mentor target.
--
-- > resolveMentor "Goblin 1" "Legion Warboss"
--
-- [Validates]
--
--   * Mentor trigger is top of stack.
--   * Target card is attacking.
--   * Target card has less power than source card.
--
-- [Effects]
--
--   * Target card gets +1/+1.
--   * Trigger is removed from top of stack.
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 a permanent.
--
-- > sacrifice "Soldier"
--
-- [Validates]
--
--   * Permanent controlled by current actor.
--   * Permanent is in play.
--
-- [Effects]
--
--   * Card is moved to graveyard. See 'move' for possible alternate effects.
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

-- | Splices a spell on to a previously cast arcane spell.
--
-- > splice "Goryo's Vengeance" "2RR" "Through the Breach"
--
-- [Validates]
--
--   * Target spell is arcane.
--   * Target spell is on stack.
--   * Spliced spell is in hand.
--   * See 'spendMana' for additional validations.
--
-- [Effects]
--
--   * See 'spendMana' for additional effects.
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

-- | Combination of 'tap' and 'addMana', see them for specification.
tapForMana :: ManaString -> CardName -> GameMonad ()
tapForMana :: String -> String -> GameMonad ()
tapForMana String
amount String
name = do
  String -> GameMonad ()
tap String
name
  String -> GameMonad ()
addMana String
amount

-- | Transition to a new game phase or step.
--
-- > transitionTo DeclareAttackers
--
-- [Validates]
--
--   * The new phase would occur after the current phase in a normal turn.
--
-- [Effects]
--
--   * Empty the mana pool.
--   * Transition to new phase.
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

-- | Equivalent to 'transitionTo' except it skips all validation. Useful when
-- an effect has modified the normal order of phases, such as adding an extra
-- combat step.
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

-- | Triggers an effect of a permanent. Typically you will want to `resolve`
-- after triggering.
--
-- > trigger "Draw Card" "Dawn of Hope" >> resolveTop
--
-- [Validates]
--
--   * Card is in play or graveyard.
--   * Card is cotrolled by actor.
--
-- [Effects]
--
--   * A card with 'triggered' is added to stack.
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)

-- | Triggers a mentor effect from an attacking creature, targeting another
-- attacking creature with lesser power. Typically you will want to
-- `resolveMentor` after triggering.
--
-- > triggerMentor "Goblin 1" "Legion Warboss"
--
-- [Validates]
--
--   * Source card has attacking and mentor attributes.
--   * Target card is attacking.
--   * Target card has less power than source card.
--
-- [Effects]
--
--   * A triggered card is placed on the stack.
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


-- | Helper function to provide a scoped let.
--
-- > with "Angel" $ \cn -> target cn >> destroy cn
with :: CardName -> (CardName -> GameMonad ()) -> GameMonad ()
with :: String -> (String -> GameMonad ()) -> GameMonad ()
with String
x String -> GameMonad ()
f = String -> GameMonad ()
f String
x

-- | Move a card from one location to another.
--
-- > move (Opponent, Play) (Active, Play) "Angel"
--
-- [Validates]:
--
--     * Card exists in source location.
--     * Destination is not stack (use a 'cast' variant instead).
--     * Destination does not match source.
--     * If card has 'token' attribute, source is in play. (Removing token once
--       they have left play is handled by 'runStateBasedActions'.)
--     * If card has 'copy' attribute, source is the stack. (Removing token
--       once they have left play is handled by 'runStateBasedActions'.)
--
-- [Effects]:
--
--     * Card moved to destination location.
--     * If card is leaving play, remove all damage, counters, and gained
--       attributes.
--     * If card has 'exileWhenLeaveStack' attribute, move to exile and remove
--       'exileWhenLeaveStack' instead.
--     * If card has 'undying', is moving from play to graveyard, and has no
--       +1\/+1 counters, add a +1\/+1 counter instead. (Note: undying should
--       move card to graveyard then back to play for owner, but since neither
--       triggers nor owner tracking are implemented, this simplification is
--       valid.)
--     * If card is entering play or changing controller, add 'summoned'
--       attribute.
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

  -- These conditionals are acting on the card state _before_ any of the above
  -- changes were applied.
  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 a permanent.
--
-- [Validates]
--
--   * Card is in play.
--   * If card belongs to opponent, does not have 'hexproof'.
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

-- | Target a card in a non-play location.
--
-- [Validates]
--
--   * Card is in zone.
targetInLocation :: CardLocation -> CardName -> GameMonad ()
targetInLocation :: CardLocation -> String -> GameMonad ()
targetInLocation CardLocation
zone = CardMatcher -> String -> GameMonad ()
validate (CardLocation -> CardMatcher
matchLocation CardLocation
zone)

-- | Activate an ability of a permanent. See 'spendMana' for additional mana
-- validations and effects. Typically you will want to `resolve` after
-- activating.
--
-- > activate "Create Soldier" "3W" "Dawn of Hope" >> resolveTop
--
-- [Validates]
--
--   * Card is in play or graveyard.
--   * Card is controlled by actor.
--
-- [Effects]
--
--   * A card with 'activated' is added to stack.
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)

-- | Activate a loyalty ability of a planeswalker. Typically you will want to
-- `resolve` after activating.
--
-- > activatePlaneswalker2 "Get a card" (-1) "Karn, Scion of Urza" >> resolveTop
--
-- [Validates]
--
--   * Card is in play.
--   * Card has enough loyalty.
--
-- [Effects]
--
--   * Card loyalty is adjusted.
--
-- See `activate` for additional validations and effects.
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

-- | Start an attack with the given creatures.
--
-- > attackWith ["Fanatical Firebrand"]
--
-- [Validates]
--
--   * Cards are in play.
--   * Cards have 'creature' attribute.
--   * Cards either have 'haste' or are missing 'summoned'.
--   * Cards do not have 'defender'.
--
-- [Effects]
--
--   * Cards become tapped, unless they have 'vigilance'.
--   * Cards gain 'attacking' attribute.
--   * Transitions to 'DeclareAttackers' step.
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

-- | Apply combat damage between an attacker and blockers, using a simple
-- damage assignment algorithm. For more complex assignments, use 'damage'
-- directly.
--
-- > combatDamage ["Spirit 1", "Spirit 2"] "Angel"
--
-- See 'damage' for other validations and effects.
--
-- [Validates]
--
--   * Attacker has attribute 'attacking'.
--   * Attacker and blockers are in play.
--   * Attacker controlled by current actor.
--   * Blockers have attribute 'creature'.
--
-- [Effects]
--
--   * Damage is dealt to blockers in order given, with the final blocker
--     receiving any left over damage.
--   * If no blockers, damage is dealt to opposing player.
--   * If attacker has 'trample', any remaining damage is dealt to opposing
--     player.
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
    -- Assign leftover damage to opponent
    (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
    -- Assign any leftover damage to final blocker
    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

-- | Copy a spell on the stack, adding it to top of stack.
--
-- > copySpell "Snap Copy" "Snap"
--
-- [Validates]
--
--   * Card is on stack.
--
-- [Effects]
--
--   * New card is on top of stack.
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

-- | Applies damage from a source to a target.
--
-- > damage (const 2) (targetPlayer Opponent) "Shock"
--
-- [Validates]
--
--   * Source exists.
--   * Damage is not less than zero.
--   * If targeting a card, target is in play and is either a creature or a
--     planeswalker.
--
-- [Effects]
--
--   * Adds damage to the target.
--   * If target is a planeswalker, remove loyalty counters instead.
--   * If source has 'deathtouch' and target is a creature and damage is
--     non-zero, add 'deathtouched'
--     attribute to target.
--   * If source has 'lifelink', controller of source gains life equal to
--     damage dealt.
--   * Note 'runStateBasedActions' handles actual destruction (if applicable)
--     of creatures and planeswalkers.
damage ::
     (Card -> Int) -- ^ A function that returns the amount of damage to apply,
                   --   given the source card.
  -> Target        -- ^ Target to apply damage to
  -> CardName      -- ^ Source card
  -> 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 a permanent.
--
-- [Validates]
--
--   * Card is in play.
--   * Card is not 'indestructible'
--
-- [Effects]
--
--   * Card is moved to graveyard. See 'move' for possible alternate effects.
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 a card from the active player's hand.
--
-- > discard "Mountain"
--
-- [Validates]
--
--   * Card exists in active player's hand.
--
-- [Effects]
--
--   * Card moved to graveyard.
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 a card. Works best when card has an associated effect that applies
-- when 'exerted' attribute is present.
--
-- > withAttributes [flying]
-- >   $ withEffect
-- >       (matchInPlay <> matchAttribute exerted)
-- >       (    matchLocation . view cardLocation
-- >         <> const (matchAttribute creature)
-- >       )
-- >       (pure . over cardStrengthModifier (mkStrength (1, 1) <>))
-- >   $ addCreature (2, 2) "Tah-Crop Elite"
-- > attackWith ["Tah-Crop Elite"]
-- > exert "Tah-Crop Elite"
--
-- [Validates]
--
--   * Card has 'tapped' attribute.
--
-- [Effects]
--
--   * Card gains 'exerted' attribute.
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

-- | Move a card to the Exile zone.
--
-- > exile "Bridge from Below"
--
-- See `moveTo` for validations and effects.
exile :: CardName -> GameMonad ()
exile :: String -> GameMonad ()
exile = Location -> String -> GameMonad ()
moveTo Location
Exile

-- | Have one card fight another (each deals damage to the other).
--
-- [Validates]
--
--   * Card is in play.
--   * Card is a creature.
--
-- [Effects]
--
--   * Each card has damage dealt to it equal to the other's power. A creature
--     fighting itself will take twice its power in damage.
--   * Note 'runStateBasedActions' handles actual destruction (if applicable)
--     of creatures.
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

-- | Modify the strength of a card in play. It will be reset to base when the
-- card leaves play.
--
-- > modifyStrength (-2, -2) "Soldier"
--
-- [Validates]
--
--   * Card is in play.
--   * Card is a creature.
--
-- [Effects]
--
--   * Changes the strength modifier for the card.
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

-- | Move card to location with same controller.
--
-- > moveTo Graveyard "Forest"
--
-- [Validates]:
--
--     * Card exists.
--
-- [Effects]:
--
--     * Card is moved to location.
--     * See 'move' for possible alternate effects, depending on card
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

-- | Remove mana from the pool. Colored mana will be removed first, then extra
-- mana of any type will be removed to match the colorless required.
--
-- > spendMana "2RG"
--
-- [Validates]:
--
--     * Mana specification is valid.
--     * Sufficient mana exists in pool.
--
-- [Effects]:
--
--     * Mana pool is reduced.
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

    -- https://stackoverflow.com/questions/14688716/removing-the-first-instance-of-x-from-a-list
    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


-- | Taps a card.
--
-- [Validates]:
--
--   * Card is in play.
--   * Card is not tapped.
--   * If creature, is not summoned or has haste.
--
-- [Effects]:
--
--   * Card gains tapped attribute.
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

-- | Untaps a card.
--
-- [Validates]:
--
--   * Card is in play.
--   * Card is tapped.
--
-- [Effects]:
--
--   * Card loses tapped attribute.
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 that a card matches a matcher.
--
-- > validate (matchAttribute "pirate") "Angrath's Marauders"
--
-- [Validates]
--
--     * Card matches matcher.
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 ()

-- | Validates that a card is no longer present in the game. Particularly
-- helpful for checking destruction of tokens.
--
-- > validateRemoved "Angel"
--
-- [Validates]
--
--     * Name does not refer to a card.
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

-- | Validates that the game is in a particular phase.
--
-- > validatePhase BeginCombat
--
-- [Validates]
--
--     * Game is in the given phase.
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

-- | Validates that a sorcery is able to be cast.
--
-- [Validates]
--
--     * Stack is empty.
--     * In a main phase.
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"

-- | Validates a player has a specific life total.
--
-- > validateLife 0 Opponent
--
-- [Validates]
--
--     * Player life equals amount.
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

-- | Pause running of state-based actions for the duration of the action,
-- running them at the end.
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

-- | Run state-based actions. These include:
--
--     * If a creature does not have 'indestructible', and has damage exceeding
--       toughess or 'deathtouched' attribute, destroy it.
--     * If a card is a 'token' and is not in play, remove it.
--     * If a card is a 'copy' and is not on the stack, remove it.
--
-- These are run implicitly at the end of each 'step', so it's not usually
-- needed to call this explicitly. Even then, using 'withStateBasedActions' is
-- usually preferred.
--
-- Running state-based actions can in turn trigger more state-based actions.
-- This method loops until no more are generated, which has the potential for
-- non-termination for pathological game states.
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'

-- | Define a high-level step in the proof. A proof typically consists on
-- multiple steps. Each step is a human-readable description, then a definition
-- of that step using actions. If a step fails, no subsequent steps will be
-- run.  'runStateBasedActions' is implicitly called at the end of each step.
-- Nested 'step' invocations execute the nested action but have no other
-- effects - generally they should be avoided.
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

-- | Branch off a labeled alternate line. Steps inside the fork will be
-- reported at the end of the main line output.
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

-- | Increments life total for current actor.
--
-- > as Opponent $ gainLife 1
--
-- [Effects]
--
--   * Increases life total by amount
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

-- | Decrements life total for current actor.
--
-- > as Opponent $ loseLife 1
--
-- [Effects]
--
--   * Decreases life total by amount
loseLife :: Int -> GameMonad ()
loseLife :: Int -> GameMonad ()
loseLife Int
amount = Int -> GameMonad ()
gainLife (-Int
amount)

-- | Sets life total for current actor.
--
-- > as Opponent $ setLife 1
--
-- [Effects]
--
--   * Sets life total to 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)

-- | Adds an "until end of turn" effect to a card. Note in practice, since
-- turns aren't modeled, the effect will stay around until the end of the
-- solution.
--
-- > addEffect (effectPTSet 1 1) "Soldier"
--
-- [Effects]
--
--   * Adds a new "until end of turn" effect to the card with the current
--   timestamp.
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