{-# LANGUAGE TemplateHaskell #-}
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', runState, State, get)
import Data.Maybe (mapMaybe, catMaybes)
import Data.List (sortOn, partition)
import Data.Tuple (swap)
type Pile = [PileEntry]
data PileEntry = PileEntry
{ PileEntry -> Card
_peSource :: Card
, PileEntry -> Timestamp
_peTimestamp :: Timestamp
, PileEntry -> [LayeredEffectPart]
_peEffect :: [LayeredEffectPart]
, PileEntry -> Either (EffectMonad CardMatcher) [CardName]
_peAppliesTo :: Either (EffectMonad CardMatcher) [CardName]
}
makeLenses ''PileEntry
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
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
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
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
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))
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)
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))
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
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
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
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
resolveEffects :: GameMonad ()
resolveEffects :: GameMonad ()
resolveEffects = do
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
applyEffects :: Board -> Board
applyEffects :: Board -> Board
applyEffects Board
board =
let
f :: (Board, Pile) -> Layer -> (Board, Pile)
f (Board, Pile)
accum Layer
v = Layer -> (Board, Pile) -> (Board, Pile)
applyEffectsAtLayer Layer
v ((Board, Pile) -> (Board, Pile))
-> ((Board, Pile) -> (Board, Pile))
-> (Board, Pile)
-> (Board, Pile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layer -> (Board, Pile) -> (Board, Pile)
collectNewEffectsAtLayer Layer
v ((Board, Pile) -> (Board, Pile)) -> (Board, Pile) -> (Board, Pile)
forall a b. (a -> b) -> a -> b
$ (Board, Pile)
accum
(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)
f (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"
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) =
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)
collectNewEffectsAtLayer :: Layer -> (Board, Pile) -> (Board, Pile)
collectNewEffectsAtLayer :: Layer -> (Board, Pile) -> (Board, Pile)
collectNewEffectsAtLayer Layer
layer (Board
board, Pile
pile) =
(
Board
board,
(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 -> Pile) -> (Board -> Pile) -> Board -> Pile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pile
pile Pile -> Pile -> Pile
forall a. Semigroup a => a -> a -> a
<>) (Pile -> Pile) -> (Board -> Pile) -> Board -> Pile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Card -> Pile) -> HashMap CardName Card -> Pile
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Layer -> Card -> Pile
extractCardEffects Layer
layer) (HashMap CardName Card -> Pile)
-> (Board -> HashMap CardName Card) -> Board -> Pile
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 -> Pile) -> Board -> Pile
forall a b. (a -> b) -> a -> b
$ Board
board
)
where
extractCardEffects :: Layer -> Card -> Pile
extractCardEffects :: Layer -> Card -> Pile
extractCardEffects Layer
layer Card
c =
let
passiveEffects :: Pile
passiveEffects =
(LayeredEffectDefinition -> PileEntry)
-> [LayeredEffectDefinition] -> Pile
forall a b. (a -> b) -> [a] -> [b]
map LayeredEffectDefinition -> PileEntry
ldToPileEntry
([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 -> PileEntry
aeToPileEntry
([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
aeToPileEntry :: AbilityEffect -> PileEntry
aeToPileEntry :: AbilityEffect -> PileEntry
aeToPileEntry (AbilityEffect Timestamp
t EffectDuration
_ [LayeredEffectPart]
es) =
PileEntry :: Card
-> Timestamp
-> [LayeredEffectPart]
-> Either (EffectMonad CardMatcher) [CardName]
-> PileEntry
PileEntry {
_peSource :: Card
_peSource = Card
c,
_peTimestamp :: Timestamp
_peTimestamp = Timestamp
t,
_peEffect :: [LayeredEffectPart]
_peEffect = [LayeredEffectPart]
es,
_peAppliesTo :: Either (EffectMonad CardMatcher) [CardName]
_peAppliesTo = [CardName] -> Either (EffectMonad CardMatcher) [CardName]
forall a b. b -> Either a b
Right [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]
}
ldToPileEntry :: LayeredEffectDefinition -> PileEntry
ldToPileEntry :: LayeredEffectDefinition -> PileEntry
ldToPileEntry LayeredEffectDefinition
ld =
PileEntry :: Card
-> Timestamp
-> [LayeredEffectPart]
-> Either (EffectMonad CardMatcher) [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 :: Either (EffectMonad CardMatcher) [CardName]
_peAppliesTo = EffectMonad CardMatcher
-> Either (EffectMonad CardMatcher) [CardName]
forall a b. a -> Either a b
Left (Getting
(EffectMonad CardMatcher)
LayeredEffectDefinition
(EffectMonad CardMatcher)
-> LayeredEffectDefinition -> EffectMonad CardMatcher
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(EffectMonad CardMatcher)
LayeredEffectDefinition
(EffectMonad CardMatcher)
Lens' LayeredEffectDefinition (EffectMonad CardMatcher)
leAppliesTo LayeredEffectDefinition
ld)
}
applyEffectsAtLayer :: Layer -> (Board, Pile) -> (Board, Pile)
applyEffectsAtLayer :: Layer -> (Board, Pile) -> (Board, Pile)
applyEffectsAtLayer Layer
layer (Board
board, Pile
pile) =
(Pile, Board) -> (Board, Pile)
forall a b. (a, b) -> (b, a)
swap ((Pile, Board) -> (Board, Pile))
-> (Board -> (Pile, Board)) -> Board -> (Board, Pile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State Board Pile -> Board -> (Pile, Board)
forall s a. State s a -> s -> (a, s)
runState ([Maybe PileEntry] -> Pile
forall a. [Maybe a] -> [a]
catMaybes ([Maybe PileEntry] -> Pile)
-> StateT Board Identity [Maybe PileEntry] -> State Board Pile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PileEntry -> StateT Board Identity (Maybe PileEntry))
-> Pile -> StateT Board Identity [Maybe PileEntry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Layer -> PileEntry -> StateT Board Identity (Maybe PileEntry)
applyEntry Layer
layer) Pile
pile) (Board -> (Board, Pile)) -> Board -> (Board, Pile)
forall a b. (a -> b) -> a -> b
$ Board
board
where
applyEntry :: Layer -> PileEntry -> State Board (Maybe PileEntry)
applyEntry :: Layer -> PileEntry -> StateT Board Identity (Maybe PileEntry)
applyEntry Layer
layer PileEntry
pe = do
let ([LayeredEffectPart]
parts, [LayeredEffectPart]
remainder) = (LayeredEffectPart -> Bool)
-> [LayeredEffectPart]
-> ([LayeredEffectPart], [LayeredEffectPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Layer -> LayeredEffectPart -> Bool
isLayer Layer
layer) (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)
if [LayeredEffectPart] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LayeredEffectPart]
parts then
Maybe PileEntry -> StateT Board Identity (Maybe PileEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (PileEntry -> Maybe PileEntry
forall a. a -> Maybe a
Just PileEntry
pe)
else do
Board
board <- StateT Board Identity Board
forall s (m :: * -> *). MonadState s m => m s
get
let effectEnv :: (Board, Card)
effectEnv = (Board
board, 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)
let cns :: [CardName]
cns = (EffectMonad CardMatcher -> [CardName])
-> ([CardName] -> [CardName])
-> Either (EffectMonad CardMatcher) [CardName]
-> [CardName]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Board, Card) -> EffectMonad CardMatcher -> [CardName]
resolveAppliesTo (Board, Card)
effectEnv) [CardName] -> [CardName]
forall a. a -> a
id (Getting
(Either (EffectMonad CardMatcher) [CardName])
PileEntry
(Either (EffectMonad CardMatcher) [CardName])
-> PileEntry -> Either (EffectMonad CardMatcher) [CardName]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(Either (EffectMonad CardMatcher) [CardName])
PileEntry
(Either (EffectMonad CardMatcher) [CardName])
Lens' PileEntry (Either (EffectMonad CardMatcher) [CardName])
peAppliesTo 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]
cns
Bool -> StateT Board Identity () -> StateT Board Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Card] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Card]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [CardName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CardName]
cns)
(CardName -> StateT Board Identity ()
forall a. HasCallStack => CardName -> a
error CardName
"assertion failed: effected card did not exist on board")
let newCs :: [Card]
newCs = (Card -> Card) -> [Card] -> [Card]
forall a b. (a -> b) -> [a] -> [b]
map ((Board, Card) -> [LayeredEffectPart] -> Card -> Card
applyEffectParts (Board, Card)
effectEnv [LayeredEffectPart]
parts) [Card]
cs
ASetter Board Board (HashMap CardName Card) (HashMap CardName Card)
-> (HashMap CardName Card -> HashMap CardName Card)
-> StateT Board Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
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] -> [(CardName, Card)]
forall a b. (a -> b) -> [a] -> [(b, a)]
indexBy (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] -> HashMap CardName Card -> HashMap CardName Card)
-> [Card] -> HashMap CardName Card -> HashMap CardName Card
forall a b. (a -> b) -> a -> b
$ [Card]
newCs)
Maybe PileEntry -> StateT Board Identity (Maybe PileEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PileEntry -> StateT Board Identity (Maybe PileEntry))
-> Maybe PileEntry -> StateT Board Identity (Maybe PileEntry)
forall a b. (a -> b) -> a -> b
$
if [LayeredEffectPart] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LayeredEffectPart]
remainder then
Maybe PileEntry
forall a. Maybe a
Nothing
else
PileEntry -> Maybe PileEntry
forall a. a -> Maybe a
Just
(PileEntry -> Maybe PileEntry)
-> (PileEntry -> PileEntry) -> PileEntry -> Maybe PileEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
PileEntry
PileEntry
(Either (EffectMonad CardMatcher) [CardName])
(Either (EffectMonad CardMatcher) [CardName])
-> Either (EffectMonad CardMatcher) [CardName]
-> PileEntry
-> PileEntry
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
PileEntry
PileEntry
(Either (EffectMonad CardMatcher) [CardName])
(Either (EffectMonad CardMatcher) [CardName])
Lens' PileEntry (Either (EffectMonad CardMatcher) [CardName])
peAppliesTo ([CardName] -> Either (EffectMonad CardMatcher) [CardName]
forall a b. b -> Either a b
Right [CardName]
cns)
(PileEntry -> PileEntry)
-> (PileEntry -> PileEntry) -> PileEntry -> PileEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter PileEntry PileEntry [LayeredEffectPart] [LayeredEffectPart]
-> [LayeredEffectPart] -> PileEntry -> PileEntry
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter PileEntry PileEntry [LayeredEffectPart] [LayeredEffectPart]
Lens' PileEntry [LayeredEffectPart]
peEffect [LayeredEffectPart]
remainder
(PileEntry -> Maybe PileEntry) -> PileEntry -> Maybe PileEntry
forall a b. (a -> b) -> a -> b
$ PileEntry
pe
resolveAppliesTo :: EffectMonadEnv -> EffectMonad CardMatcher -> [CardName]
resolveAppliesTo :: (Board, Card) -> EffectMonad CardMatcher -> [CardName]
resolveAppliesTo (Board
board, Card
source) EffectMonad CardMatcher
m =
(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] -> [CardName]) -> (Board -> [Card]) -> Board -> [CardName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Card -> Bool) -> [Card] -> [Card]
forall a. (a -> Bool) -> [a] -> [a]
filter (CardMatcher -> Card -> Bool
applyMatcher (CardMatcher -> Card -> Bool) -> CardMatcher -> Card -> Bool
forall a b. (a -> b) -> a -> b
$ EffectMonad CardMatcher -> (Board, Card) -> CardMatcher
forall r a. Reader r a -> r -> a
runReader EffectMonad CardMatcher
m (Board
board, Card
source))
([Card] -> [Card]) -> (Board -> [Card]) -> Board -> [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 -> 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 -> [CardName]) -> Board -> [CardName]
forall a b. (a -> b) -> a -> b
$ Board
board
applyEffectParts :: EffectMonadEnv -> [LayeredEffectPart] -> Card -> Card
applyEffectParts :: (Board, Card) -> [LayeredEffectPart] -> Card -> Card
applyEffectParts (Board, Card)
env [LayeredEffectPart]
es Card
target =
(Card -> LayeredEffectPart -> Card)
-> Card -> [LayeredEffectPart] -> Card
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
(\Card
t (LayeredEffectPart Layer
_ Card -> EffectMonad Card
eff) -> EffectMonad Card -> (Board, Card) -> Card
forall r a. Reader r a -> r -> a
runReader (Card -> EffectMonad Card
eff Card
t) (Board, Card)
env)
Card
target
[LayeredEffectPart]
es
indexBy :: (a -> b) -> [a] -> [(b, a)]
indexBy :: (a -> b) -> [a] -> [(b, a)]
indexBy a -> b
f = (a -> (b, a)) -> [a] -> [(b, a)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) (b -> a -> (b, a)) -> (a -> b) -> a -> a -> (b, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> b
f (a -> a -> (b, a)) -> (a -> a) -> a -> (b, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> a
forall a. a -> a
id)
(LayeredEffectPart Layer
l Card -> EffectMonad Card
_) = Layer
l
isLayer :: Layer -> LayeredEffectPart -> Bool
isLayer :: Layer -> LayeredEffectPart -> Bool
isLayer Layer
l LayeredEffectPart
p = Layer
l Layer -> Layer -> Bool
forall a. Eq a => a -> a -> Bool
== LayeredEffectPart -> Layer
extractLayer LayeredEffectPart
p