{-# LANGUAGE TemplateHaskell #-}

{-|
Effects are continuous effects, such as "other creatures get +1/+1".

They are typically added to a card using 'Dovin.Builder.withEffect' or 'Dovin.Actions.addEffect'.
 -}
module Dovin.Effects
  ( effectPTSet
  , effectPTSetF
  , effectPTAdjust
  , effectPTAdjustF
  , effectNoAbilities
  , effectAddAbility
  , effectAddType

  , resolveEffects

  , enabledInPlay

  , viewSelf
  , askCards
  , askSelf
  )
  where

import Dovin.Prelude
import Dovin.Types
import Dovin.Matchers (applyMatcher, matchInPlay)

import Control.Lens (makeLenses, over, view, set)
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Control.Monad.Reader (ask, runReader)
import Control.Monad.State (modify')
import Data.Maybe (mapMaybe, catMaybes)
import Data.List (sortOn)

type Pile = [PileEntry]
data PileEntry = PileEntry
  { PileEntry -> Card
_peSource :: Card
  , PileEntry -> Timestamp
_peTimestamp :: Timestamp
  , PileEntry -> [LayeredEffectPart]
_peEffect :: [LayeredEffectPart]
  , PileEntry -> [CardName]
_peAppliesTo :: [CardName]
  }
makeLenses ''PileEntry

-- | Constant variant of 'effectPTSetF'.
effectPTSet :: (Int, Int) -> LayeredEffectPart
effectPTSet :: (Int, Int) -> LayeredEffectPart
effectPTSet = (Card -> EffectMonad (Int, Int)) -> LayeredEffectPart
effectPTSetF ((Card -> EffectMonad (Int, Int)) -> LayeredEffectPart)
-> ((Int, Int) -> Card -> EffectMonad (Int, Int))
-> (Int, Int)
-> LayeredEffectPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectMonad (Int, Int) -> Card -> EffectMonad (Int, Int)
forall a b. a -> b -> a
const (EffectMonad (Int, Int) -> Card -> EffectMonad (Int, Int))
-> ((Int, Int) -> EffectMonad (Int, Int))
-> (Int, Int)
-> Card
-> EffectMonad (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> EffectMonad (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Layer 7B effect to set the power and toughness of a creature.
effectPTSetF :: (Card -> EffectMonad (Int, Int)) -> LayeredEffectPart
effectPTSetF :: (Card -> EffectMonad (Int, Int)) -> LayeredEffectPart
effectPTSetF Card -> EffectMonad (Int, Int)
f = Layer -> (Card -> EffectMonad Card) -> LayeredEffectPart
LayeredEffectPart Layer
Layer7B ((Card -> EffectMonad Card) -> LayeredEffectPart)
-> (Card -> EffectMonad Card) -> LayeredEffectPart
forall a b. (a -> b) -> a -> b
$ \Card
c -> do
                   (Int, Int)
pt <- Card -> EffectMonad (Int, Int)
f Card
c
                   Card -> EffectMonad Card
forall (m :: * -> *) a. Monad m => a -> m a
return (Card -> EffectMonad Card) -> Card -> EffectMonad Card
forall a b. (a -> b) -> a -> b
$ ASetter Card Card CardStrength CardStrength
-> CardStrength -> Card -> Card
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Card Card CardStrength CardStrength
Lens' Card CardStrength
cardStrength ((Int, Int) -> CardStrength
mkStrength (Int, Int)
pt) Card
c

-- | Constant variant of 'effectPTAdjustF'
effectPTAdjust :: (Int, Int) -> LayeredEffectPart
effectPTAdjust :: (Int, Int) -> LayeredEffectPart
effectPTAdjust = (Card -> EffectMonad (Int, Int)) -> LayeredEffectPart
effectPTAdjustF ((Card -> EffectMonad (Int, Int)) -> LayeredEffectPart)
-> ((Int, Int) -> Card -> EffectMonad (Int, Int))
-> (Int, Int)
-> LayeredEffectPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectMonad (Int, Int) -> Card -> EffectMonad (Int, Int)
forall a b. a -> b -> a
const (EffectMonad (Int, Int) -> Card -> EffectMonad (Int, Int))
-> ((Int, Int) -> EffectMonad (Int, Int))
-> (Int, Int)
-> Card
-> EffectMonad (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> EffectMonad (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Layer 7C effect to adjust the power and toughness of a creature.
effectPTAdjustF :: (Card -> EffectMonad (Int, Int)) -> LayeredEffectPart
effectPTAdjustF :: (Card -> EffectMonad (Int, Int)) -> LayeredEffectPart
effectPTAdjustF Card -> EffectMonad (Int, Int)
f = Layer -> (Card -> EffectMonad Card) -> LayeredEffectPart
LayeredEffectPart Layer
Layer7C ((Card -> EffectMonad Card) -> LayeredEffectPart)
-> (Card -> EffectMonad Card) -> LayeredEffectPart
forall a b. (a -> b) -> a -> b
$ \Card
c -> do
                   (Int, Int)
pt <- Card -> EffectMonad (Int, Int)
f Card
c
                   Card -> EffectMonad Card
forall (m :: * -> *) a. Monad m => a -> m a
return (Card -> EffectMonad Card) -> Card -> EffectMonad Card
forall a b. (a -> b) -> a -> b
$ ASetter Card Card CardStrength CardStrength
-> (CardStrength -> CardStrength) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card CardStrength CardStrength
Lens' Card CardStrength
cardStrength ((Int, Int) -> CardStrength
mkStrength (Int, Int)
pt CardStrength -> CardStrength -> CardStrength
forall a. Semigroup a => a -> a -> a
<>) Card
c

-- | Layer 6 effect to add an ability to a card. In practice, it adds adds a
-- new 'CardAttribute'.
effectAddAbility :: CardName -> LayeredEffectPart
effectAddAbility CardName
attr = Layer -> (Card -> EffectMonad Card) -> LayeredEffectPart
LayeredEffectPart Layer
Layer6 (Card -> EffectMonad Card
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Card -> EffectMonad Card)
-> (Card -> Card) -> Card -> EffectMonad Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Card Card CardAttributes CardAttributes
-> (CardAttributes -> CardAttributes) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card CardAttributes CardAttributes
Lens' Card CardAttributes
cardAttributes (CardName -> CardAttributes -> CardAttributes
forall a. Ord a => a -> Set a -> Set a
S.insert CardName
attr))

-- | Layer 6 effect to remove all abilities from a card. This doesn't
-- temporary abilities added by 'addEffect'.
effectNoAbilities :: LayeredEffectPart
effectNoAbilities = Layer -> (Card -> EffectMonad Card) -> LayeredEffectPart
LayeredEffectPart Layer
Layer6 (Card -> EffectMonad Card
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Card -> EffectMonad Card)
-> (Card -> Card) -> Card -> EffectMonad Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  Card Card [LayeredEffectDefinition] [LayeredEffectDefinition]
-> [LayeredEffectDefinition] -> Card -> Card
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Card Card [LayeredEffectDefinition] [LayeredEffectDefinition]
Lens' Card [LayeredEffectDefinition]
cardPassiveEffects [LayeredEffectDefinition]
forall a. Monoid a => a
mempty)

-- | Layer 4 effect to add a type to a card. Since card types are modeled
-- explicitly, it instead adds a new 'CardAttribute'.
effectAddType :: CardName -> LayeredEffectPart
effectAddType CardName
attr = Layer -> (Card -> EffectMonad Card) -> LayeredEffectPart
LayeredEffectPart Layer
Layer4 (Card -> EffectMonad Card
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Card -> EffectMonad Card)
-> (Card -> Card) -> Card -> EffectMonad Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Card Card CardAttributes CardAttributes
-> (CardAttributes -> CardAttributes) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card CardAttributes CardAttributes
Lens' Card CardAttributes
cardAttributes (CardName -> CardAttributes -> CardAttributes
forall a. Ord a => a -> Set a -> Set a
S.insert CardName
attr))

-- | Effect enabled definition to apply when a card is in play.
enabledInPlay :: EffectMonad Bool
enabledInPlay :: EffectMonad Bool
enabledInPlay = CardMatcher -> Card -> Bool
applyMatcher CardMatcher
matchInPlay (Card -> Bool) -> EffectMonad Card -> EffectMonad Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectMonad Card
askSelf

-- | The card that is generating the effect being applied.
askSelf :: EffectMonad Card
askSelf :: EffectMonad Card
askSelf = (Board, Card) -> Card
forall a b. (a, b) -> b
snd ((Board, Card) -> Card)
-> ReaderT (Board, Card) Identity (Board, Card) -> EffectMonad Card
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Board, Card) Identity (Board, Card)
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Apply a lens to 'askSelf'.
viewSelf :: Getting b Card b -> ReaderT (Board, Card) Identity b
viewSelf Getting b Card b
x = Getting b Card b -> Card -> b
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting b Card b
x (Card -> b) -> EffectMonad Card -> ReaderT (Board, Card) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectMonad Card
askSelf

-- | Return cards fitting the given matcher.
askCards :: CardMatcher -> EffectMonad [Card]
askCards :: CardMatcher -> EffectMonad [Card]
askCards CardMatcher
matcher =
  (Card -> Bool) -> [Card] -> [Card]
forall a. (a -> Bool) -> [a] -> [a]
filter (CardMatcher -> Card -> Bool
applyMatcher CardMatcher
matcher)
  ([Card] -> [Card])
-> ((Board, Card) -> [Card]) -> (Board, Card) -> [Card]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap CardName Card -> [Card]
forall k v. HashMap k v -> [v]
M.elems
  (HashMap CardName Card -> [Card])
-> ((Board, Card) -> HashMap CardName Card)
-> (Board, Card)
-> [Card]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (HashMap CardName Card) Board (HashMap CardName Card)
-> Board -> HashMap CardName Card
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (HashMap CardName Card) Board (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards
  (Board -> HashMap CardName Card)
-> ((Board, Card) -> Board)
-> (Board, Card)
-> HashMap CardName Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Board, Card) -> Board
forall a b. (a, b) -> a
fst
  ((Board, Card) -> [Card])
-> ReaderT (Board, Card) Identity (Board, Card)
-> EffectMonad [Card]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Board, Card) Identity (Board, Card)
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Internal algorithm to apply re-calculate the state of the board by applying all effects.
resolveEffects :: GameMonad ()
resolveEffects :: GameMonad ()
resolveEffects = do
  -- This just happens to be a convenient place to bump the timestamp. SBE
  -- handling might be a better spot though.
  ASetter Board Board Timestamp Timestamp
-> (Timestamp -> Timestamp) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter Board Board Timestamp Timestamp
Lens' Board Timestamp
currentTime (Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
+ Timestamp
1)

  (Board -> Board) -> GameMonad ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' Board -> Board
resetCards
  (Board -> Board) -> GameMonad ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' Board -> Board
resolveCounters
  (Board -> Board) -> GameMonad ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' Board -> Board
applyEffects

resetCards :: Board -> Board
resetCards :: Board -> Board
resetCards Board
board = ASetter Board Board (HashMap CardName Card) (HashMap CardName Card)
-> HashMap CardName Card -> Board -> Board
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Board Board (HashMap CardName Card) (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards ((BaseCard -> Card)
-> HashMap CardName BaseCard -> HashMap CardName Card
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map BaseCard -> Card
unwrap (HashMap CardName BaseCard -> HashMap CardName Card)
-> (Board -> HashMap CardName BaseCard)
-> Board
-> HashMap CardName Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (HashMap CardName BaseCard) Board (HashMap CardName BaseCard)
-> Board -> HashMap CardName BaseCard
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (HashMap CardName BaseCard) Board (HashMap CardName BaseCard)
Lens' Board (HashMap CardName BaseCard)
cards (Board -> HashMap CardName Card) -> Board -> HashMap CardName Card
forall a b. (a -> b) -> a -> b
$ Board
board) Board
board
  where
    unwrap :: BaseCard -> Card
unwrap (BaseCard Card
card) = Card
card

-- Unlike the previous effects system, V3 attempts to better mirror the
-- layering rules while also providing a more flexible API to create more
-- types of effects. Some notable constraints this requires solving for
-- include:
--
-- * The set of cards an effect applies to needs to be fixed in the first
--   layer in which the effect would apply.
-- * Layers can create or remove effects in higher layers (e.g. removing all
--   abilities in layer 6). This means it is not possible to know all effects
--   that will be applied at the start of the algorithm, effects need to be
--   collected layer by layer.
--
-- This algorithm uses the concept of a "pile" of unapplied effects, that is
-- both added to and reduced at each layer.
--
-- 1. For every layer, all cards are checked for effects that would start
--    applying on that layer, and all parts of that effect are added to the
--    pile - alongside the set of cards to apply to. For example, "all
--    creatures are 0/1 and have no abilities" applies on both layers 6 and
--    7B and it will be added to the pile when evaluating layer 6.
-- 2. All sub-effects that apply to the current layer are removed from the
--    pile and evaluated in timestamp order. (Note: dependencies are not
--    implemented yet.)
-- 3. After the final layer, the pile should be empty.
applyEffects :: Board -> Board
applyEffects :: Board -> Board
applyEffects Board
board =
  let (Board
newBoard, Pile
pile) = ((Board, Pile) -> Layer -> (Board, Pile))
-> (Board, Pile) -> [Layer] -> (Board, Pile)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Board, Pile) -> Layer -> (Board, Pile)
resolveLayer (Board
board, Pile
forall a. Monoid a => a
mempty) [Layer]
allLayers in

  if Pile -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pile
pile then
    Board
newBoard
  else
    CardName -> Board
forall a. HasCallStack => CardName -> a
error CardName
"assertion failed: pile should be empty"

-- Convert card counters and legacy strength modifiers into V3 effects. Note
-- that since counter timestamps are not implemented, card timestamps are used
-- instead.
resolveCounters :: Board -> Board
resolveCounters :: Board -> Board
resolveCounters Board
board =
  let
    newCards :: HashMap CardName Card
newCards = (Card -> Card) -> HashMap CardName Card -> HashMap CardName Card
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map Card -> Card
countersToEffect (HashMap CardName Card -> HashMap CardName Card)
-> (Board -> HashMap CardName Card)
-> Board
-> HashMap CardName Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (HashMap CardName Card) Board (HashMap CardName Card)
-> Board -> HashMap CardName Card
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (HashMap CardName Card) Board (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards (Board -> HashMap CardName Card) -> Board -> HashMap CardName Card
forall a b. (a -> b) -> a -> b
$ Board
board
  in

  ASetter Board Board (HashMap CardName Card) (HashMap CardName Card)
-> HashMap CardName Card -> Board -> Board
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Board Board (HashMap CardName Card) (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards HashMap CardName Card
newCards Board
board

  where
    unwrap :: BaseCard -> Card
unwrap (BaseCard Card
card) = Card
card

    countersToEffect :: Card -> Card
    countersToEffect :: Card -> Card
countersToEffect Card
card =
      let es :: [AbilityEffect]
es =
            (LayeredEffectPart -> AbilityEffect)
-> [LayeredEffectPart] -> [AbilityEffect]
forall a b. (a -> b) -> [a] -> [b]
map (Timestamp -> EffectDuration -> [LayeredEffectPart] -> AbilityEffect
AbilityEffect (Getting Timestamp Card Timestamp -> Card -> Timestamp
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Timestamp Card Timestamp
Lens' Card Timestamp
cardTimestamp Card
card) EffectDuration
EndOfTurn ([LayeredEffectPart] -> AbilityEffect)
-> (LayeredEffectPart -> [LayeredEffectPart])
-> LayeredEffectPart
-> AbilityEffect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LayeredEffectPart -> [LayeredEffectPart]
forall a. Int -> a -> [a]
replicate Int
1)
            ([LayeredEffectPart] -> [AbilityEffect])
-> ([Card -> Maybe LayeredEffectPart] -> [LayeredEffectPart])
-> [Card -> Maybe LayeredEffectPart]
-> [AbilityEffect]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe LayeredEffectPart] -> [LayeredEffectPart]
forall a. [Maybe a] -> [a]
catMaybes
            ([Maybe LayeredEffectPart] -> [LayeredEffectPart])
-> ([Card -> Maybe LayeredEffectPart] -> [Maybe LayeredEffectPart])
-> [Card -> Maybe LayeredEffectPart]
-> [LayeredEffectPart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Card -> Maybe LayeredEffectPart) -> Maybe LayeredEffectPart)
-> [Card -> Maybe LayeredEffectPart] -> [Maybe LayeredEffectPart]
forall a b. (a -> b) -> [a] -> [b]
map (\Card -> Maybe LayeredEffectPart
f -> Card -> Maybe LayeredEffectPart
f Card
card)
            ([Card -> Maybe LayeredEffectPart] -> [AbilityEffect])
-> [Card -> Maybe LayeredEffectPart] -> [AbilityEffect]
forall a b. (a -> b) -> a -> b
$ [ (Int, Int) -> Maybe LayeredEffectPart
mkPTEffect ((Int, Int) -> Maybe LayeredEffectPart)
-> (Card -> (Int, Int)) -> Card -> Maybe LayeredEffectPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Int, Int)
forall b. b -> (b, b)
dup (Int -> (Int, Int)) -> (Card -> Int) -> Card -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
              , (Int, Int) -> Maybe LayeredEffectPart
mkPTEffect ((Int, Int) -> Maybe LayeredEffectPart)
-> (Card -> (Int, Int)) -> Card -> Maybe LayeredEffectPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Int, Int)
forall b. b -> (b, b)
dup (Int -> (Int, Int)) -> (Card -> Int) -> Card -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
              , (Int, Int) -> Maybe LayeredEffectPart
mkPTEffect ((Int, Int) -> Maybe LayeredEffectPart)
-> (Card -> (Int, Int)) -> Card -> Maybe LayeredEffectPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardStrength -> (Int, Int)
toTuple (CardStrength -> (Int, Int))
-> (Card -> CardStrength) -> Card -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CardStrength Card CardStrength -> Card -> CardStrength
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardStrength Card CardStrength
Lens' Card CardStrength
cardStrengthModifier
              ]
      in

      ASetter Card Card [AbilityEffect] [AbilityEffect]
-> ([AbilityEffect] -> [AbilityEffect]) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over
        ASetter Card Card [AbilityEffect] [AbilityEffect]
Lens' Card [AbilityEffect]
cardAbilityEffects
        ([AbilityEffect]
es [AbilityEffect] -> [AbilityEffect] -> [AbilityEffect]
forall a. Semigroup a => a -> a -> a
<>)
        Card
card

      where
        toTuple :: CardStrength -> (Int, Int)
toTuple (CardStrength Int
p Int
t) = (Int
p, Int
t)
        mkPTEffect :: (Int, Int) -> Maybe LayeredEffectPart
        mkPTEffect :: (Int, Int) -> Maybe LayeredEffectPart
mkPTEffect (Int
p, Int
t) =
          -- This is an optimization to not create a large number of no-op
          -- effects.
          if Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
            Maybe LayeredEffectPart
forall a. Maybe a
Nothing
          else
            LayeredEffectPart -> Maybe LayeredEffectPart
forall a. a -> Maybe a
Just (LayeredEffectPart -> Maybe LayeredEffectPart)
-> LayeredEffectPart -> Maybe LayeredEffectPart
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> LayeredEffectPart
effectPTAdjust (Int
p, Int
t)

        dup :: b -> (b, b)
dup b
x = (b
x, b
x)

resolveLayer :: (Board, Pile) -> Layer -> (Board, Pile)
resolveLayer :: (Board, Pile) -> Layer -> (Board, Pile)
resolveLayer (Board
board, Pile
pile) Layer
layer =
  let
    cs :: HashMap CardName Card
cs            = Getting (HashMap CardName Card) Board (HashMap CardName Card)
-> Board -> HashMap CardName Card
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (HashMap CardName Card) Board (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards Board
board
    newEffects :: Pile
newEffects    = (Card -> Pile) -> HashMap CardName Card -> Pile
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Layer -> Card -> Pile
extractEffects Layer
layer) HashMap CardName Card
cs :: Pile
    newPile :: Pile
newPile       = Pile
pile Pile -> Pile -> Pile
forall a. Semigroup a => a -> a -> a
<> Pile
newEffects :: Pile
    (Pile
pile', Pile
peel) = Layer -> Pile -> (Pile, Pile)
peelLayer Layer
layer Pile
newPile
    newBoard :: Board
newBoard      = (Board -> PileEntry -> Board) -> Board -> Pile -> Board
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Board -> PileEntry -> Board
applyEffects Board
board (Pile -> Board) -> (Pile -> Pile) -> Pile -> Board
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PileEntry -> Timestamp) -> Pile -> Pile
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Getting Timestamp PileEntry Timestamp -> PileEntry -> Timestamp
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Timestamp PileEntry Timestamp
Lens' PileEntry Timestamp
peTimestamp) (Pile -> Board) -> Pile -> Board
forall a b. (a -> b) -> a -> b
$ Pile
peel
  in
  (Board
newBoard, Pile
pile')

  where
    -- Take a PileEntry and apply it to the board state. It is assumed that it
    -- has already been filtered to a single layer.
    applyEffects :: Board -> PileEntry -> Board
    applyEffects :: Board -> PileEntry -> Board
applyEffects Board
board PileEntry
pe =
      let
        cs :: [Card]
cs = (CardName -> Maybe Card) -> [CardName] -> [Card]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\CardName
cn -> CardName -> HashMap CardName Card -> Maybe Card
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup CardName
cn (Getting (HashMap CardName Card) Board (HashMap CardName Card)
-> Board -> HashMap CardName Card
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (HashMap CardName Card) Board (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards Board
board))
             ([CardName] -> [Card])
-> (PileEntry -> [CardName]) -> PileEntry -> [Card]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [CardName] PileEntry [CardName] -> PileEntry -> [CardName]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [CardName] PileEntry [CardName]
Lens' PileEntry [CardName]
peAppliesTo
             (PileEntry -> [Card]) -> PileEntry -> [Card]
forall a b. (a -> b) -> a -> b
$ PileEntry
pe :: [Card]
        newCards :: [Card]
newCards = (Card -> Card) -> [Card] -> [Card]
forall a b. (a -> b) -> [a] -> [b]
map
                     (Card -> [LayeredEffectPart] -> Card -> Card
forall (t :: * -> *).
Foldable t =>
Card -> t LayeredEffectPart -> Card -> Card
applyEffectParts (Getting Card PileEntry Card -> PileEntry -> Card
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Card PileEntry Card
Lens' PileEntry Card
peSource PileEntry
pe) (Getting [LayeredEffectPart] PileEntry [LayeredEffectPart]
-> PileEntry -> [LayeredEffectPart]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [LayeredEffectPart] PileEntry [LayeredEffectPart]
Lens' PileEntry [LayeredEffectPart]
peEffect PileEntry
pe))
                     [Card]
cs
      in

      ASetter Board Board (HashMap CardName Card) (HashMap CardName Card)
-> (HashMap CardName Card -> HashMap CardName Card)
-> Board
-> Board
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over
        ASetter Board Board (HashMap CardName Card) (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards
        (HashMap CardName Card
-> HashMap CardName Card -> HashMap CardName Card
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
M.union (HashMap CardName Card
 -> HashMap CardName Card -> HashMap CardName Card)
-> ([Card] -> HashMap CardName Card)
-> [Card]
-> HashMap CardName Card
-> HashMap CardName Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CardName, Card)] -> HashMap CardName Card
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(CardName, Card)] -> HashMap CardName Card)
-> ([Card] -> [(CardName, Card)])
-> [Card]
-> HashMap CardName Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Card -> (CardName, Card)) -> [Card] -> [(CardName, Card)]
forall a b. (a -> b) -> [a] -> [b]
map (\Card
c -> (Getting CardName Card CardName -> Card -> CardName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardName Card CardName
Lens' Card CardName
cardName Card
c, Card
c)) ([Card] -> HashMap CardName Card -> HashMap CardName Card)
-> [Card] -> HashMap CardName Card -> HashMap CardName Card
forall a b. (a -> b) -> a -> b
$ [Card]
newCards)
        Board
board

    applyEffectParts :: Card -> t LayeredEffectPart -> Card -> Card
applyEffectParts Card
source t LayeredEffectPart
es Card
target =
      (Card -> LayeredEffectPart -> Card)
-> Card -> t LayeredEffectPart -> Card
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
        (\Card
t (LayeredEffectPart Layer
_ Card -> EffectMonad Card
effect) ->
          EffectMonad Card -> (Board, Card) -> Card
forall r a. Reader r a -> r -> a
runReader (Card -> EffectMonad Card
effect Card
t) (Board
board, Card
source))
        Card
target
        t LayeredEffectPart
es

    -- Find all effects on a card that begin applying at the given layer.
    extractEffects :: Layer -> Card -> Pile
    extractEffects :: Layer -> Card -> Pile
extractEffects Layer
layer Card
c =
      let
        passiveEffects :: Pile
passiveEffects =
          (LayeredEffectDefinition -> PileEntry)
-> [LayeredEffectDefinition] -> Pile
forall a b. (a -> b) -> [a] -> [b]
map LayeredEffectDefinition -> PileEntry
toPileEntry
          ([LayeredEffectDefinition] -> Pile)
-> (Card -> [LayeredEffectDefinition]) -> Card -> Pile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [LayeredEffectDefinition] Card [LayeredEffectDefinition]
-> Card -> [LayeredEffectDefinition]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [LayeredEffectDefinition] Card [LayeredEffectDefinition]
Lens' Card [LayeredEffectDefinition]
cardPassiveEffects
          (Card -> Pile) -> Card -> Pile
forall a b. (a -> b) -> a -> b
$ Card
c
        abilityEffects :: Pile
abilityEffects =
          (AbilityEffect -> PileEntry) -> [AbilityEffect] -> Pile
forall a b. (a -> b) -> [a] -> [b]
map (\(AbilityEffect Timestamp
t EffectDuration
_ [LayeredEffectPart]
es) ->
            PileEntry :: Card -> Timestamp -> [LayeredEffectPart] -> [CardName] -> PileEntry
PileEntry {
              _peSource :: Card
_peSource = Card
c,
              _peTimestamp :: Timestamp
_peTimestamp = Timestamp
t,
              _peEffect :: [LayeredEffectPart]
_peEffect = [LayeredEffectPart]
es,
              _peAppliesTo :: [CardName]
_peAppliesTo = [Getting CardName Card CardName -> Card -> CardName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardName Card CardName
Lens' Card CardName
cardName Card
c]
            })
          ([AbilityEffect] -> Pile)
-> (Card -> [AbilityEffect]) -> Card -> Pile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [AbilityEffect] Card [AbilityEffect]
-> Card -> [AbilityEffect]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [AbilityEffect] Card [AbilityEffect]
Lens' Card [AbilityEffect]
cardAbilityEffects
          (Card -> Pile) -> Card -> Pile
forall a b. (a -> b) -> a -> b
$ Card
c
      in

      (PileEntry -> Bool) -> Pile -> Pile
forall a. (a -> Bool) -> [a] -> [a]
filter
        (Layer -> Layer -> Bool
forall a. Eq a => a -> a -> Bool
(==) Layer
layer (Layer -> Bool) -> (PileEntry -> Layer) -> PileEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Layer] -> Layer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Layer] -> Layer) -> (PileEntry -> [Layer]) -> PileEntry -> Layer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LayeredEffectPart -> Layer) -> [LayeredEffectPart] -> [Layer]
forall a b. (a -> b) -> [a] -> [b]
map LayeredEffectPart -> Layer
extractLayer ([LayeredEffectPart] -> [Layer])
-> (PileEntry -> [LayeredEffectPart]) -> PileEntry -> [Layer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [LayeredEffectPart] PileEntry [LayeredEffectPart]
-> PileEntry -> [LayeredEffectPart]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [LayeredEffectPart] PileEntry [LayeredEffectPart]
Lens' PileEntry [LayeredEffectPart]
peEffect)
        (Pile
passiveEffects Pile -> Pile -> Pile
forall a. Semigroup a => a -> a -> a
<> Pile
abilityEffects)

      where
        extractLayer :: LayeredEffectPart -> Layer
extractLayer (LayeredEffectPart Layer
l Card -> EffectMonad Card
_) = Layer
l

        toPileEntry :: LayeredEffectDefinition -> PileEntry
        toPileEntry :: LayeredEffectDefinition -> PileEntry
toPileEntry LayeredEffectDefinition
ld =
          let
            matcher :: CardMatcher
matcher = Reader (Board, Card) CardMatcher -> (Board, Card) -> CardMatcher
forall r a. Reader r a -> r -> a
runReader (Getting
  (Reader (Board, Card) CardMatcher)
  LayeredEffectDefinition
  (Reader (Board, Card) CardMatcher)
-> LayeredEffectDefinition -> Reader (Board, Card) CardMatcher
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Reader (Board, Card) CardMatcher)
  LayeredEffectDefinition
  (Reader (Board, Card) CardMatcher)
Lens' LayeredEffectDefinition (Reader (Board, Card) CardMatcher)
leAppliesTo LayeredEffectDefinition
ld) (Board
board, Card
c)
            cs' :: [Card]
cs' =
              (Card -> Bool) -> [Card] -> [Card]
forall a. (a -> Bool) -> [a] -> [a]
filter
                (CardMatcher -> Card -> Bool
applyMatcher CardMatcher
matcher)
                (HashMap CardName Card -> [Card]
forall k v. HashMap k v -> [v]
M.elems (HashMap CardName Card -> [Card])
-> (Board -> HashMap CardName Card) -> Board -> [Card]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (HashMap CardName Card) Board (HashMap CardName Card)
-> Board -> HashMap CardName Card
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (HashMap CardName Card) Board (HashMap CardName Card)
Lens' Board (HashMap CardName Card)
resolvedCards (Board -> [Card]) -> Board -> [Card]
forall a b. (a -> b) -> a -> b
$ Board
board)
          in

          PileEntry :: Card -> Timestamp -> [LayeredEffectPart] -> [CardName] -> PileEntry
PileEntry {
            _peSource :: Card
_peSource = Card
c,
            _peTimestamp :: Timestamp
_peTimestamp = Getting Timestamp Card Timestamp -> Card -> Timestamp
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Timestamp Card Timestamp
Lens' Card Timestamp
cardTimestamp Card
c,
            _peEffect :: [LayeredEffectPart]
_peEffect = Getting
  [LayeredEffectPart] LayeredEffectDefinition [LayeredEffectPart]
-> LayeredEffectDefinition -> [LayeredEffectPart]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  [LayeredEffectPart] LayeredEffectDefinition [LayeredEffectPart]
Lens' LayeredEffectDefinition [LayeredEffectPart]
leEffect LayeredEffectDefinition
ld,
            _peAppliesTo :: [CardName]
_peAppliesTo = (Card -> CardName) -> [Card] -> [CardName]
forall a b. (a -> b) -> [a] -> [b]
map (Getting CardName Card CardName -> Card -> CardName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardName Card CardName
Lens' Card CardName
cardName) [Card]
cs'
          }

-- Return two piles, the second including every effect part that applies at
-- this layer, the first with all the remaining. Removes any entries that no
-- longer have any effect parts remaining to apply.
peelLayer :: Layer -> Pile -> (Pile, Pile)
peelLayer :: Layer -> Pile -> (Pile, Pile)
peelLayer Layer
layer Pile
pile =
  ((Bool -> Bool) -> Pile -> Pile
f Bool -> Bool
not Pile
pile, (Bool -> Bool) -> Pile -> Pile
f Bool -> Bool
forall a. a -> a
id Pile
pile)
  where
    f :: (Bool -> Bool) -> Pile -> Pile
f Bool -> Bool
g =
      (PileEntry -> Bool) -> Pile -> Pile
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (PileEntry -> Bool) -> PileEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LayeredEffectPart] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([LayeredEffectPart] -> Bool)
-> (PileEntry -> [LayeredEffectPart]) -> PileEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [LayeredEffectPart] PileEntry [LayeredEffectPart]
-> PileEntry -> [LayeredEffectPart]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [LayeredEffectPart] PileEntry [LayeredEffectPart]
Lens' PileEntry [LayeredEffectPart]
peEffect)
      (Pile -> Pile) -> (Pile -> Pile) -> Pile -> Pile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PileEntry -> PileEntry) -> Pile -> Pile
forall a b. (a -> b) -> [a] -> [b]
map (ASetter PileEntry PileEntry [LayeredEffectPart] [LayeredEffectPart]
-> ([LayeredEffectPart] -> [LayeredEffectPart])
-> PileEntry
-> PileEntry
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter PileEntry PileEntry [LayeredEffectPart] [LayeredEffectPart]
Lens' PileEntry [LayeredEffectPart]
peEffect ((LayeredEffectPart -> Bool)
-> [LayeredEffectPart] -> [LayeredEffectPart]
forall a. (a -> Bool) -> [a] -> [a]
filter ((LayeredEffectPart -> Bool)
 -> [LayeredEffectPart] -> [LayeredEffectPart])
-> (LayeredEffectPart -> Bool)
-> [LayeredEffectPart]
-> [LayeredEffectPart]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
g (Bool -> Bool)
-> (LayeredEffectPart -> Bool) -> LayeredEffectPart -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layer -> LayeredEffectPart -> Bool
isLayer Layer
layer))

    isLayer :: Layer -> LayeredEffectPart -> Bool
    isLayer :: Layer -> LayeredEffectPart -> Bool
isLayer Layer
l1 (LayeredEffectPart Layer
l2 Card -> EffectMonad Card
_) = Layer
l1 Layer -> Layer -> Bool
forall a. Eq a => a -> a -> Bool
== Layer
l2