Permalink
Browse files

Restructured object types

  • Loading branch information...
1 parent 120d53f commit 397c10b7a84c5f64c5e5468811eaf249d8f404c7 @MedeaMelana committed Aug 31, 2012
Showing with 79 additions and 36 deletions.
  1. +3 −9 BasicLands.hs
  2. +31 −15 Types.hs
  3. +45 −12 Utils.hs
View
@@ -2,8 +2,9 @@
module BasicLands where
-import Types
import Predicates
+import Types
+import Utils
import Control.Applicative
import Data.Boolean
@@ -25,14 +26,7 @@ mkBasicLandCard ty color = Card $ \ts rOwner ->
Object
{ _name = Just (fromString (show ty))
, _colors = mempty
- , _group = Permanent
- { _supertypes = Set.singleton Basic
- , _artifactTypes = Nothing
- , _creatureTypes = Nothing
- , _enchantmentTypes = Nothing
- , _landTypes = Just (Set.singleton ty)
- , _planeswalkerTypes = Nothing
- }
+ , _types = basicType <> objectType ty
, _zone = Library
, _owner = rOwner
, _controller = rOwner
View
@@ -17,6 +17,7 @@ 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)
@@ -89,7 +90,7 @@ data Card = Card
data Object = Object
{ _name :: Maybe Text
, _colors :: Set Color
- , _group :: Group
+ , _types :: ObjectTypes
, _zone :: Zone
, _owner :: Ref Player
, _controller :: Ref Player
@@ -134,20 +135,32 @@ data CounterType
= Charge | Plus1Plus1 | Minus1Minus1 | Poison | Hatchling | Loyalty
deriving (Eq, Ord, Show, Read, Enum, Bounded)
-data Group
- = Spell { _spellType :: SpellType }
- | Permanent
- { _supertypes :: Set Supertype
- , _artifactTypes :: Maybe (Set ArtifactType)
- , _creatureTypes :: Maybe (Set CreatureType)
- , _enchantmentTypes :: Maybe (Set EnchantmentType)
- , _landTypes :: Maybe (Set LandType)
- , _planeswalkerTypes :: Maybe (Set PlaneswalkerType)
- }
- deriving (Eq, Ord, Show)
-data SpellType = Instant | Sorcery
- deriving (Eq, Ord, Show, Read, Enum, Bounded)
+-- Object types
+
+data ObjectTypes = ObjectTypes
+ { _supertypes :: Set Supertype
+ , _artifactTypes :: Maybe (Set ArtifactType)
+ , _creatureTypes :: Maybe (Set CreatureType)
+ , _enchantmentTypes :: Maybe (Set EnchantmentType)
+ , _instantTypes :: Maybe (Set SpellType)
+ , _landTypes :: Maybe (Set LandType)
+ , _planeswalkerTypes :: Maybe (Set PlaneswalkerType)
+ , _sorceryTypes :: Maybe (Set SpellType)
+ } deriving (Eq, Ord, Show)
+
+instance Monoid ObjectTypes where
+ mempty = ObjectTypes mempty mempty mempty mempty mempty mempty mempty mempty
+ x `mappend` y = ObjectTypes
+ { _supertypes = _supertypes x `mappend` _supertypes y
+ , _artifactTypes = _artifactTypes x `mappend` _artifactTypes y
+ , _creatureTypes = _creatureTypes x `mappend` _creatureTypes y
+ , _enchantmentTypes = _enchantmentTypes x `mappend` _enchantmentTypes y
+ , _instantTypes = _instantTypes x `mappend` _instantTypes y
+ , _landTypes = _landTypes x `mappend` _landTypes y
+ , _planeswalkerTypes = _planeswalkerTypes x `mappend` _planeswalkerTypes y
+ , _sorceryTypes = _sorceryTypes x `mappend` _sorceryTypes y
+ }
data Supertype = Basic | Legendary
deriving (Eq, Ord, Show, Read, Enum, Bounded)
@@ -174,6 +187,9 @@ data CreatureType
data EnchantmentType = Aura | Curse
deriving (Eq, Ord, Show, Read, Enum, Bounded)
+data SpellType = Arcane | Trap
+ deriving (Eq, Ord, Show, Read, Enum, Bounded)
+
data LandType = Plains | Island | Swamp | Mountain | Forest | Locus
deriving (Eq, Ord, Show, Read, Enum, Bounded)
@@ -364,4 +380,4 @@ type Magic = ViewT (Program Ask)
data Ask a where
Ask :: Ref Player -> [Choice] -> Ask Choice
-$(mkLabels [''World, ''Player, ''Object, ''Zone, ''Group, ''Action])
+$(mkLabels [''World, ''Player, ''Object, ''Zone, ''ObjectTypes, ''Action])
View
@@ -3,19 +3,52 @@
module Utils where
import Types
-import Labels
-import Data.Label.MaybeM
-import Data.Label.Maybe ((:~>))
+import Data.Label.Pure
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as Set
-object :: Ref Object -> World :~> Object
-object r = objects .^ ref r
-player :: Ref Player -> World :~> Player
-player r = players .^ ref r
+basicType :: ObjectTypes
+basicType = mempty { _supertypes = Set.singleton Basic }
-stamp :: Magic Timestamp
-stamp = do
- t <- gets time
- time .~ (+ 1)
- return t
+legendaryType :: ObjectTypes
+legendaryType = mempty { _supertypes = Set.singleton Legendary }
+
+artifactType :: ObjectTypes
+artifactType = mempty { _artifactTypes = Just mempty }
+
+enchantmentType :: ObjectTypes
+enchantmentType = mempty { _enchantmentTypes = Just mempty }
+
+instantType :: ObjectTypes
+instantType = mempty { _instantTypes = Just mempty }
+
+landType :: ObjectTypes
+landType = mempty { _landTypes = Just mempty }
+
+sorceryType :: ObjectTypes
+sorceryType = mempty { _sorceryTypes = Just mempty }
+
+
+class ObjectType a where
+ objectTypeLabel :: ObjectTypes :-> Maybe (Set a)
+
+instance ObjectType ArtifactType where
+ objectTypeLabel = artifactTypes
+
+instance ObjectType CreatureType where
+ objectTypeLabel = creatureTypes
+
+instance ObjectType EnchantmentType where
+ objectTypeLabel = enchantmentTypes
+
+instance ObjectType LandType where
+ objectTypeLabel = landTypes
+
+instance ObjectType PlaneswalkerType where
+ objectTypeLabel = planeswalkerTypes
+
+objectType :: ObjectType a => a -> ObjectTypes
+objectType ty = set objectTypeLabel (Just (Set.singleton ty)) mempty

0 comments on commit 397c10b

Please sign in to comment.