/
BasicLands.hs
69 lines (57 loc) · 2.16 KB
/
BasicLands.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
module Magic.BasicLands where
import Magic
import Control.Applicative
import Control.Monad (void)
import Data.Label.PureM
import Data.Monoid
import Data.String
plains, island, swamp, mountain, forest :: Card
plains = mkBasicLandCard Plains White
island = mkBasicLandCard Island Blue
swamp = mkBasicLandCard Swamp Black
mountain = mkBasicLandCard Mountain Red
forest = mkBasicLandCard Forest Green
mkBasicLandCard :: LandSubtype -> Color -> Card
mkBasicLandCard ty color = mkCard $ do
name =: Just (fromString (show ty))
types =: basicType <> landTypes [ty]
play =: Just playLand
activatedAbilities =: [tapToAddMana (Just color)]
playLand :: Activation
playLand = Activation
{ available = \rSource rActivator ->
case rSource of
(Some (Hand _), _) -> do
control <- checkObject rSource (isControlledBy rActivator)
stackEmpty <- isStackEmpty
ap <- asks activePlayer
step <- asks activeStep
n <- countLandsPlayedThisTurn (== rActivator)
return (control && ap == rActivator && step == MainPhase && stackEmpty && n < 1)
_ -> return False
, manaCost = mempty
, effect = \rSource rActivator -> void (executeEffect (Will (PlayLand rActivator rSource)))
}
countLandsPlayedThisTurn :: (PlayerRef -> Bool) -> View Int
countLandsPlayedThisTurn f = length . filter isPlayLand <$> asks turnHistory
where
isPlayLand (Did (PlayLand p _)) = f p
isPlayLand _ = False
tapToAddMana :: Maybe Color -> ActivatedAbility
tapToAddMana mc = ActivatedAbility
{ abilityActivation = Activation
{ available = \rSource rActivator ->
case rSource of
(Some Battlefield, _) ->
checkObject rSource (isControlledBy rActivator)
_ -> return False
, manaCost = mempty
, effect = \_rSource rActivator -> void (executeEffect (Will (AddToManaPool rActivator [mc])))
}
, abilityType = ManaAb
, tapCost = TapCost
}
checkObject :: SomeObjectRef -> (Object -> Bool) -> View Bool
checkObject r ok = ok <$> asks (objectBase r)