Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

First draft of turn structure

  • Loading branch information...
commit 6455cd7a25d52eacab48b683d937075bdcc577cc 1 parent 808db2a
@MedeaMelana authored
Showing with 190 additions and 36 deletions.
  1. +164 −0 Engine.hs
  2. +11 −16 Labels.hs
  3. +15 −20 Types.hs
View
164 Engine.hs
@@ -0,0 +1,164 @@
+{-# LANGUAGE TypeOperators #-}
+
+module Engine where
+
+import Labels
+import Predicates
+import Types
+
+import Control.Applicative ((<$>))
+import Control.Monad (forever)
+import Control.Monad.State (StateT)
+import Control.Monad.Operational
+import Data.Boolean
+import Data.Ord (comparing)
+import qualified Data.IntMap as IntMap
+import Data.Label.Pure
+import Data.Label.PureM
+import Data.List (sortBy)
+import Data.Traversable (for)
+
+type Engine = StateT World (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
+ ros <- filter ((isControlledBy rp &&* isInZone Battlefield) . snd) . IntMap.toList <$> gets objects
+ _ <- for ros $ \(ro, _) -> executeEffect (UntapPermanent ro)
+ 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) =
+ objects .^ ref ro .^ tapStatus =: Just Untapped
+compileEffect (DrawCard rp) = do
+ library <- getLibrary rp
+ case library of
+ [] -> players .^ ref rp .^ failedCardDraw =: True
+ (ro, _) : _ -> executeEffect (MoveObject ro Library Hand)
+compileEffect _ = undefined
+
+getLibrary :: Ref Player -> Engine [WithRef Object]
+getLibrary rp = sortOn (get timestamp . snd) . filter ((isOwnedBy rp &&* isInZone Library) . snd) <$> list objects
+
+list :: (World :-> RefMap a) -> Engine [WithRef a]
+list collection = IntMap.toList <$> gets collection
+
+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 ()
View
27 Labels.hs
@@ -2,29 +2,24 @@
module Labels where
-import Prelude hiding ((.), id)
+import Types
-import Control.Arrow (ArrowZero(..), ArrowChoice(..), arr, returnA)
+import Prelude hiding ((.), id)
import Control.Category (Category(..), (>>>))
-import Control.Monad (MonadPlus)
import Control.Monad.State (MonadState)
-
-import Data.Label (Lens(..))
-import Data.Label.Abstract (lens)
-import Data.Label.Maybe ((:~>))
-import Data.Label.MaybeM (modify)
-import Data.IntMap (IntMap, Key)
+import Data.Label.Pure ((:->), lens)
+import Data.Label.PureM
import qualified Data.IntMap as IntMap
-ref :: (ArrowZero (~>), ArrowChoice (~>)) => Key -> Lens (~>) (IntMap a) a
-ref key = lens ((zeroArrow ||| returnA) . arr g) (arr s)
- where
- g im = maybe (Left ()) Right (IntMap.lookup key im)
- s (el, im) = IntMap.insert key el im
+ref :: Ref a -> RefMap a :-> a
+ref key = lens (IntMap.! key) (IntMap.insert key)
(.^) :: Category (~>) => a ~> b -> b ~> c -> a ~> c
(.^) = (>>>)
-(.~) :: (MonadState f m, MonadPlus m) => (f :~> a) -> (a -> a) -> m ()
-(.~) = modify
+(~:) :: MonadState s m => (s :-> a) -> (a -> a) -> m ()
+(~:) = modify
+
+(~:*) :: (Functor f, MonadState s m) => (s :-> f a) -> (a -> a) -> m ()
+l ~:* f = l ~: fmap f
View
35 Types.hs
@@ -14,34 +14,27 @@ import Control.Monad.Identity
import Control.Monad.Operational
import Data.Label (mkLabels)
import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
import Data.Monoid
import Data.Set (Set)
-import qualified Data.Set as Set
import Data.Text (Text)
type Bag = []
-newtype Ref a = Ref Int deriving (Eq, Show, Read)
+type Ref a = Int
type RefMap = IntMap
type RefSet a = Set (Ref a)
type WithRef a = (Ref a, a)
-(!) :: IntMap a -> Ref a -> a
-m ! Ref k = m IntMap.! k
-
-- | Current game situation.
data World = World
- { _objects :: RefMap Object
- , _players :: RefMap Player
- , _activePlayer :: Ref Player
- , _priority :: Ref Player
- , _activeStep :: Step
- --, _prestack :: [Special StackedEffect]
- --, _stack :: [StackedEffect]
- , _time :: Timestamp
+ { _objects :: RefMap Object
+ , _players :: RefMap Player
+ , _activePlayer :: Ref Player
+ , _activeStep :: Step
+ , _time :: Timestamp
+ , _turnStructure :: [(Ref Player, [Step])]
}
@@ -49,9 +42,8 @@ data World = World
data Step
= BeginningPhase BeginningStep
- | PrecombatMainPhase
+ | MainPhase
| CombatPhase CombatStep
- | PostcombatMainPhase
| EndPhase EndStep
deriving (Eq, Ord, Show, Read)
@@ -75,9 +67,12 @@ data EndStep
deriving (Eq, Ord, Show, Read, Enum, Bounded)
data Player = Player
- { _life :: Int
- , _manaPool :: Bag (Maybe Color)
- } deriving (Eq, Ord, Show)
+ { _life :: Int
+ , _manaPool :: Bag (Maybe Color)
+ , _prestack :: [Magic StackItem]
+ , _maximumHandSize :: Maybe Int
+ , _failedCardDraw :: Bool -- [704.5b]
+ }
-- Objects
@@ -294,7 +289,7 @@ data OneShotEffect
| DamagePlayer (Ref Object) (Ref Player) Int Bool Bool -- source, player, amount, combat damage?, preventable?
| ShuffleLibrary
-- | ReorderLibraryCards
- | DrawCard -- Drawing is special [120.5]
+ | DrawCard (Ref Player) -- Drawing is special [120.5]
| DestroyPermanent (Ref Object) Bool -- target, preventable? -- Destruction is special [701.6b]
| MoveObject (Ref Object) Zone Zone
| TapPermanent (Ref Object)
Please sign in to comment.
Something went wrong with that request. Please try again.