Skip to content
This repository
  • 5 commits
  • 8 files changed
  • 0 comments
  • 1 contributor
9  BasicLands.hs
@@ -2,9 +2,9 @@
2 2
 
3 3
 module BasicLands where
4 4
 
  5
+import Core
5 6
 import Labels
6 7
 import Predicates
7  
-import Types
8 8
 import Utils
9 9
 
10 10
 import Control.Applicative
@@ -20,7 +20,7 @@ swamp    = mkBasicLandCard Swamp    Black
20 20
 mountain = mkBasicLandCard Mountain Red
21 21
 forest   = mkBasicLandCard Forest   Green
22 22
 
23  
-mkBasicLandCard :: LandType -> Color -> Card
  23
+mkBasicLandCard :: LandSubtype -> Color -> Card
24 24
 mkBasicLandCard ty color = mkCard $ do
25 25
   name               =: Just (fromString (show ty))
26 26
   types              =: basicType <> objectType ty
@@ -35,7 +35,7 @@ playLand rSource rActivator = ClosedAbility
35 35
         _           -> return False
36 36
   , _manaCost = mempty
37 37
   , _additionalCosts = []
38  
-  , _effect = SpecialAction (return [MoveObject rSource Battlefield])
  38
+  , _effect = SpecialAction (return [WillSimpleEffect (PlayLand rSource)])
39 39
   }
40 40
 
41 41
 tapToAddMana :: Maybe Color -> Ability
@@ -46,7 +46,8 @@ tapToAddMana mc rSource rActivator = ClosedAbility
46 46
         _                -> return False
47 47
   , _manaCost = mempty
48 48
   , _additionalCosts = []
49  
-  , _effect = SpecialAction (return [AddToManaPool rActivator mc])
  49
+  -- TODO require cost: tap self
  50
+  , _effect = SpecialAction (return [WillSimpleEffect (AddToManaPool rActivator mc)])
50 51
   }
51 52
 
52 53
 checkObject :: ObjectRef -> (Object -> Bool) -> View Bool
76  Core.hs
... ...
@@ -0,0 +1,76 @@
  1
+{-# LANGUAGE ScopedTypeVariables #-}
  2
+{-# LANGUAGE TypeOperators #-}
  3
+
  4
+module Core
  5
+  ( compileZoneRef
  6
+  , evaluate, singleTarget, (<?>), askMagicTargets, allTargets
  7
+  , module Types
  8
+  ) where
  9
+
  10
+import IdList (IdList)
  11
+import qualified IdList
  12
+import Labels
  13
+import Types
  14
+
  15
+import Control.Applicative
  16
+import qualified Control.Monad.Operational as Operational
  17
+import Control.Monad (forM, filterM)
  18
+import Control.Monad.Trans (lift)
  19
+import Data.Label.Pure ((:->))
  20
+import Data.Label.PureM (asks)
  21
+
  22
+
  23
+compileZoneRef :: ZoneRef -> World :-> IdList Object
  24
+compileZoneRef z =
  25
+  case z of
  26
+    Library p   -> players .^ listEl p .^ library
  27
+    Hand p      -> players .^ listEl p .^ hand
  28
+    Battlefield -> battlefield
  29
+    Graveyard p -> players .^ listEl p .^ graveyard
  30
+    Stack       -> stack
  31
+    Exile       -> exile
  32
+    Command     -> command
  33
+
  34
+evaluate :: TargetList Target a -> ([Target], a)
  35
+evaluate (Nil x)       = ([], x)
  36
+evaluate (Snoc xs t)   = (ts ++ [t], f t) where (ts, f) = evaluate xs
  37
+evaluate (Test f _ xs) = (ts,        f x) where (ts, x) = evaluate xs
  38
+
  39
+singleTarget :: TargetList () Target
  40
+singleTarget = Snoc (Nil id) ()
  41
+
  42
+infixl 4 <?>
  43
+(<?>) :: TargetList t a -> (a -> View Bool) -> TargetList t a
  44
+xs <?> ok = Test id ok xs
  45
+
  46
+askTargets :: forall a. ([Target] -> Magic Target) -> [Target] -> TargetList () a -> Magic (TargetList Target a)
  47
+askTargets choose = askTargets' (const (return True))
  48
+  where
  49
+    askTargets' :: forall b. (b -> View Bool) -> [Target] -> TargetList () b -> Magic (TargetList Target b)
  50
+    askTargets' ok ts scheme =
  51
+      case scheme of
  52
+        Nil x -> return (Nil x)
  53
+        Snoc xs () -> do
  54
+          xs' <- askTargets choose ts xs
  55
+          let (_, f) = evaluate xs'
  56
+          eligibleTargets <- view (filterM (ok . f) ts)
  57
+          chosen <- choose eligibleTargets
  58
+          return (Snoc xs' chosen)
  59
+        Test f ok' scheme' -> do
  60
+          z <- askTargets' (\x -> (&&) <$> ok (f x) <*> ok' x) ts scheme'
  61
+          return (f <$> z)
  62
+
  63
+askMagicTargets :: PlayerRef -> TargetList () a -> Magic (TargetList Target a)
  64
+askMagicTargets p ts = do
  65
+  ats <- allTargets
  66
+  askTargets (lift . Operational.singleton . AskTarget p) ats ts
  67
+
  68
+allTargets :: Magic [Target]
  69
+allTargets = do
  70
+  ps <- IdList.ids <$> asks players
  71
+  let zrs = [Exile, Battlefield, Stack, Command] ++
  72
+            [ z p | z <- [Library, Hand, Graveyard], p <- ps ]
  73
+  oss <- forM zrs $ \zr -> do
  74
+    os <- IdList.ids <$> asks (compileZoneRef zr)
  75
+    return (map (\o -> (zr, o)) os)
  76
+  return (map TargetPlayer ps ++ map TargetObject (concat oss))
75  Engine.hs
@@ -2,21 +2,22 @@
2 2
 
3 3
 module Engine where
4 4
 
  5
+import Core
5 6
 import IdList (Id)
6 7
 import qualified IdList
7 8
 import Labels
8 9
 import Predicates
9  
-import Types
10  
-import Utils
  10
+import Utils hiding (object)
11 11
 
12 12
 import Control.Applicative ((<$>))
13 13
 import Control.Monad (forever, void, forM_, replicateM_)
14 14
 import qualified Control.Monad.Operational as Operational
15 15
 import Control.Monad.Random (RandT, StdGen)
16  
-import Control.Monad.State (StateT)
  16
+import Control.Monad.Reader (runReaderT)
  17
+import Control.Monad.State (StateT, get)
17 18
 import Control.Monad.Trans (lift)
18 19
 import Data.Ord (comparing)
19  
-import Data.Label.Pure (set)
  20
+import Data.Label.Pure (set, (:->))
20 21
 import Data.Label.PureM (gets, puts, (=:))
21 22
 import Data.List (sortBy)
22 23
 import Data.Maybe (catMaybes)
@@ -56,9 +57,9 @@ round :: Engine ()
56 57
 round = forever $ do
57 58
   players ~:* set manaPool []
58 59
   step <- nextStep
59  
-  raise (BeginStep step)
  60
+  raise (DidBeginStep step)
60 61
   executeStep step
61  
-  raise (EndStep step)
  62
+  raise (WillEndStep step)
62 63
 
63 64
 nextStep :: Engine Step
64 65
 nextStep = do
@@ -84,7 +85,7 @@ executeStep (BeginningPhase UntapStep) = do
84 85
   -- [502.2] untap permanents
85 86
   rp <- gets activePlayer
86 87
   ios <- IdList.filter (isControlledBy rp) <$> gets battlefield
87  
-  _ <- for ios $ \(i, _) -> executeEffect (UntapPermanent i)
  88
+  _ <- for ios $ \(i, _) -> executeEffect (WillSimpleEffect (UntapPermanent i))
88 89
   return ()
89 90
 
90 91
 executeStep (BeginningPhase UpkeepStep) = do
@@ -95,7 +96,7 @@ executeStep (BeginningPhase UpkeepStep) = do
95 96
 
96 97
 executeStep (BeginningPhase DrawStep) = do
97 98
   -- [504.1]
98  
-  DrawCard <$> gets activePlayer >>= executeEffect
  99
+  WillSimpleEffect . DrawCard <$> gets activePlayer >>= executeEffect
99 100
 
100 101
   -- TODO [504.2]  handle triggers
101 102
 
@@ -183,11 +184,15 @@ executeEffect e = do
183 184
 -- Compilation of effects
184 185
 
185 186
 compileEffect :: OneShotEffect -> Engine ()
186  
-compileEffect (UntapPermanent i) = untapPermanent i
187  
-compileEffect (DrawCard rp) = drawCard rp
188  
-compileEffect (MoveObject rObj rToZone) = moveObject rObj rToZone
189  
-compileEffect (ShuffleLibrary rPlayer) = shuffleLibrary rPlayer
190  
-compileEffect _ = undefined
  187
+compileEffect (WillSimpleEffect e) = compileSimpleEffect e
  188
+compileEffect (WillMoveObject rObj rToZone obj) = moveObject rObj rToZone obj
  189
+
  190
+compileSimpleEffect :: SimpleOneShotEffect -> Engine ()
  191
+compileSimpleEffect (UntapPermanent i) = untapPermanent i
  192
+compileSimpleEffect (DrawCard rp) = drawCard rp
  193
+compileSimpleEffect (ShuffleLibrary rPlayer) = shuffleLibrary rPlayer
  194
+compileSimpleEffect _ = undefined
  195
+
191 196
 
192 197
 
193 198
 tick :: Engine Timestamp
@@ -204,21 +209,21 @@ drawCard rp = do
204 209
   lib <- gets (players .^ listEl rp .^ library)
205 210
   case IdList.toList lib of
206 211
     []          -> players .^ listEl rp .^ failedCardDraw =: True
207  
-    (ro, _) : _ -> executeEffect (MoveObject (Library rp, ro) (Hand rp))
  212
+    (ro, o) : _ -> executeEffect (WillMoveObject (Library rp, ro) (Hand rp) o)
208 213
 
209  
-moveObject :: ObjectRef -> ZoneRef -> Engine ()
210  
-moveObject (rFromZone, i) rToZone = do
  214
+moveObject :: ObjectRef -> ZoneRef -> Object -> Engine ()
  215
+moveObject (rFromZone, i) rToZone obj = do
211 216
   mObj <- IdList.removeM (compileZoneRef rFromZone) i
212 217
   case mObj of
213  
-    Nothing     -> return ()
214  
-    Just obj -> do
  218
+    Nothing -> return ()
  219
+    Just _  -> do
215 220
       t <- tick
216 221
       void (IdList.consM (compileZoneRef rToZone) (set timestamp t obj))
217 222
 
218 223
 moveAllObjects :: ZoneRef -> ZoneRef -> Engine ()
219 224
 moveAllObjects rFromZone rToZone = do
220  
-  objectIds <- map fst . IdList.toList <$> gets (compileZoneRef rFromZone)
221  
-  forM_ objectIds $ \i -> moveObject (rFromZone, i) rToZone
  225
+  ois <- IdList.toList <$> gets (compileZoneRef rFromZone)
  226
+  forM_ ois $ \(i, o) -> moveObject (rFromZone, i) rToZone o
222 227
 
223 228
 shuffleLibrary :: PlayerRef -> Engine ()
224 229
 shuffleLibrary rPlayer = do
@@ -236,4 +241,34 @@ offerPriority = do
236 241
   -- TODO empty prestacks in APNAP order
237 242
   -- TODO offer available actions to players in APNAP order
238 243
   -- TODO when everyone passes, return
  244
+  playerIds <- apnap
  245
+  forM_ playerIds $ \p -> do
  246
+    actions       <- collectActions p
  247
+    PlayCard rObj <- liftQuestion (AskPriorityAction p actions)
  248
+    Just ability  <- gets (object rObj .^ play)
  249
+    executeAction ability rObj p
239 250
   return ()
  251
+
  252
+object :: ObjectRef -> World :-> Object
  253
+object (zoneRef, i) = compileZoneRef zoneRef .^ listEl i
  254
+
  255
+collectActions :: PlayerRef -> Engine [PriorityAction]
  256
+collectActions = undefined
  257
+
  258
+executeAction :: Ability -> ObjectRef -> PlayerRef -> Engine ()
  259
+executeAction ability rSource activatorId = do
  260
+  let closedAbility = ability rSource activatorId
  261
+  -- TODO pay costs
  262
+  case _effect closedAbility of
  263
+    SpecialAction m -> executeMagic m >>= mapM_ executeEffect
  264
+    StackingAction _ -> return ()
  265
+
  266
+executeMagic :: Magic a -> Engine a
  267
+executeMagic m = get >>= lift . lift . runReaderT m
  268
+
  269
+-- | Returns player IDs in APNAP order (active player, non-active player).
  270
+apnap :: Engine [PlayerRef]
  271
+apnap = do
  272
+  activePlayerId <- gets activePlayer
  273
+  (ps, qs) <- break (== activePlayerId) . IdList.ids <$> gets players
  274
+  return (qs ++ ps)
5  IdList.hs
@@ -2,7 +2,7 @@
2 2
 
3 3
 module IdList
4 4
   ( Id, IdList
5  
-  , empty, get, set, remove, cons, fromList, toList, filter, shuffle
  5
+  , empty, get, set, remove, cons, fromList, toList, ids, filter, shuffle
6 6
   , consM, removeM, shuffleM
7 7
   ) where
8 8
 
@@ -54,6 +54,9 @@ fromList = foldr (\x xs -> snd (cons x xs)) empty
54 54
 toList :: IdList a -> [(Id, a)]
55 55
 toList (IdList ixs _) = ixs
56 56
 
  57
+ids :: IdList a -> [Id]
  58
+ids = map fst . toList
  59
+
57 60
 filter :: (a -> Bool) -> IdList a -> [(Id, a)]
58 61
 filter f = Prelude.filter (f . snd) . toList
59 62
 
156  M12.hs
@@ -2,129 +2,39 @@
2 2
 
3 3
 module M12 where
4 4
 
5  
-import Types
6  
-import Labels
7  
-import Predicates
  5
+import Core
8 6
 import Utils
9 7
 
10 8
 import Control.Applicative
11  
-import Control.Monad (when)
12  
-import Data.Boolean
13  
-import qualified Data.IntMap as IntMap
14  
-import Data.Label.MaybeM
15  
-import Data.Maybe (catMaybes)
16  
-import Data.Monoid
17  
-import Data.Set (Set)
18  
-import qualified Data.Set as Set
19  
-import Data.Text (Text)
20  
-
21  
-
22  
--- doomblade :: Card
23  
--- doomblade =
24  
---   mkInstant "Doomblade" [PayMana [Just Black, Nothing]] $
25  
---     \rSelf rOwner -> do
26  
---       let crit = notB (hasColor Black) &&* isOnBattlefield
27  
---       rTarget <- targetCreature crit
28  
---       stack rSelf $ do
29  
---         o <- gets (object rTarget)
30  
---         when (crit o) $ object rTarget .^ zone =: Graveyard
31  
--- 
32  
-goblinFireslinger :: Card
33  
-goblinFireslinger = Card
34  
-  { enterWorld = \timestamp rOwner rSelf -> Object
35  
-    { _name = Just "Goblin Fireslinger"
36  
-    , _colors = colorsFromCost cost
37  
-    , _group = Permanent
38  
-      { _supertypes = Set.empty
39  
-      , _creatureTypes = Set.fromList [Goblin, Warrior]
40  
-      }
41  
-    , _zone = Library
42  
-    , _owner = rOwner
43  
-    , _controller = rOwner
44  
-    
45  
-    , _power = 1
46  
-    , _toughness = 1
47  
-    , _damage = 0
48  
-    
49  
-    , _activatedAbilities =
50  
-      [ Action
51  
-        { _available = \rp ->
52  
-            (isInZone Battlefield &&* isControlledBy rp) <$>
53  
-            gets (object rSelf)
54  
-        , _cost = mempty { tapPermanents = [\(r, _) -> r == rSelf] }
55  
-        , _effect = do
56  
-            rt <- targetPlayer
57  
-            stack rSelf $ player rt .^ life .~ subtract 1
58  
-        }
59  
-      ]
60  
-    , _play = Action
61  
-      { _available = \rp ->
62  
-          (isInZone Hand &&* isControlledBy rp) <$>
63  
-          gets (object rSelf)
64  
-      , _cost = cost
65  
-      , _effect = stack rSelf $
66  
-          object rSelf .^ zone =: Battlefield Untapped
67  
-      }
68  
-    , _timestamp = timestamp
69  
-    , _staticAbilities = []
70  
-    , _counters = []
71  
-    , _continuousEffects = []
72  
-    }
73  
-  }
74  
-  where
75  
-    cost = mempty { payColoredMana = [Red] }
76  
-
77  
--- stack :: Ref Object -> Magic () -> Magic ()
78  
--- stack r a = raise $ move r (Stack a)
79  
-
80  
--- move :: Ref Object -> Zone -> Magic ()
81  
--- move r z = do
82  
---   object r .^ zone =: z
83  
---   object r .^ effects =: []
84  
---   object r .^ counters =: []  -- [121.2]
85  
---   stamp >>= puts (object r .^ timestamp)  -- [613.6c]
86  
-
87  
--- target :: (Object -> Bool) -> Magic (Ref Object)
88  
--- target = undefined
89  
--- 
90  
--- targetCreature :: (Object -> Bool) -> Magic (Ref Object)
91  
--- targetCreature = undefined
92  
--- 
93  
--- targetPlayer :: Magic (Ref Player)
94  
--- targetPlayer = targetPlayer' (const True)
95  
--- 
96  
--- targetOpponent :: Ref Player -> Magic (Ref Player)
97  
--- targetOpponent rController = targetPlayer' (\(rp, _) -> rp /= rController)
98  
--- 
99  
--- targetPlayer' :: (WithRef Player -> Bool) -> Magic (Ref Player)
100  
--- targetPlayer' f = do
101  
---   rpps <- IntMap.toList <$> gets players
102  
---   choose [ (TargetPlayer rp, rp) | rpp@(rp, _) <- rpps, f rpp ]
103  
--- 
104  
--- mkInstant :: Text -> [Cost] -> (Ref Player -> Ref Object ->
105  
---   Magic ()) -> Card
106  
--- mkInstant name cost effect = Card
107  
---   { enterWorld = \timestamp rOwner rSelf -> Object
108  
---     { _name = Just name
109  
---     , _colors = colorsFromCost cost
110  
---     , _group = Spell Instant
111  
---     , _zone = Library
112  
---     , _owner = rOwner
113  
---     , _controller = rOwner
114  
---     , _activatedAbilities = []
115  
---     , _play = Action
116  
---       { _available = \rp ->
117  
---         (isInHand &&* isControlledBy rp) <$>
118  
---         gets (object rSelf)
119  
---       , _cost = cost
120  
---       , _effect = stack rSelf (effect rOwner rSelf)
121  
---       }
122  
---     , _timestamp = timestamp
123  
---     , _staticAbilities = []
124  
---     , _counters = []
125  
---     , _effects = []
126  
---     }
127  
---   }
128  
-
129  
-colorsFromCost :: Cost -> Set Color
130  
-colorsFromCost = Set.fromList . payColoredMana
  9
+import Data.Label.PureM ((=:))
  10
+
  11
+
  12
+shock :: Card
  13
+shock = mkCard $ do
  14
+  name  =: Just "Shock"
  15
+  types =: instantType
  16
+  play  =: (Just $ \rSelf rActivator ->
  17
+    ClosedAbility
  18
+      { _available =
  19
+          case rSelf of
  20
+            (Hand rp, _) -> return (rp == rActivator)
  21
+            _            -> return False
  22
+      , _manaCost = ManaCost [Red] 0
  23
+      , _additionalCosts = []
  24
+      , _effect = StackingAction (shockEffect rSelf rActivator)
  25
+      })
  26
+
  27
+shockEffect :: ObjectRef -> PlayerRef -> Magic StackItem
  28
+shockEffect rSelf rActivator = do
  29
+  -- TODO check for hexproof
  30
+  -- TODO check for protection
  31
+  -- TODO realise rSelf is sometimes in hand, sometimes on the stack
  32
+  let ok t = case t of
  33
+              TargetObject (Battlefield, _) -> return True
  34
+              TargetPlayer _                -> return True
  35
+              _                             -> return False
  36
+  ts <- askMagicTargets rActivator (singleTarget <?> ok)
  37
+  let f t = case t of
  38
+              TargetObject or -> return [WillSimpleEffect (DamageObject rSelf or 2 False True)]
  39
+              TargetPlayer pr -> return [WillSimpleEffect (DamagePlayer rSelf pr 2 False True)]
  40
+  return (f <$> ts)
2  Makefile
... ...
@@ -1,2 +1,2 @@
1 1
 run:
2  
-	ghci -Wall M12
  2
+	ghci -Wall Engine
71  Types.hs
@@ -15,7 +15,6 @@ import Control.Monad.Reader
15 15
 import Control.Monad.Identity
16 16
 import qualified Control.Monad.Operational as Operational
17 17
 import Data.Label (mkLabels)
18  
-import Data.Label.Pure ((:->))
19 18
 import Data.Monoid
20 19
 import Data.Set (Set)
21 20
 import Data.Text (Text)
@@ -125,7 +124,7 @@ type Timestamp = Int
125 124
 data Color = White | Blue | Black | Red | Green
126 125
   deriving (Eq, Ord, Show, Read, Enum, Bounded)
127 126
 
128  
-data ZoneRef = Library PlayerRef | Hand PlayerRef | Battlefield | Graveyard PlayerRef | Stack | Exile
  127
+data ZoneRef = Library PlayerRef | Hand PlayerRef | Battlefield | Graveyard PlayerRef | Stack | Exile | Command
129 128
   deriving (Eq, Ord, Show, Read)
130 129
 
131 130
 data TapStatus = Untapped | Tapped
@@ -276,20 +275,24 @@ data Layer
276 275
 
277 276
 -- | Events triggered abilities watch for.
278 277
 data Event
279  
-  = OneShotEffectEvent OneShotEffect
  278
+  = DidSimpleEffect SimpleOneShotEffect
  279
+  | DidMoveObject ZoneRef ObjectRef  -- old zone, new zone/id
280 280
 
281 281
   -- Keyword actions [701]
282  
-  | ActivateAbility ObjectRef Int  -- index of ability
283  
-  | CastSpell PlayerRef ObjectRef  -- controller, spell
284  
-  | Counter ObjectRef ObjectRef  -- source (spell or ability), target
285  
-  | PlayLand ObjectRef
286  
-  | RegeneratePermanent ObjectRef
287  
-  | RevealCard ObjectRef
288  
-  | BeginStep Step
289  
-  | EndStep Step
290  
-  | LoseGame PlayerRef
  282
+  | DidActivateAbility ObjectRef Int  -- index of ability
  283
+  | DidCastSpell PlayerRef ObjectRef  -- controller, spell
  284
+  | DidCounter ObjectRef ObjectRef  -- source (spell or ability), target
  285
+  | DidPlayLand ObjectRef
  286
+  | DidRevealCard ObjectRef
  287
+  | DidBeginStep Step
  288
+  | WillEndStep Step
  289
+  | DidLoseGame PlayerRef
291 290
 
292 291
 data OneShotEffect
  292
+  = WillSimpleEffect SimpleOneShotEffect
  293
+  | WillMoveObject ObjectRef ZoneRef Object  -- current zone/id, new zone, suggested form
  294
+
  295
+data SimpleOneShotEffect
293 296
   = AdjustLife PlayerRef Int
294 297
   | DamageObject ObjectRef ObjectRef Int Bool Bool  -- source, creature/planeswalker, amount, combat damage?, preventable?
295 298
   | DamagePlayer ObjectRef PlayerRef Int Bool Bool  -- source, player, amount, combat damage?, preventable?
@@ -297,7 +300,6 @@ data OneShotEffect
297 300
   -- | ReorderLibraryCards
298 301
   | DrawCard PlayerRef -- Drawing is special [120.5]
299 302
   | DestroyPermanent ObjectRef Bool  -- target, preventable? -- Destruction is special [701.6b]
300  
-  | MoveObject ObjectRef ZoneRef
301 303
   | TapPermanent ObjectRef
302 304
   | UntapPermanent Id
303 305
   | AddCounter ObjectRef CounterType
@@ -306,13 +308,16 @@ data OneShotEffect
306 308
   | AddToManaPool PlayerRef (Maybe Color)
307 309
   | AttachPermanent ObjectRef (Maybe ObjectRef) (Maybe ObjectRef)  -- aura/equipment, old target, new target
308 310
   | RemoveFromCombat ObjectRef
  311
+  | PlayLand ObjectRef
  312
+
  313
+data PriorityAction = PlayCard ObjectRef
309 314
 
310 315
 
311 316
 -- Targets
312 317
 
313 318
 data Target
314 319
   = TargetPlayer PlayerRef
315  
-  | TargetObject (World :-> IdList Object) ObjectRef
  320
+  | TargetObject ObjectRef
316 321
 
317 322
 
318 323
 -- Stack items
@@ -320,7 +325,7 @@ data Target
320 325
 data TargetList t a where
321 326
   Nil  :: a -> TargetList t a
322 327
   Snoc :: TargetList t (Target -> a) -> t -> TargetList t a
323  
-  Test :: (x -> a) -> (x -> Bool) -> TargetList t x -> TargetList t a
  328
+  Test :: (x -> a) -> (x -> View Bool) -> TargetList t x -> TargetList t a
324 329
 
325 330
 instance Functor (TargetList t) where
326 331
   fmap f (Nil x)        = Nil (f x)
@@ -333,35 +338,6 @@ instance Applicative (TargetList t) where
333 338
   xs <*> Snoc ys t = Snoc ((.) <$> xs <*> ys) t
334 339
   xs <*> Test f ok ys = Test fst snd ((\g x -> (g (f x), ok x)) <$> xs <*> ys)
335 340
 
336  
-evaluate :: TargetList Target a -> ([Target], a)
337  
-evaluate (Nil x)       = ([], x)
338  
-evaluate (Snoc xs t)   = (ts ++ [t], f t) where (ts, f) = evaluate xs
339  
-evaluate (Test f _ xs) = (ts,        f x) where (ts, x) = evaluate xs
340  
-
341  
-singleTarget :: TargetList () Target
342  
-singleTarget = Snoc (Nil id) ()
343  
-
344  
-infixl 4 <?>
345  
-(<?>) :: TargetList t a -> (a -> Bool) -> TargetList t a
346  
-xs <?> ok = Test id ok xs
347  
-
348  
-askTargets :: forall m a. Monad m => ([Target] -> m Target) -> [Target] -> TargetList () a -> m (TargetList Target a)
349  
-askTargets choose = askTargets' (const True)
350  
-  where
351  
-    askTargets' :: forall b. (b -> Bool) -> [Target] -> TargetList () b -> m (TargetList Target b)
352  
-    askTargets' ok ts scheme =
353  
-      case scheme of
354  
-        Nil x -> return (Nil x)
355  
-        Snoc xs () -> do
356  
-          xs' <- askTargets choose ts xs
357  
-          let (_, f) = evaluate xs'
358  
-          let eligibleTargets = filter (ok . f) ts
359  
-          chosen <- choose eligibleTargets
360  
-          return (Snoc xs' chosen)
361  
-        Test f ok' scheme' -> do
362  
-          z <- askTargets' (\x -> ok (f x) && ok' x) ts scheme'
363  
-          return (f <$> z)
364  
-
365 341
 
366 342
 -- Monads
367 343
 
@@ -371,6 +347,11 @@ type View = ViewT Identity
371 347
 type Magic = ViewT (Operational.Program Ask)
372 348
 
373 349
 data Ask a where
374  
-  AskKeepHand :: PlayerRef -> Ask Bool
  350
+  AskKeepHand       :: PlayerRef -> Ask Bool
  351
+  AskPriorityAction :: PlayerRef -> [PriorityAction] -> Ask PriorityAction
  352
+  AskTarget         :: PlayerRef -> [Target] -> Ask Target
  353
+
  354
+view :: View a -> Magic a
  355
+view v = ReaderT $ return . runIdentity . runReaderT v
375 356
 
376 357
 $(mkLabels [''World, ''Player, ''Object, ''ObjectTypes, ''Action])
13  Utils.hs
@@ -2,9 +2,7 @@
2 2
 
3 3
 module Utils where
4 4
 
5  
-import IdList (IdList)
6 5
 import qualified IdList
7  
-import Labels
8 6
 import Types
9 7
 
10 8
 import Control.Monad.State (State, execState)
@@ -96,14 +94,3 @@ instance ObjectType PlaneswalkerSubtype where
96 94
 
97 95
 objectType :: ObjectType a => a -> ObjectTypes
98 96
 objectType ty = set objectTypeLabel (Just (Set.singleton ty)) mempty
99  
-
100  
-compileZoneRef :: ZoneRef -> World :-> IdList Object
101  
-compileZoneRef z =
102  
-  case z of
103  
-    Library p   -> players .^ listEl p .^ library
104  
-    Hand p      -> players .^ listEl p .^ hand
105  
-    Battlefield -> battlefield
106  
-    Graveyard p -> players .^ listEl p .^ graveyard
107  
-    Stack       -> stack
108  
-    Exile       -> exile
109  
-

No commit comments for this range

Something went wrong with that request. Please try again.