Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Moved Event-related types and functions to separate module Events

  • Loading branch information...
commit f265fc97bab7c0444bf1c14d942f21ad78864740 1 parent 905305c
@MedeaMelana authored
Showing with 168 additions and 142 deletions.
  1. +16 −4 Core.hs
  2. +9 −135 Engine.hs
  3. +135 −0 Events.hs
  4. +1 −0  M12.hs
  5. +1 −1  Magic.cabal
  6. +6 −2 Types.hs
View
20 Core.hs
@@ -2,10 +2,11 @@
{-# LANGUAGE TypeOperators #-}
module Core
- ( compileZoneRef
- , evaluateTargetList, singleTarget, (<?>), askMagicTargets, allTargets, allObjects
- , module Types
- ) where
+ --( compileZoneRef
+ --, evaluateTargetList, singleTarget, (<?>), askMagicTargets, allTargets, allObjects
+ --, module Types
+ --)
+ where
import IdList (IdList)
import qualified IdList
@@ -15,6 +16,8 @@ import Types
import Control.Applicative
import qualified Control.Monad.Operational as Operational
import Control.Monad (forM, filterM)
+import Control.Monad.Reader (runReaderT)
+import qualified Control.Monad.State as State
import Control.Monad.Trans (lift)
import Data.Label.Pure ((:->))
import Data.Label.PureM (asks)
@@ -83,3 +86,12 @@ allObjects = do
fmap concat $ forM zrs $ \zr -> do
ios <- IdList.toList <$> asks (compileZoneRef zr)
return (map (\(i,o) -> ((zr,i),o)) ios)
+
+liftQuestion :: Ask a -> Engine a
+liftQuestion = lift . lift . Operational.singleton
+
+executeMagic :: Magic a -> Engine a
+executeMagic m = State.get >>= lift . lift . runReaderT m
+
+object :: ObjectRef -> World :-> Object
+object (zoneRef, i) = compileZoneRef zoneRef .^ listEl i
View
144 Engine.hs
@@ -3,30 +3,25 @@
module Engine where
import Core
+import Events
import IdList (Id)
import qualified IdList
import Labels
import Predicates
+import Types
import Utils hiding (object)
import Control.Applicative ((<$>))
import Control.Monad (forever, forM_, replicateM_, when)
-import qualified Control.Monad.Operational as Operational
-import Control.Monad.Random (RandT, StdGen)
-import Control.Monad.Reader (runReaderT)
-import Control.Monad.State (StateT)
-import qualified Control.Monad.State as State
import Control.Monad.Trans (lift)
import Control.Monad.Writer (tell, execWriterT)
-import Data.Either (partitionEithers)
import Data.Ord (comparing)
-import Data.Label.Pure (get, set, (:->))
-import Data.Label.PureM (gets, puts, (=:))
+import Data.Label.Pure (get, set)
+import Data.Label.PureM (gets, (=:))
import Data.List (sortBy)
-import Data.Maybe (catMaybes, isJust)
+import Data.Maybe (catMaybes)
import Data.Traversable (for)
-type Engine = StateT World (RandT StdGen (Operational.Program Ask))
enterPlayer :: [Card] -> Engine ()
@@ -53,9 +48,6 @@ drawOpeningHands playerIds handSize = do
else return (Just playerId)
drawOpeningHands (catMaybes mulliganingPlayers) (handSize - 1)
-liftQuestion :: Ask a -> Engine a
-liftQuestion = lift . lift . Operational.singleton
-
round :: Engine ()
round = forever $ do
players ~:* set manaPool []
@@ -72,10 +64,6 @@ nextStep = do
activeStep =: s
return s
-raise :: Event -> Engine ()
-raise _ = do
- -- TODO handle triggered abilities
- return ()
-- Execution of steps
@@ -178,74 +166,10 @@ executeStep (EndPhase CleanupStep) = do
-- TODO [514.3] handle triggers; check state-based actions; possibly offer priority
return ()
--- | Execute a one-shot effect, applying replacement effects and triggering abilities.
--- TODO Return [Event] what actually happened
-executeEffect :: OneShotEffect -> Engine ()
-executeEffect e = applyReplacementEffects e >>= mapM_ compileEffect
-
-
--- Compilation of effects
-
--- TODO Return [Event] what actually happened
-compileEffect :: OneShotEffect -> Engine ()
-compileEffect e =
- case e of
- WillMoveObject rObj rToZone obj -> moveObject rObj rToZone obj
- Will (UntapPermanent i) -> untapPermanent i
- Will (DrawCard rp) -> drawCard rp
- Will (ShuffleLibrary rPlayer) -> shuffleLibrary rPlayer
- _ -> undefined
-
-
-
-tick :: Engine Timestamp
-tick = do
- t <- gets time
- time ~: succ
- return t
-
-untapPermanent :: Id -> Engine ()
-untapPermanent i = do
- Just ts <- gets (battlefield .^ listEl i .^ tapStatus)
- case ts of
- Untapped -> return ()
- Tapped -> do
- battlefield .^ listEl i .^ tapStatus =: Just Untapped
- raise (Did (UntapPermanent i))
-
-drawCard :: PlayerRef -> Engine ()
-drawCard rp = do
- lib <- gets (players .^ listEl rp .^ library)
- case IdList.toList lib of
- [] -> do
- players .^ listEl rp .^ failedCardDraw =: True
- (ro, o) : _ -> do
- executeEffect (WillMoveObject (Library rp, ro) (Hand rp) o)
- -- TODO Only raise event if card was actually moved
- raise (Did (DrawCard rp))
-
-moveObject :: ObjectRef -> ZoneRef -> Object -> Engine ()
-moveObject (rFromZone, i) rToZone obj = do
- mObj <- IdList.removeM (compileZoneRef rFromZone) i
- case mObj of
- Nothing -> return ()
- Just _ -> do
- t <- tick
- newId <- IdList.consM (compileZoneRef rToZone) (set timestamp t obj)
- raise (DidMoveObject rFromZone (rToZone, newId))
-
-moveAllObjects :: ZoneRef -> ZoneRef -> Engine ()
-moveAllObjects rFromZone rToZone = do
- ois <- IdList.toList <$> gets (compileZoneRef rFromZone)
- forM_ ois $ \(i, o) -> moveObject (rFromZone, i) rToZone o
-
-shuffleLibrary :: PlayerRef -> Engine ()
-shuffleLibrary rPlayer = do
- let libraryLabel = players .^ listEl rPlayer .^ library
- lib <- gets libraryLabel
- lib' <- lift (IdList.shuffle lib)
- puts libraryLabel lib'
- raise (Did (ShuffleLibrary rPlayer))
+
+
+
+
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn = sortBy . comparing
@@ -359,9 +283,6 @@ resolve i = do
then moveObject (Stack, i) (Graveyard (get controller o)) o'
else moveObject (Stack, i) Battlefield o'
-object :: ObjectRef -> World :-> Object
-object (zoneRef, i) = compileZoneRef zoneRef .^ listEl i
-
collectActions :: PlayerRef -> Engine [PriorityAction]
collectActions p = do
objects <- executeMagic allObjects
@@ -383,53 +304,6 @@ executeAction ability rSource activatorId = do
SpecialAction m -> executeMagic m >>= mapM_ executeEffect
StackingAction _ -> return ()
--- [616] Interaction of Replacement and/or Prevention Effects
--- TODO Handle multiple effects (in a single event) at once, to be able to adhere
--- to APNAP order; see http://draw3cards.com/questions/9618
-applyReplacementEffects :: OneShotEffect -> Engine [OneShotEffect]
-applyReplacementEffects effect = do
- objects <- map snd <$> executeMagic allObjects
- go (concatMap (get replacementEffects) objects) effect
- where
- go :: [ReplacementEffect] -> OneShotEffect -> Engine [OneShotEffect]
- go availableEffects effectToReplace = do
- p <- affectedPlayer effectToReplace
- let (notApplicable, applicable) =
- partitionEithers $ map (\f -> maybe (Left f) (\m -> Right (f, m)) (f effectToReplace)) availableEffects
- if null applicable
- then return [effectToReplace]
- else do
- ((chosen, mReplacements), notChosen) <-
- liftQuestion (AskPickReplacementEffect p applicable)
- replacements <- executeMagic mReplacements
- -- TODO Resolve replacements in affected player APNAP order.
- fmap concat $ for replacements (go (map fst notChosen ++ notApplicable))
-
--- [616.1] The affected player chooses which replacement effect to apply first.
-affectedPlayer :: OneShotEffect -> Engine PlayerRef
-affectedPlayer e =
- case e of
- WillMoveObject o _ _ -> controllerOf o
- Will (AdjustLife p _) -> return p
- Will (DamageObject _ o _ _ _) -> controllerOf o
- Will (DamagePlayer _ p _ _ _) -> return p
- Will (ShuffleLibrary p) -> return p
- Will (DrawCard p) -> return p
- Will (DestroyPermanent i _) -> controllerOf (Battlefield, i)
- Will (TapPermanent i) -> controllerOf (Battlefield, i)
- Will (UntapPermanent i) -> controllerOf (Battlefield, i)
- Will (AddCounter o _) -> controllerOf o
- Will (RemoveCounter o _) -> controllerOf o
- Will (CreateObject o) -> return (get controller o)
- Will (AddToManaPool p _) -> return p
- Will (AttachPermanent o _ _) -> controllerOf o -- debatable
- Will (RemoveFromCombat i) -> controllerOf (Battlefield, i)
- Will (PlayLand o) -> controllerOf o
- Will (LoseGame p) -> return p
- where controllerOf o = gets (object o .^ controller)
-
-executeMagic :: Magic a -> Engine a
-executeMagic m = State.get >>= lift . lift . runReaderT m
-- | Returns player IDs in APNAP order (active player, non-active player).
apnap :: Engine [(PlayerRef, Player)]
View
135 Events.hs
@@ -0,0 +1,135 @@
+module Events where
+
+import Core
+import IdList (Id)
+import qualified IdList
+import Labels
+import Types
+
+import Control.Applicative ((<$>))
+import Control.Monad (forM_,)
+import Control.Monad.Trans (lift)
+import Data.Either (partitionEithers)
+import Data.Label.Pure (get, set)
+import Data.Label.PureM (gets, puts, (=:))
+import Data.Traversable (for)
+
+
+
+-- | Execute a one-shot effect, applying replacement effects and triggering abilities.
+-- TODO Return [Event] what actually happened
+executeEffect :: OneShotEffect -> Engine ()
+executeEffect e = applyReplacementEffects e >>= mapM_ compileEffect
+
+raise :: Event -> Engine ()
+raise _ = do
+ -- TODO handle triggered abilities
+ return ()
+
+
+-- [616] Interaction of Replacement and/or Prevention Effects
+-- TODO Handle multiple effects (in a single event) at once, to be able to adhere
+-- to APNAP order; see http://draw3cards.com/questions/9618
+applyReplacementEffects :: OneShotEffect -> Engine [OneShotEffect]
+applyReplacementEffects effect = do
+ objects <- map snd <$> executeMagic allObjects
+ go (concatMap (get replacementEffects) objects) effect
+ where
+ go :: [ReplacementEffect] -> OneShotEffect -> Engine [OneShotEffect]
+ go availableEffects effectToReplace = do
+ p <- affectedPlayer effectToReplace
+ let (notApplicable, applicable) =
+ partitionEithers $ map (\f -> maybe (Left f) (\m -> Right (f, m)) (f effectToReplace)) availableEffects
+ if null applicable
+ then return [effectToReplace]
+ else do
+ ((chosen, mReplacements), notChosen) <-
+ liftQuestion (AskPickReplacementEffect p applicable)
+ replacements <- executeMagic mReplacements
+ -- TODO Resolve replacements in affected player APNAP order.
+ fmap concat $ for replacements (go (map fst notChosen ++ notApplicable))
+
+-- [616.1] The affected player chooses which replacement effect to apply first.
+affectedPlayer :: OneShotEffect -> Engine PlayerRef
+affectedPlayer e =
+ case e of
+ WillMoveObject o _ _ -> controllerOf o
+ Will (AdjustLife p _) -> return p
+ Will (DamageObject _ o _ _ _) -> controllerOf o
+ Will (DamagePlayer _ p _ _ _) -> return p
+ Will (ShuffleLibrary p) -> return p
+ Will (DrawCard p) -> return p
+ Will (DestroyPermanent i _) -> controllerOf (Battlefield, i)
+ Will (TapPermanent i) -> controllerOf (Battlefield, i)
+ Will (UntapPermanent i) -> controllerOf (Battlefield, i)
+ Will (AddCounter o _) -> controllerOf o
+ Will (RemoveCounter o _) -> controllerOf o
+ Will (CreateObject o) -> return (get controller o)
+ Will (AddToManaPool p _) -> return p
+ Will (AttachPermanent o _ _) -> controllerOf o -- debatable
+ Will (RemoveFromCombat i) -> controllerOf (Battlefield, i)
+ Will (PlayLand o) -> controllerOf o
+ Will (LoseGame p) -> return p
+ where controllerOf o = gets (object o .^ controller)
+
+
+-- Compilation of effects
+
+-- TODO Return [Event] what actually happened
+compileEffect :: OneShotEffect -> Engine ()
+compileEffect e =
+ case e of
+ WillMoveObject rObj rToZone obj -> moveObject rObj rToZone obj
+ Will (UntapPermanent i) -> untapPermanent i
+ Will (DrawCard rp) -> drawCard rp
+ Will (ShuffleLibrary rPlayer) -> shuffleLibrary rPlayer
+ _ -> undefined
+
+untapPermanent :: Id -> Engine ()
+untapPermanent i = do
+ Just ts <- gets (battlefield .^ listEl i .^ tapStatus)
+ case ts of
+ Untapped -> return ()
+ Tapped -> do
+ battlefield .^ listEl i .^ tapStatus =: Just Untapped
+ raise (Did (UntapPermanent i))
+
+drawCard :: PlayerRef -> Engine ()
+drawCard rp = do
+ lib <- gets (players .^ listEl rp .^ library)
+ case IdList.toList lib of
+ [] -> do
+ players .^ listEl rp .^ failedCardDraw =: True
+ (ro, o) : _ -> do
+ executeEffect (WillMoveObject (Library rp, ro) (Hand rp) o)
+ -- TODO Only raise event if card was actually moved
+ raise (Did (DrawCard rp))
+
+moveObject :: ObjectRef -> ZoneRef -> Object -> Engine ()
+moveObject (rFromZone, i) rToZone obj = do
+ mObj <- IdList.removeM (compileZoneRef rFromZone) i
+ case mObj of
+ Nothing -> return ()
+ Just _ -> do
+ t <- tick
+ newId <- IdList.consM (compileZoneRef rToZone) (set timestamp t obj)
+ raise (DidMoveObject rFromZone (rToZone, newId))
+
+moveAllObjects :: ZoneRef -> ZoneRef -> Engine ()
+moveAllObjects rFromZone rToZone = do
+ ois <- IdList.toList <$> gets (compileZoneRef rFromZone)
+ forM_ ois $ \(i, o) -> moveObject (rFromZone, i) rToZone o
+
+shuffleLibrary :: PlayerRef -> Engine ()
+shuffleLibrary rPlayer = do
+ let libraryLabel = players .^ listEl rPlayer .^ library
+ lib <- gets libraryLabel
+ lib' <- lift (IdList.shuffle lib)
+ puts libraryLabel lib'
+ raise (Did (ShuffleLibrary rPlayer))
+
+tick :: Engine Timestamp
+tick = do
+ t <- gets time
+ time ~: succ
+ return t
View
1  M12.hs
@@ -3,6 +3,7 @@
module M12 where
import Core
+import Types
import Utils
import Control.Applicative
View
2  Magic.cabal
@@ -12,6 +12,6 @@ build-type: Simple
cabal-version: >=1.8
library
- exposed-modules: BasicLands, Core, Engine, IdList, Labels, M12, Predicates, TargetList, Types, Utils
+ exposed-modules: BasicLands, Core, Engine, Events, IdList, Labels, M12, Predicates, TargetList, Types, Utils
-- other-modules:
build-depends: base ==4.5.*, fclabels ==1.1.*, operational ==0.2.*, mtl ==2.1.*, MonadRandom ==0.1.*, random-shuffle ==0.0.*, containers ==0.4.*, text ==0.11.*
View
8 Types.hs
@@ -58,7 +58,7 @@ module Types (
Target(..), TargetList(..),
-- * Monads
- ViewT, View, Magic,
+ ViewT, View, Magic, Engine,
view,
Ask(..)
) where
@@ -66,8 +66,10 @@ module Types (
import IdList (Id, IdList)
import Control.Applicative
-import Control.Monad.Reader
import Control.Monad.Identity
+import Control.Monad.Random (RandT, StdGen)
+import Control.Monad.Reader
+import Control.Monad.State (StateT)
import qualified Control.Monad.Operational as Operational
import Data.Label (mkLabels)
import Data.Monoid
@@ -461,6 +463,8 @@ type View = ViewT Identity
type Magic = ViewT (Operational.Program Ask)
+type Engine = StateT World (RandT StdGen (Operational.Program Ask))
+
data Ask a where
AskKeepHand :: PlayerRef -> Ask Bool
AskPriorityAction :: PlayerRef -> [PriorityAction] -> Ask (Maybe PriorityAction)
Please sign in to comment.
Something went wrong with that request. Please try again.