First draft of turn structure

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 ()

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

Types.hs

@@ -14,44 +14,36 @@ 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])]
   }
 
 
 -- Steps and phases
 
 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)