/
Engine.hs
174 lines (143 loc) · 5.01 KB
/
Engine.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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
{-# LANGUAGE TypeOperators #-}
module Engine where
import qualified IdList
import Labels
import Predicates
import Types
import Control.Applicative ((<$>))
import Control.Monad (forever)
import Control.Monad.Operational
import Control.Monad.Random (RandT, StdGen)
import Control.Monad.State (StateT)
import Control.Monad.Trans (lift)
import Data.Ord (comparing)
import Data.Label.Pure (set)
import Data.Label.PureM (gets, puts, (=:))
import Data.List (sortBy)
import Data.Traversable (for)
type Engine = StateT World (RandT StdGen (Program Ask))
round :: Engine ()
round = forever $ do
players ~:* set manaPool []
nextStep >>= executeStep
nextStep :: Engine Step
nextStep = do
(rp, s : ss) : ts <- gets turnStructure
turnStructure =: if null ss then ts else (rp, ss) : ts
activePlayer =: rp
activeStep =: s
return s
executeStep :: Step -> Engine ()
executeStep (BeginningPhase UntapStep) = do
-- TODO [502.1] phasing
-- [502.2] untap permanents
rp <- gets activePlayer
ios <- IdList.filter (isControlledBy rp) <$> gets battlefield
_ <- for ios $ \(i, _) -> executeEffect (UntapPermanent i)
return ()
executeStep (BeginningPhase UpkeepStep) = do
-- TODO [503.1] handle triggers
-- [503.2]
offerPriority
executeStep (BeginningPhase DrawStep) = do
-- [504.1]
DrawCard <$> gets activePlayer >>= executeEffect
-- TODO [504.2] handle triggers
-- [504.3]
offerPriority
executeStep MainPhase = do
-- TODO [505.4] handle triggers
-- [505.5]
offerPriority
executeStep (CombatPhase BeginningOfCombatStep) = do
offerPriority
executeStep (CombatPhase DeclareAttackersStep) = do
-- TODO [508.1a] declare attackers
-- TODO [508.1b] declare which player or planeswalker each attacker attacks
-- TODO [508.1c] check attacking restrictions
-- TODO [508.1d] check attacking requirements
-- TODO [508.1e] declare banding
-- TODO [508.1f] tap attackers
-- TODO [508.1g] determine costs
-- TODO [508.1h] allow mana abilities
-- TODO [508.1i] pay costs
-- TODO [508.1j] mark creatures as attacking
-- TODO [508.2] handle triggers
offerPriority
-- TODO [508.6] potentially skip declare blockers and combat damage steps
return ()
executeStep (CombatPhase DeclareBlockersStep) = do
-- TODO [509.1a] declare blockers
-- TODO [509.1b] check blocking restrictions
-- TODO [509.1c] check blocking requirements
-- TODO [509.1d] determine costs
-- TODO [509.1e] allow mana abilities
-- TODO [509.1f] pay costs
-- TODO [509.1g] mark creatures as blocking
-- TODO [509.1h] mark creatures as blocked
-- TODO [509.2] declare attackers' damage assignment order
-- TODO [509.3] declare blockers' damage assignment order
-- TODO [509.4] handle triggers
offerPriority
-- TODO [509.6] determine new attackers' damage assignment order
-- TODO [509.7] determine new blockers' damage assignment order
return ()
executeStep (CombatPhase CombatDamageStep) = do
-- TODO [510.1] assign combat damage
-- TODO [510.2] deal damage
-- TODO [510.3] handle triggers
offerPriority
-- TODO [510.5] possibly introduce extra combat damage step for first/double strike
return ()
executeStep (CombatPhase EndOfCombatStep) = do
-- TODO [511.1] handle triggers
-- [511.2]
offerPriority
-- TODO [511.3] remove creatures from combat
return ()
executeStep (EndPhase EndOfTurnStep) = do
-- TODO [513.1] handle triggers
-- [513.2]
offerPriority
executeStep (EndPhase CleanupStep) = do
-- TODO [514.1] discard excess cards
-- TODO [514.2] remove damage from permanents
-- TODO [514.3] handle triggers; check state-based actions; possibly offer priority
return ()
executeEffect :: OneShotEffect -> Engine ()
executeEffect e = do
-- TODO trigger abilities
-- TODO apply replacement effects
compileEffect e
compileEffect :: OneShotEffect -> Engine ()
compileEffect (UntapPermanent ro) =
battlefield .^ listEl ro .^ tapStatus =: Just Untapped
compileEffect (DrawCard rp) = do
lib <- gets (players .^ listEl rp .^ library)
case IdList.toList lib of
[] -> players .^ listEl rp .^ failedCardDraw =: True
(ro, _) : _ -> executeEffect (MoveObject (Library rp, ro) (Hand rp))
compileEffect (MoveObject rObject@(rFromZone, i) rToZone) = do
mObject <- lookupObject rObject
case mObject of
Nothing -> return ()
Just object -> do
compileZoneRef rFromZone ~: IdList.remove i
compileZoneRef rToZone ~: IdList.cons object
compileEffect (ShuffleLibrary rPlayer) = do
let libraryLabel = players .^ listEl rPlayer .^ library
lib <- gets libraryLabel
lib' <- lift (IdList.shuffle lib)
puts libraryLabel lib'
compileEffect _ = undefined
lookupObject :: ObjectRef -> Engine (Maybe Object)
lookupObject (rz, i) = IdList.get i <$> gets (compileZoneRef rz)
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn = sortBy . comparing
offerPriority :: Engine ()
offerPriority = do
-- TODO check state-based actions
-- TODO empty prestacks in APNAP order
-- TODO offer available actions to players in APNAP order
-- TODO when everyone passes, return
return ()