Permalink
Browse files

Adds improved "AbstractLocation" model for locations, network of cybo…

…rg planets.
  • Loading branch information...
1 parent 413fd12 commit 2d235a18bb3f74d2990462fc02ee8d03ec3e28b6 @clanehin committed May 27, 2011
@@ -63,7 +63,7 @@ startingEquipmentBySpecies Myrmidon = [sphere Krypton]
startingEquipmentBySpecies Perennial = [sphere Wood]
startingEquipmentBySpecies Recreant = [sphere Malignite]
startingEquipmentBySpecies Reptilian = [sphere Oxygen]
-startingEquipmentBySpecies DustVortex = []
+startingEquipmentBySpecies DustVortex = [sphere Aluminum, sphere Nitrogen]
dbCreateStartingPlane :: Creature -> DB PlaneRef
dbCreateStartingPlane creature =
@@ -82,12 +82,14 @@ dbBeginGame creature character_class =
plane_ref <- dbCreateStartingPlane creature
landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
creature_ref <- dbAddCreature first_level_creature (Standing plane_ref landing_site Here)
- _ <- createTown plane_ref [Portal,Node Monolith]
+ _ <- createTown plane_ref [Stargate Portal,Node Monolith]
let starting_equip = startingEquipmentBySpecies (creature_species creature) ++ startingEquipmentByClass character_class
forM_ starting_equip $ \tool -> dbAddTool tool (Inventory creature_ref)
forM_ [0..10] $ \_ -> do tool_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref
tool_type <- weightedPickM [(8,phase_pistol),(5,phaser),(3,phase_rifle),(8,kinetic_fleuret),(3,kinetic_sabre),
(5,Sphere $ toSubstance Nitrogen),(5,Sphere $ toSubstance Ionidium),(5,Sphere $ toSubstance Aluminum)]
dbAddTool tool_type (Dropped plane_ref tool_position)
- _ <- makePlanets (Subsequent plane_ref) =<< generatePlanetInfo all_planets
+ (_,end_of_nonaligned_first_series) <- makePlanets (Subsequent plane_ref Portal) =<< generatePlanetInfo nonaligned_first_series_planets
+ _ <- makePlanets (Subsequent end_of_nonaligned_first_series Portal) =<< generatePlanetInfo nonaligned_second_series_planets
+ _ <- makePlanets (Subsequent end_of_nonaligned_first_series CyberGate) =<< generatePlanetInfo cyborg_planets
setPlayerState $ PlayerCreatureTurn creature_ref NormalMode
@@ -46,7 +46,7 @@ activateBuilding :: BuildingType -> CreatureRef -> BuildingRef -> DB Bool
activateBuilding (Node n) creature_ref building_ref =
do captureNode n creature_ref building_ref
return True
-activateBuilding Portal creature_ref building_ref =
+activateBuilding (Stargate Portal) creature_ref building_ref =
do m_creature_position :: Maybe (PlaneRef,Position) <- liftM extractParent $ dbWhere creature_ref
m_portal_position :: Maybe (PlaneRef,Position) <- liftM extractParent $ dbWhere building_ref
when (fmap fst m_creature_position /= fmap fst m_portal_position) $ throwError $ DBError "activateBuilding: creature and portal on different planes"
@@ -56,16 +56,16 @@ activateBuilding Portal creature_ref building_ref =
() | cy < py ->
do m_subsequent_loc :: Maybe (Location PlaneRef Subsequent) <- liftM listToMaybe $ dbGetContents plane_ref
case m_subsequent_loc of
- Just loc -> (portalCreatureTo Portal 1 creature_ref $ child loc) >> return True
+ Just loc -> (portalCreatureTo (Stargate Portal) 1 creature_ref $ child loc) >> return True
_ -> throwError $ DBErrorFlag NoStargateAddress
() | cy > py ->
do m_previous_loc :: Maybe Subsequent <- liftM extractParent $ dbWhere plane_ref
case m_previous_loc of
- Just loc -> (portalCreatureTo Portal (-1) creature_ref $ subsequent_to loc) >> return True
+ Just loc -> (portalCreatureTo (Stargate Portal) (-1) creature_ref $ subsequent_to loc) >> return True
_ -> throwError $ DBErrorFlag NoStargateAddress
() | otherwise -> throwError $ DBErrorFlag BuildingApproachWrongAngle
_ -> throwError $ DBError "activateBuilding: can't decode building-creature relative positions"
-activateBuilding CyberGate creature_ref building_ref =
+activateBuilding (Stargate CyberGate) creature_ref building_ref =
do m_creature_position :: Maybe (PlaneRef,Position) <- liftM extractParent $ dbWhere creature_ref
m_portal_position :: Maybe (PlaneRef,Position) <- liftM extractParent $ dbWhere building_ref
when (fmap fst m_creature_position /= fmap fst m_portal_position) $ throwError $ DBError "activateBuilding: creature and portal on different planes"
@@ -3,26 +3,34 @@ module BuildingData
(Building(..),
BuildingType(..),
NodeType(..),
+ StargateType(..),
all_nodes,
+ all_stargates,
showBuilding,
buildingOccupies)
where
data Building = Building
deriving (Read,Show)
-data BuildingType = Node NodeType | Portal | CyberGate
+data BuildingType = Node NodeType | Stargate StargateType
deriving (Eq,Ord,Read,Show)
data NodeType = Monolith | Anchor
deriving (Eq,Ord,Read,Show,Enum,Bounded)
+data StargateType = Portal | CyberGate
+ deriving (Eq,Ord,Read,Show,Enum,Bounded)
+
all_nodes :: [NodeType]
all_nodes = [minBound..maxBound]
+all_stargates :: [StargateType]
+all_stargates = [minBound..maxBound]
+
showBuilding :: BuildingType -> String
showBuilding (Node n) = show n
-showBuilding x = show x
+showBuilding (Stargate s) = show s
-- | Get a list of squares, relative to the center of the building (0,0),
-- that a building occupies. These squares must be free of unfriendly terrain
@@ -34,10 +42,10 @@ buildingOccupies :: BuildingType -> [(Integer,Integer)]
-- Monolith: X
buildingOccupies (Node _) = [(0,0)]
-- Portal: XXX
-buildingOccupies Portal = [(0,0),(-1,0),(1,0)]
+buildingOccupies (Stargate Portal) = [(0,0),(-1,0),(1,0)]
-- Cybergate: XXX
-- XX XX
-- XX XX
-- X X
-buildingOccupies CyberGate = [(-3,-3),(-3,-2),(-2,-2),(-2,-1),(-1,-1),(-1,0),(0,0),(1,-1),(1,0),(2,-2),(2,-1),(3,-3),(3,-2)]
+buildingOccupies (Stargate CyberGate) = [(-3,-3),(-3,-2),(-2,-2),(-2,-1),(-1,-1),(-1,0),(0,0),(1,-1),(1,0),(2,-2),(2,-1),(3,-3),(3,-2)]
@@ -9,6 +9,7 @@ module Contact
import Position
import Facing
import DB
+import Reference
import CreatureData
import Control.Monad
import Plane
View
@@ -3,7 +3,8 @@
FlexibleContexts,
Rank2Types,
RelaxedPolyRec,
- ScopedTypeVariables #-}
+ ScopedTypeVariables,
+ TypeFamilies #-}
module DB
(DBResult,
@@ -38,6 +39,7 @@ module DB
dbVerify,
dbGetAncestors,
dbWhere,
+ whereIs,
dbGetContents,
dbSetStartingSpecies,
dbGetStartingSpecies,
@@ -58,6 +60,8 @@ module DB
import DBPrivate
import DBData
+import Location
+import Reference
import CreatureData
import PlaneData
import BuildingData
@@ -457,36 +461,55 @@ dbModBuilding = dbModObjectComposable dbGetBuilding dbPutBuilding
-- This is where we handle making sure that a creature can only wield one tool,
-- and a Plane can point to only one subsequent Plane.
--
+-- DEPRECATED: use setLocation
+-- This function is a monster.
+--
dbSetLocation :: (LocationChild c,LocationParent p) => Location c p -> DB ()
dbSetLocation loc =
do logDB log_database DEBUG $ "setting location: " ++ show loc
case (fmap parent $ coerceParentTyped _wielded loc,
fmap parent $ coerceParentTyped _subsequent loc,
fmap parent $ coerceParentTyped _beneath loc) of
(Just (Wielded c),_,_) -> dbUnwieldCreature c
- (_,Just (Subsequent s),_) -> shuntPlane _subsequent s
- (_,_,Just (Beneath b)) -> shuntPlane _beneath b
+ (_,Just (Subsequent s v),_) -> shuntPlane (\subseq -> subsequent_via subseq == v) s
+ (_,_,Just (Beneath b)) -> shuntPlane (\(Beneath {}) -> True) b
(_,_,_) -> return ()
modify (\db -> db { db_hierarchy = HD.insert (unsafeLocation loc) $ db_hierarchy db })
+setLocation :: Location () () -> DB ()
+setLocation loc =
+ do logDB log_database DEBUG $ "setting location: " ++ show loc
+ case loc of
+ IsWielded _ (Wielded c) -> dbUnwieldCreature c
+ IsSubsequent _ (Subsequent s v) -> shuntPlane (\subseq -> subsequent_via subseq == v) s
+ IsBeneath _ (Beneath b) -> shuntPlane (\(Beneath {}) -> True) b
+ _ -> return ()
+ modify (\db -> db { db_hierarchy = HD.insert (unsafeLocation loc) $ db_hierarchy db })
+
-- |
--- Shunt any wielded objects into inventory.
+-- Bump any existing child Plane in a matching to TheUniverse
--
-dbUnwieldCreature :: CreatureRef -> DB ()
-dbUnwieldCreature c = mapM_ (dbSetLocation . returnToInventory) =<<
- dbGetContents c
+shuntPlane :: (LocationView a,LocationProvides a (Child Plane) ~ Provided) => (a -> Bool) -> PlaneRef -> DB ()
+shuntPlane f p =
+ do locations <- liftM (filterLocation f) $ DB.getContents p
+ forM_ locations $ \l ->
+ do (_ :: AbstractLocation (Child Plane),
+ _ :: AbstractLocation (Parent TheUniverse)) <-
+ moveTo (fromChild $ Location.fromLocation l :: PlaneRef) TheUniverse
+ return ()
-- |
--- Shunt a subordinate plane in the specified position to TheUniverse.
+-- Shunt any wielded objects into inventory.
--
-shuntPlane :: (LocationParent p) => Type p -> PlaneRef -> DB ()
-shuntPlane t p = mapM_ (dbSetLocation . shuntToTheUniverse t) =<<
- dbGetContents p
+dbUnwieldCreature :: CreatureRef -> DB ()
+dbUnwieldCreature c = mapM_ (dbSetLocation . returnToInventory) =<< dbGetContents c
-- |
-- Moves an object, returning the location of the object before and after
-- the move.
--
+-- Deprecated: new code should use 'moveTo'.
+--
dbMove :: (ReferenceType e, LocationChild (Reference e),LocationParent b) =>
(forall m. DBReadable m => Location (Reference e) () ->
m (Location (Reference e) b)) ->
@@ -499,6 +522,25 @@ dbMove moveF ref =
when (genericParent old =/= genericParent new) $ -- an entity arriving in a new container shouldn't act before, nor be suspended beyond, the next action of the container
dbSetTimeCoordinate ref =<< dbGetTimeCoordinate (genericParent new)
return (unsafeLocation old, unsafeLocation new)
+
+-- |
+-- Moves an object, returning the location of the object before and after
+-- the move.
+--
+moveTo :: (Motion m,
+ LocationView (Child e),
+ LocationView to,
+ LocationProvides (Child e) (MoveFrom m) ~ Provided,
+ LocationProvides (MoveTo m) to ~ Provided,
+ ReferenceType e) =>
+ Reference e -> m -> DB (AbstractLocation (Child e), AbstractLocation to)
+moveTo ref motion =
+ do old <- whereIs ref
+ let new = moveLocation motion $ coerceLocation old
+ setLocation $ (Location.fromLocation new :: Location () ())
+ when (((fromParent $ Location.fromLocation old) :: Reference ()) == (fromParent $ Location.fromLocation new)) $
+ dbSetTimeCoordinate ref =<< dbGetTimeCoordinate (fromParent $ Location.fromLocation new :: Reference ())
+ return (coerceLocation old,coerceLocation new)
dbMoveAllWithin :: (forall m. DBReadable m =>
Location (Reference ()) (Reference e) ->
@@ -520,6 +562,11 @@ dbWhere :: (DBReadable db) => Reference e -> db (Location (Reference e) ())
dbWhere item = asks (unsafeLocation . fromMaybe (error "dbWhere: has no location") .
HD.lookupParent (toUID item) . db_hierarchy)
+whereIs :: (DBReadable db, ReferenceType e, LocationView (Child e)) => Reference e -> db (AbstractLocation (Child e))
+whereIs item =
+ do location <- asks (fromMaybe (error "whereIs: has no location") . HD.lookupParent (toUID item) . db_hierarchy)
+ return $ fromMaybe (error "whereIs: location type violate") $ filterLocation (const True) $ Just $ abstractLocation location
+
-- |
-- Returns all ancestor Locations of this element starting with the location
-- of the element and ending with theUniverse.
@@ -535,10 +582,16 @@ dbGetAncestors ref =
-- Returns the location records of this object.
--
dbGetContents :: (DBReadable db,GenericReference a) => Reference t -> db [a]
-dbGetContents item = asks (Data.Maybe.mapMaybe fromLocation . HD.lookupChildren
+dbGetContents item = asks (Data.Maybe.mapMaybe DBData.fromLocation . HD.lookupChildren
(toUID item) . db_hierarchy)
-- |
+-- Returns locations of all children of a reference.
+--
+getContents :: (LocationView (Parent t), DBReadable db) => Reference t -> db [AbstractLocation (Parent t)]
+getContents item = asks (filterLocation (const True) . List.map abstractLocation . HD.lookupChildren (toUID item) . db_hierarchy)
+
+-- |
-- Gets the time of an object.
--
dbGetTimeCoordinate :: (DBReadable db,ReferenceType a) => Reference a -> db TimeCoordinate
@@ -13,9 +13,7 @@ module DBData
BuildingRef,
TheUniverse(..),
the_universe,
- (=:=), (=/=),
GenericReference(..),
- ReferenceType(..),
LocationChild(..),
LocationParent(..),
Location,
@@ -79,6 +77,7 @@ import BuildingData
import Data.Maybe
import Control.Monad
import Position
+import Reference
--
-- Type Instances
@@ -156,15 +155,6 @@ instance (LocationChild c,LocationParent p) => GenericReference (Location c p) w
generalizeReference = genericChild
--
--- Reference Equality
---
-(=:=) :: (GenericReference a,GenericReference b) => a -> b -> Bool
-a =:= b = generalizeReference a == generalizeReference b
-
-(=/=) :: (GenericReference a,GenericReference b) => a -> b -> Bool
-a =/= b = not $ a =:= b
-
---
-- References
--
@@ -177,32 +167,6 @@ coerceReferenceTyped = const coerceReference
isReferenceTyped :: (ReferenceType a) => Type (Reference a) -> Reference x -> Bool
isReferenceTyped a = isJust . coerceReferenceTyped a
-class ReferenceType a where
- coerceReference :: Reference x -> Maybe (Reference a)
-
-instance ReferenceType () where
- coerceReference = Just . unsafeReference
-
-instance ReferenceType Plane where
- coerceReference (PlaneRef ref) = Just $ PlaneRef ref
- coerceReference _ = Nothing
-
-instance ReferenceType Tool where
- coerceReference (ToolRef ref) = Just $ ToolRef ref
- coerceReference _ = Nothing
-
-instance ReferenceType Creature where
- coerceReference (CreatureRef ref) = Just $ CreatureRef ref
- coerceReference _ = Nothing
-
-instance ReferenceType Building where
- coerceReference (BuildingRef ref) = Just $ BuildingRef ref
- coerceReference _ = Nothing
-
-instance ReferenceType TheUniverse where
- coerceReference UniverseRef = Just UniverseRef
- coerceReference _ = Nothing
-
--
-- Locations
--
@@ -113,7 +113,8 @@ data Wielded =
-- The location of a Plane linked to from another Plane, such as with a Stargate.
--
data Subsequent =
- Subsequent { subsequent_to :: PlaneRef }
+ Subsequent { subsequent_to :: PlaneRef,
+ subsequent_via :: StargateType }
deriving (Read,Show,Eq,Ord)
-- |
@@ -130,7 +131,7 @@ data Beneath =
--
-- p represents the type of the parent location, such as Standing or Dropped.
--
-data Location e t =
+data Location c p =
IsStanding CreatureRef Standing
| IsDropped ToolRef Dropped
| InInventory ToolRef Inventory
Oops, something went wrong.

0 comments on commit 2d235a1

Please sign in to comment.