Permalink
Browse files

Add some missing files and minor fixes.

  • Loading branch information...
clanehin committed Apr 28, 2012
1 parent 706f798 commit cd8b3fc6220b9d4033c0041d94544500f321e28f
@@ -0,0 +1,121 @@
+{-# LANGUAGE TypeFamilies, EmptyDataDecls, ScopedTypeVariables, PatternGuards, FlexibleContexts #-}
+
+module DetailedLocation
+ (DetailedLocation,
+ PlaneLocation,
+ BuildingLocation,
+ ToolLocation,
+ CarriedLocation,
+ PlanarLocation,
+ filterLocations,
+ mapLocations,
+ asChildren,
+ identityDetail,
+ detail,
+ Planar(..),
+ LocationAssignmentTable)
+ where
+
+import DBData
+import PlaneData
+import BuildingData
+import ToolData
+import CreatureData
+import Position
+import Data.Maybe
+import Control.Monad
+import Reference
+import Facing
+
+type PlaneLocation = DetailedLocation (Child Plane)
+type BuildingLocation = DetailedLocation (Child Building)
+type CreatureLocation = DetailedLocation (Child Creature)
+type ToolLocation = DetailedLocation (Child Tool)
+type CarriedLocation = DetailedLocation (Parent Creature)
+type PlanarLocation = DetailedLocation Planar
+
+data DetailedLocation a = DetailedLocation { dl_location :: Location }
+
+instance LocationSource (DetailedLocation a) where
+ toLocation = dl_location
+
+instance (LocationDetail a) => LocationDetail (DetailedLocation a) where
+ fromLocation source =
+ do (_ :: a) <- fromLocation source
+ return $ DetailedLocation source
+
+filterLocations :: (LocationSource l, LocationDetail a) => (a -> Bool) -> [l] -> [DetailedLocation a]
+filterLocations f = map DetailedLocation . filter (maybe False f . fromLocation) . map toLocation
+
+mapLocations :: (LocationSource l, LocationDetail a) => [l] -> [a]
+mapLocations = mapMaybe (fromLocation . toLocation)
+
+identityDetail :: (LocationDetail a) => DetailedLocation a -> a
+identityDetail = fromMaybe (error "identityDetail: impossible case: fromLocation call failed") . fromLocation . dl_location
+
+detail :: (LocationDetail to,LocationAssignmentTable from to ~ Supported) => DetailedLocation from -> to
+detail = fromMaybe (error "detail: impossible case: fromLocation call failed") . fromLocation . dl_location
+
+asChildren :: (LocationSource l,LocationDetail (Child a)) => [l] -> [Reference a]
+asChildren = map asChild . mapLocations
+
+-- | A location with a parent plane and a multiposition.
+-- That is, any physical object resting, walking, or constructed on a plane.
+-- But not a Beneath or Subsequent plane.
+data Planar = Planar {
+ planar_parent :: PlaneRef,
+ planar_position :: Position,
+ planar_multiposition :: MultiPosition }
+
+instance LocationDetail Planar where
+ fromLocation l = liftM3 Planar (liftM (\(Parent x) -> x) $ fromLocation l) (fromLocation l) (fromLocation l)
+
+instance LocationConstructor Planar where
+ type ReferenceTypeOf Planar = ()
+ constructLocation ref planar | Just creature_ref <- coerceReference ref =
+ constructLocation creature_ref $ Standing (planar_parent planar) (planar_position planar) Here
+ constructLocation ref planar | Just tool_ref <- coerceReference ref =
+ constructLocation tool_ref $ Dropped (planar_parent planar) (planar_position planar)
+ constructLocation ref planar | Just plane_ref <- coerceReference ref =
+ constructLocation plane_ref $ Beneath (planar_parent planar)
+ constructLocation ref planar | Just building_ref <- coerceReference ref =
+ constructLocation building_ref $ Constructed (planar_parent planar)
+ (planar_position planar)
+ (error "LocationConstructor Planar: constructLocation: indeterminate")
+
+-- | Meaning that an assignment from one location type to another is guaranteed to succeed.
+data Supported
+
+-- | This is not remotely a complete table, but will need to be added to on an as-needed basis.
+type family LocationAssignmentTable from to :: *
+type instance LocationAssignmentTable a (DetailedLocation b) = LocationAssignmentTable a b
+type instance LocationAssignmentTable a (Child ()) = Supported
+type instance LocationAssignmentTable a (Parent ()) = Supported
+type instance LocationAssignmentTable Planar (Parent Plane) = Supported
+type instance LocationAssignmentTable Planar MultiPosition = Supported
+type instance LocationAssignmentTable Planar Position = Supported
+type instance LocationAssignmentTable Planar (Parent Plane, MultiPosition) = Supported
+type instance LocationAssignmentTable Planar (Parent Plane, Position) = Supported
+type instance LocationAssignmentTable (Child a) (Child a) = Supported
+type instance LocationAssignmentTable (Child Creature) (Parent Plane) = Supported
+type instance LocationAssignmentTable (Child Creature) Position = Supported
+type instance LocationAssignmentTable (Child Creature) MultiPosition = Supported
+type instance LocationAssignmentTable (Child Creature) Planar = Supported
+type instance LocationAssignmentTable (Child Creature) Facing = Supported
+type instance LocationAssignmentTable (Child Creature) (Facing,Position) = Supported
+type instance LocationAssignmentTable (Child Creature) (Position,Facing) = Supported
+type instance LocationAssignmentTable (Child Building) (Parent Plane) = Supported
+type instance LocationAssignmentTable (Child Building) Position = Supported
+type instance LocationAssignmentTable (Child Building) MultiPosition = Supported
+type instance LocationAssignmentTable Beneath (Child Plane) = Supported
+type instance LocationAssignmentTable Subsequent (Child Plane) = Supported
+type instance LocationAssignmentTable Standing Planar = Supported
+type instance LocationAssignmentTable Standing (Child Creature) = Supported
+type instance LocationAssignmentTable Standing (Parent Plane) = Supported
+type instance LocationAssignmentTable Standing Position = Supported
+type instance LocationAssignmentTable Standing MultiPosition = Supported
+type instance LocationAssignmentTable Standing Facing = Supported
+type instance LocationAssignmentTable Wielded (Child Tool) = Supported
+type instance LocationAssignmentTable Dropped (Child Tool) = Supported
+type instance LocationAssignmentTable Inventory (Child Tool) = Supported
+
@@ -0,0 +1,20 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module DetailedTravel
+ (DetailedTravel.whereIs,
+ DetailedTravel.getContents)
+ where
+
+import Prelude hiding (getContents)
+import DB
+import DetailedLocation
+import Control.Monad
+import Data.Maybe
+import Reference
+
+whereIs :: (DBReadable db,ReferenceType a) => Reference a -> db (DetailedLocation (Child a))
+whereIs = liftM (fromMaybe (error "DetailedTravel.whereIs: Reference is not a child of it's own location.") . fromLocation) . DB.whereIs
+
+getContents :: (DBReadable db,ReferenceType a) => Reference a -> db [DetailedLocation (Parent a)]
+getContents = liftM mapLocations . DB.getContents
+
@@ -0,0 +1,66 @@
+module PersistantData
+ (CharacterClass(..),
+ PowerUpData(..),
+ PlanetRegion(..),
+ Building(..),
+ BuildingBehavior(..),
+ BuildingShape(..),
+ BuildingSignal(..),
+ BuildingPrototype(..))
+ where
+
+{----- CHARACTER -----}
+
+data CharacterClass = Barbarian
+ | Consular
+ | Engineer
+ | ForceAdept
+ | Marine
+ | Ninja
+ | Pirate
+ | Scout
+ | Shepherd
+ | StarChild
+ | Thief
+ | Warrior
+ deriving (Eq,Enum,Bounded,Read,Show,Ord)
+
+{----- POWER UPS -----}
+
+-- |
+-- Cause a character to advance in level or to gain a specific CharacterClass.
+data PowerUpData =
+ -- Award a character points. If the character gain enough points to advance in character class,
+ -- then do this, otherwise, he just accumulates the points.
+ AwardCharacter Integer
+ -- Apply a specific CharacterClass to a character. If he already has this CharacterClass,
+ -- then we back off and give him the points instead.
+ | ForceCharacter CharacterClass
+ deriving (Eq,Read,Show)
+
+{----- PLANETS -----}
+
+data PlanetRegion = NonAlignedRegion | CyborgRegion
+ deriving (Eq,Ord,Read,Show)
+
+{----- BUILDINGS -----}
+
+data Building = Building { building_behavior :: BuildingBehavior,
+ building_signal :: Maybe BuildingSignal }
+ deriving (Read,Show)
+
+data BuildingBehavior = PowerUp PowerUpData | TwoWayStargate PlanetRegion | OneWayStargate PlanetRegion
+ deriving (Eq,Read,Show)
+
+data BuildingShape = Monolith | Anchor | Portal | CyberGate
+ deriving (Eq,Ord,Read,Show)
+
+data BuildingSignal = Magnetic
+ deriving (Eq,Read,Show)
+
+data BuildingPrototype = BuildingPrototype { -- TODO: does this data structure really need to be persistant?
+ buildingproto_behavior :: BuildingBehavior,
+ buildingproto_shape :: BuildingShape,
+ buildingproto_signal :: Maybe BuildingSignal }
+ deriving (Eq,Read,Show)
+
@@ -207,7 +207,7 @@ setTerrainAt plane_ref (Position pos) patch = dbModPlane (\p -> p { plane_terrai
-- Typically this is zero or one creatures, and zero or more tools. Might be a building.
whatIsOccupying :: (DBReadable db) => PlaneRef -> Position -> db [PlanarLocation]
whatIsOccupying plane_ref position =
- liftM (filter ((== 0) . (distanceBetweenChessboard position :: MultiPosition -> Integer) . detail) . mapLocations) $ getContents plane_ref
+ liftM (mapLocations . filterLocations (\(x :: MultiPosition) -> distanceBetweenChessboard position x == 0)) $ getContents plane_ref
-- | Answers True iff a creature may walk or swim or drop objects at the position.
-- Lava is considered passable, but trees are not.

0 comments on commit cd8b3fc

Please sign in to comment.