Major restructuring of the location system, which doesn't seem to be utterly broken.

parent 4bf79700
......@@ -12,6 +12,8 @@ The binary packages:
And the library packages:
* rsagl (RogueStar Animation and Graphics Library)
* rsagl-math
* rsagl-frp
The library packages must be installed before the binary packages can
even be configured.
......
......@@ -23,7 +23,7 @@ executable roguestar-engine
mtl >=1.1.0.2, random >=1.0.0.2 && <1.1,
old-time >=1.0.0.3 && <1.1, array >=0.3.0.0 && <0.3.1,
containers >=0.3.0.0, base >=4 && <5
other-modules: TravelData, VisibilityData, FactionData, Behavior, Alignment, PlaneData, Grids, Perception, PlaneVisibility, Turns, Plane, CreatureData, Protocol, Character, Tool, Substances, HierarchicalDatabase, Travel, ToolData, CharacterData, Creature, Facing, DBPrivate, RNG, Species, Position, TerrainData, Combat, Tests, DBData, GridRayCaster, BeginGame, SpeciesData, TimeCoordinate, DB, AttributeGeneration, CreatureAttribute, Building, BuildingData, Town, Random, PlayerState, MakeData, DBErrorFlag, Construction, Make, Activate, Contact, DeviceActivation, WorkCluster, Planet, PlanetData, Logging, NodeData, CharacterAdvancement
other-modules: TravelData, VisibilityData, FactionData, Behavior, Alignment, PlaneData, Grids, Perception, PlaneVisibility, Turns, Plane, CreatureData, Protocol, Character, Tool, Substances, HierarchicalDatabase, Travel, ToolData, CharacterData, Creature, Facing, DBPrivate, RNG, Species, Position, TerrainData, Combat, Tests, DBData, GridRayCaster, BeginGame, SpeciesData, TimeCoordinate, DB, AttributeGeneration, CreatureAttribute, Building, BuildingData, Town, Random, PlayerState, MakeData, DBErrorFlag, Construction, Make, Activate, Contact, DeviceActivation, WorkCluster, Planet, PlanetData, Logging, PowerUpData, CharacterAdvancement, PersistantData
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
if impl(ghc >= 7.0)
......
......@@ -19,7 +19,7 @@ data ActivationOutcome =
resolveActivation :: (DBReadable db) => CreatureRef -> db ActivationOutcome
resolveActivation creature_ref =
do tool_ref <- maybe (throwError $ DBErrorFlag NoToolWielded) return =<< dbGetWielded creature_ref
do tool_ref <- maybe (throwError $ DBErrorFlag NoToolWielded) return =<< getWielded creature_ref
tool <- dbGetTool tool_ref
case tool of
DeviceTool {} -> throwError $ DBErrorFlag ToolIs_Innapropriate
......
......@@ -77,19 +77,19 @@ dbCreateStartingPlane creature =
-- The character class should not be pre-applied to the creature.
--
dbBeginGame :: Creature -> CharacterClass -> DB ()
dbBeginGame creature character_class =
dbBeginGame creature character_class =
do let first_level_creature = applyCharacterClass character_class creature
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 [Stargate Portal,Node Monolith]
_ <- createTown plane_ref [basic_stargate,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)
(_,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
(_,end_of_nonaligned_first_series) <- makePlanets (Subsequent plane_ref NonAlignedRegion) =<< generatePlanetInfo nonaligned_first_series_planets
_ <- makePlanets (Subsequent end_of_nonaligned_first_series NonAlignedRegion) =<< generatePlanetInfo nonaligned_second_series_planets
_ <- makePlanets (Subsequent end_of_nonaligned_first_series CyborgRegion) =<< generatePlanetInfo cyborg_planets
setPlayerState $ PlayerCreatureTurn creature_ref NormalMode
......@@ -6,11 +6,13 @@ module Behavior
dbBehave)
where
import Prelude hiding (getContents)
import DB
import Position
import Facing
import Data.Ratio
import Tool
import ToolData
import Control.Monad.Error
import Combat
import Activate
......@@ -26,6 +28,10 @@ import TerrainData
import Make
import Construction
import Building
import Reference
import DetailedLocation
import Plane
import PlaneData
--
-- Every possible behavior that a creature might take, AI or Human.
......@@ -55,25 +61,22 @@ data Behavior =
-- if occupied by a creature this is 'Attack'.
facingBehavior :: (DBReadable db) => CreatureRef -> Facing -> db Behavior
facingBehavior creature_ref face =
do (m_standing :: Maybe (PlaneRef,Position)) <- liftM (fmap parent) $ getPlanarPosition creature_ref
case m_standing of
Nothing -> return Wait
Just (plane_ref,pos) ->
do let facing_pos = offsetPosition (facingToRelative face) pos
t <- terrainAt plane_ref facing_pos
who :: [CreatureRef] <- whatIsOccupying plane_ref facing_pos
what :: [BuildingRef] <- whatIsOccupying plane_ref facing_pos
case t of
_ | not (null who) -> return $ Attack face
_ | not (null what) -> return $ ActivateBuilding face
Forest -> return $ ClearTerrain face
DeepForest -> return $ ClearTerrain face
RockFace -> return $ ClearTerrain face
_ -> return $ Step face
do ((Parent plane_ref,pos) :: (Parent Plane,Position)) <- liftM detail $ getPlanarLocation creature_ref
let facing_pos = offsetPosition (facingToRelative face) pos
t <- terrainAt plane_ref facing_pos
who :: [CreatureRef] <- liftM asChildren $ whatIsOccupying plane_ref facing_pos
what :: [BuildingRef] <- liftM asChildren $ whatIsOccupying plane_ref facing_pos
case t of
_ | not (null who) -> return $ Attack face
_ | not (null what) -> return $ ActivateBuilding face
Forest -> return $ ClearTerrain face
DeepForest -> return $ ClearTerrain face
RockFace -> return $ ClearTerrain face
_ -> return $ Step face
dbBehave :: Behavior -> CreatureRef -> DB ()
dbBehave (Step face) creature_ref =
do (move_from,move_to) <- dbMove (stepCreature face) creature_ref
do (move_from,move_to) <- move creature_ref =<< stepCreature face creature_ref
dbAdvanceTime creature_ref =<< case () of
() | (move_from == move_to) -> return 0
() | face == Here -> quickActionTime creature_ref -- counts as turning in place
......@@ -95,18 +98,18 @@ dbBehave (Jump face) creature_ref =
dbAdvanceTime creature_ref =<< fullActionTime creature_ref
dbBehave (TurnInPlace face) creature_ref =
do _ <- dbMove (turnCreature face) creature_ref
do _ <- move creature_ref =<< turnCreature face creature_ref
dbAdvanceTime creature_ref =<< quickActionTime creature_ref
dbBehave (Pickup tool_ref) creature_ref =
do _ <- dbMove (dbPickupTool creature_ref) tool_ref
do _ <- move tool_ref =<< pickupTool creature_ref tool_ref
dbAdvanceTime creature_ref =<< quickActionTime creature_ref
dbBehave (Wield tool_ref) creature_ref =
do available <- availableWields creature_ref
already_wielded <- dbGetWielded creature_ref
already_wielded <- getWielded creature_ref
when (not $ tool_ref `elem` available) $ throwError $ DBErrorFlag ToolIs_Unreachable
_ <- dbMove dbWieldTool tool_ref
_ <- move tool_ref =<< wieldTool tool_ref
dbAdvanceTime creature_ref =<< case () of
() | Just tool_ref == already_wielded -> return 0 -- already wielded, so this was an empty action
() | otherwise -> quickActionTime creature_ref
......@@ -116,23 +119,23 @@ dbBehave (Unwield) creature_ref =
dbAdvanceTime creature_ref =<< quickActionTime creature_ref
dbBehave (Drop tool_ref) creature_ref =
do tool_parent <- liftM extractParent $ dbWhere tool_ref
already_wielded <- dbGetWielded creature_ref
when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag ToolIs_NotInInventory
_ <- dbMove dbDropTool tool_ref
do tool_parent <- liftM parentReference $ whereIs tool_ref
already_wielded <- getWielded creature_ref
when (tool_parent =/= creature_ref) $ throwError $ DBErrorFlag ToolIs_NotInInventory
_ <- move tool_ref =<< dropTool tool_ref
dbAdvanceTime creature_ref =<< case () of
() | Just tool_ref == already_wielded -> return 0 -- instantly drop a tool if it's already held in the hand
() | otherwise -> quickActionTime creature_ref
dbBehave (Fire face) creature_ref =
do _ <- dbMove (turnCreature face) creature_ref
do _ <- move creature_ref =<< turnCreature face creature_ref
ranged_attack_model <- rangedAttackModel creature_ref
_ <- atomic executeAttack $ resolveAttack ranged_attack_model face
dbAdvanceTime creature_ref =<< quickActionTime creature_ref
return ()
dbBehave (Attack face) creature_ref =
do _ <- dbMove (turnCreature face) creature_ref
do _ <- move creature_ref =<< turnCreature face creature_ref
melee_attack_model <- meleeAttackModel creature_ref
_ <- atomic executeAttack $ resolveAttack melee_attack_model face
dbAdvanceTime creature_ref =<< move1ActionTime creature_ref
......@@ -140,16 +143,14 @@ dbBehave (Attack face) creature_ref =
dbBehave Wait creature_ref = dbAdvanceTime creature_ref =<< quickActionTime creature_ref
dbBehave Vanish creature_ref =
dbBehave Vanish creature_ref =
do dbAdvanceTime creature_ref =<< quickActionTime creature_ref
_ <- runMaybeT $
do (plane_ref :: PlaneRef) <- MaybeT $ liftM (fmap parent) $ getPlanarPosition creature_ref
lift $
do faction <- getCreatureFaction creature_ref
is_visible_to_anyone_else <- liftM (any (creature_ref `elem`)) $
mapM (\fact -> dbGetVisibleObjectsForFaction (return . const True) fact plane_ref)
({- all factions except this one: -} delete faction [minBound..maxBound])
when (not is_visible_to_anyone_else) $ deleteCreature creature_ref
(Parent plane_ref :: Parent Plane) <- liftM detail $ getPlanarLocation creature_ref
faction <- getCreatureFaction creature_ref
is_visible_to_anyone_else <- liftM (any (genericReference creature_ref `elem`)) $
mapM (\fact -> dbGetVisibleObjectsForFaction (return . const True) fact plane_ref)
({- all factions except this one: -} delete faction [minBound..maxBound])
when (not is_visible_to_anyone_else) $ deleteCreature creature_ref
return ()
dbBehave Activate creature_ref =
......@@ -163,14 +164,14 @@ dbBehave (Make make_prep) creature_ref =
return ()
dbBehave (ClearTerrain face) creature_ref =
do _ <- dbMove (turnCreature face) creature_ref
do _ <- move creature_ref =<< turnCreature face creature_ref
ok <- modifyFacingTerrain clearTerrain face creature_ref
when (not ok) $ throwError $ DBErrorFlag Unable
dbAdvanceTime creature_ref =<< fullActionTime creature_ref
return ()
dbBehave (ActivateBuilding face) creature_ref =
do _ <- dbMove (turnCreature face) creature_ref
do _ <- move creature_ref =<< turnCreature face creature_ref
ok <- activateFacingBuilding face creature_ref
when (not ok) $ throwError $ DBErrorFlag Unable
dbAdvanceTime creature_ref =<< fullActionTime creature_ref
......@@ -182,7 +183,7 @@ dbBehave (ActivateBuilding face) creature_ref =
-- | A value indicating the degree of difficulty a creature suffers on account of the inventory it is carrying.
inventoryBurden :: (DBReadable db) => CreatureRef -> db Rational
inventoryBurden creature_ref =
do inventory_size <- liftM (genericLength . map (asType _tool)) $ dbGetContents creature_ref
do inventory_size <- liftM (genericLength . filterLocations (\(Child tool_ref :: Child Tool) -> True)) $ getContents creature_ref
inventory_skill <- liftM roll_ideal $ rollCreatureAbilityScore InventorySkill 0 creature_ref
return $ (inventory_size ^ 2) % inventory_skill
......
This diff is collapsed.
module BuildingData
(Building(..),
BuildingType(..),
NodeType(..),
StargateType(..),
all_nodes,
all_stargates,
showBuilding,
BuildingBehavior(..),
BuildingShape(..),
BuildingSignal(..),
BuildingPrototype(..),
basic_stargate,
cybergate,
monolith,
powerup,
buildingOccupies)
where
data Building = Building
deriving (Read,Show)
import PowerUpData
import CharacterData
import PersistantData
data BuildingType = Node NodeType | Stargate StargateType
deriving (Eq,Ord,Read,Show)
basic_stargate :: BuildingPrototype
basic_stargate = BuildingPrototype (TwoWayStargate NonAlignedRegion) Portal (Just Magnetic)
data NodeType = Monolith | Anchor
deriving (Eq,Ord,Read,Show,Enum,Bounded)
cybergate :: BuildingPrototype
cybergate = BuildingPrototype (OneWayStargate CyborgRegion) CyberGate (Just Magnetic)
data StargateType = Portal | CyberGate
deriving (Eq,Ord,Read,Show,Enum,Bounded)
monolith :: BuildingPrototype
monolith = BuildingPrototype (PowerUp $ ForceCharacter StarChild) Monolith (Just Magnetic)
all_nodes :: [NodeType]
all_nodes = [minBound..maxBound]
all_stargates :: [StargateType]
all_stargates = [minBound..maxBound]
showBuilding :: BuildingType -> String
showBuilding (Node n) = show n
showBuilding (Stargate s) = show s
powerup :: BuildingPrototype
powerup = BuildingPrototype (PowerUp $ AwardCharacter 1) Anchor (Just Magnetic)
-- | 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
-- that a building occupies. These squares must be free of unbuildable terrain
-- (mountains, trees, water, lava, etc.) and no other objects can co-occupy these squares.
--
-- A goal is that every building type has a unique occupation signature,
-- so that it can be identified by it's shape alone.
buildingOccupies :: BuildingType -> [(Integer,Integer)]
-- Monolith: X
buildingOccupies (Node _) = [(0,0)]
-- It's also a hope that most buildings will be identifiable based on their footprint alone.
--
buildingOccupies :: BuildingShape -> [(Integer,Integer)]
-- Monolith/Node: X
buildingOccupies Monolith = [(0,0)]
buildingOccupies Anchor = [(0,0)]
-- Portal: XXX
buildingOccupies (Stargate Portal) = [(0,0),(-1,0),(1,0)]
buildingOccupies Portal = [(0,0),(-1,0),(1,0)]
-- Cybergate: XXX
-- XX XX
-- XX XX
-- X X
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)]
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)]
module CharacterAdvancement
(CharacterBumpRequest(..),
CharacterBumpResult(..),
(CharacterBumpResult(..),
characterFitness,
bumpCharacter,
characterLevel,
......@@ -11,16 +10,7 @@ module CharacterAdvancement
import qualified Data.Map as Map
import CreatureData
import CharacterData
-- |
-- Cause a character to advance in level or to gain a specific CharacterClass.
data CharacterBumpRequest =
-- 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
import PowerUpData
data CharacterBumpResult =
CharacterAwarded { character_points_awarded :: Integer,
......@@ -30,13 +20,12 @@ data CharacterBumpResult =
| CharacterForced { character_new_character_class :: CharacterClass,
character_new :: Creature }
-- |
-- Increases the character score by the set amount.
-- If the score is high enough that the character can advance to the next level,
-- this function will apply that advancement.
--
bumpCharacter :: CharacterBumpRequest -> Creature -> CharacterBumpResult
bumpCharacter :: PowerUpData -> Creature -> CharacterBumpResult
bumpCharacter (ForceCharacter character_class) c =
if character_class `elem` Map.keys (creature_levels c)
then bumpCharacter (AwardCharacter $ characterFitness new_character - characterFitness c) c
......
......@@ -5,19 +5,7 @@ module CharacterData
base_character_classes)
where
data CharacterClass = Barbarian
| Consular
| Engineer
| ForceAdept
| Marine
| Ninja
| Pirate
| Scout
| Shepherd
| StarChild
| Thief
| Warrior
deriving (Eq,Enum,Bounded,Read,Show,Ord)
import PersistantData
all_character_classes :: [CharacterClass]
all_character_classes = [minBound..maxBound]
......
......@@ -19,6 +19,7 @@ import Data.Maybe
import DeviceActivation
import Contact
import Plane
import DetailedLocation
data AttackModel =
RangedAttackModel CreatureRef ToolRef Device
......@@ -49,7 +50,7 @@ interactionMode (UnarmedAttackModel {}) = Unarmed
-- This will fail if the creature is holding anything other than a weapon.
attackModel :: (DBReadable db) => CreatureRef -> db AttackModel
attackModel attacker_ref =
do m_tool_ref <- dbGetWielded attacker_ref
do m_tool_ref <- getWielded attacker_ref
case m_tool_ref of
Nothing -> return $ UnarmedAttackModel attacker_ref
Just tool_ref ->
......@@ -87,20 +88,20 @@ data AttackOutcome =
resolveAttack :: (DBReadable db) => AttackModel -> Facing -> db AttackOutcome
resolveAttack attack_model face =
do device_activation <- resolveDeviceActivation (AttackSkill $ interactionMode attack_model)
do device_activation <- resolveDeviceActivation (AttackSkill $ interactionMode attack_model)
(DamageSkill $ interactionMode attack_model)
(ReloadSkill $ interactionMode attack_model)
(toPseudoDevice attack_model)
(attacker attack_model)
m_defender_ref <- liftM listToMaybe $ findContacts (contactMode $ interactionMode attack_model) (attacker attack_model) face
m_defender_ref <- liftM (listToMaybe . map asChild . mapLocations) $ findContacts (contactMode $ interactionMode attack_model) (attacker attack_model) face
case (dao_outcome_type device_activation,m_defender_ref) of
(DeviceFailed, _) | Just tool_ref <- weapon attack_model ->
(DeviceFailed, _) | Just tool_ref <- weapon attack_model ->
return $ AttackMalfunction (attacker attack_model) tool_ref (dao_energy device_activation)
(DeviceCriticalFailed, _) | Just tool_ref <- weapon attack_model ->
return $ AttackExplodes (attacker attack_model) tool_ref (dao_energy device_activation)
(DeviceActivated, Just defender_ref) ->
do defense_outcome <- resolveDefense (interactionMode attack_model) defender_ref
distance_squared <- liftM (fromMaybe 0) $ dbDistanceBetweenSquared (attacker attack_model) defender_ref
distance_squared <- liftM (fromMaybe 0) $ Plane.distanceBetweenSquared (attacker attack_model) defender_ref
let isDisarmingBlow = dao_skill_roll device_activation > do_skill_roll defense_outcome + distance_squared &&
dao_energy device_activation > do_damage_reduction defense_outcome + do_disarm_bonus defense_outcome
case () of
......@@ -122,9 +123,9 @@ data DefenseOutcome = DefenseOutcome {
do_damage_reduction :: Integer,
do_disarm_bonus :: Integer }
resolveDefense :: (DBReadable db) => CreatureInteractionMode -> CreatureRef -> db DefenseOutcome
resolveDefense :: (DBReadable db) => CreatureInteractionMode -> CreatureRef -> db DefenseOutcome
resolveDefense interaction_mode defender_ref =
do m_tool_ref <- dbGetWielded defender_ref
do m_tool_ref <- getWielded defender_ref
m_tool <- maybe (return Nothing) (liftM Just . dbGetTool) m_tool_ref
disarm_bonus <- maybe (return 0) toolDurability m_tool_ref
let pdevice = case m_tool of
......@@ -148,7 +149,7 @@ executeAttack (AttackHit attacker_ref m_tool_ref defender_ref damage) =
dbPushSnapshot $ AttackEvent attacker_ref m_tool_ref defender_ref
executeAttack (AttackMalfunction attacker_ref tool_ref damage) =
do injureCreature damage attacker_ref
_ <- dbMove dbDropTool tool_ref
_ <- move tool_ref =<< dropTool tool_ref
dbPushSnapshot $ WeaponOverheatsEvent attacker_ref tool_ref
return ()
executeAttack (AttackExplodes attacker_ref tool_ref damage) =
......@@ -157,7 +158,7 @@ executeAttack (AttackExplodes attacker_ref tool_ref damage) =
deleteTool tool_ref
executeAttack (AttackDisarm attacker_ref defender_ref dropped_tool) =
do dbPushSnapshot $ DisarmEvent attacker_ref defender_ref dropped_tool
_ <- dbMove dbDropTool dropped_tool
_ <- move dropped_tool =<< dropTool dropped_tool
return ()
executeAttack (AttackSunder attacker_ref weapon_ref defender_ref sundered_tool) =
do dbPushSnapshot $ SunderEvent attacker_ref weapon_ref defender_ref sundered_tool
......
......@@ -18,7 +18,7 @@ import Data.Maybe
-- True iff any terrain modification actually occured.
modifyFacingTerrain :: (TerrainPatch -> TerrainPatch) -> Facing -> CreatureRef -> DB Bool
modifyFacingTerrain f face creature_ref = liftM (fromMaybe False) $ runMaybeT $
do (plane_ref,position) <- MaybeT $ liftM extractParent $ dbWhere creature_ref
do (plane_ref,position) <- MaybeT $ liftM fromLocation $ whereIs creature_ref
let target_position = offsetPosition (facingToRelative face) position
prev_terrain <- lift $ terrainAt plane_ref target_position
let new_terrain = f prev_terrain
......
......@@ -6,6 +6,7 @@ module Contact
ContactModeType(..))
where
import Prelude hiding (getContents)
import Position
import Facing
import DB
......@@ -16,6 +17,7 @@ import Plane
import Data.Ord
import Data.List as List
import Data.Maybe
import DetailedLocation
-- | 'Touch' contacts are on the same or facing square as the subject.
-- 'Line' contacts are on any point starting on the same square and anywhere directly along a line traced in the
......@@ -39,22 +41,22 @@ instance ContactModeType CreatureInteractionMode where
-- farthest from the subject, except in the case of area contacts, which are
-- sorted from the center of the area. The subject is never a contact of
-- itself.
findContacts :: (DBReadable db,ReferenceType x,GenericReference a,ContactModeType c) =>
c -> Reference x -> Facing -> db [a]
findContacts :: (DBReadable db,ContactModeType c) =>
c -> Reference x -> Facing -> db [DetailedLocation Planar]
findContacts contact_mode attacker_ref face =
do (m_l :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap parent) $ getPlanarPosition attacker_ref
do (m_l :: Maybe (PlaneRef,MultiPosition)) <- liftM fromLocation $ whereIs attacker_ref
let testF pos (x :: MultiPosition) = case contactMode contact_mode of
Touch -> min (x `distanceBetweenChessboard` (offsetPosition (facingToRelative face) pos))
(x `distanceBetweenChessboard` pos) == 0
Line -> isFacing (pos,face) x
Area -> distanceBetweenSquared (offsetPosition (facingToRelative7 face) pos) x < 49
Area -> Position.distanceBetweenSquared (offsetPosition (facingToRelative7 face) pos) x < 49
center_pos pos = case contactMode contact_mode of
Area -> offsetPosition (facingToRelative7 face) pos
_ -> pos
flip (maybe $ return []) m_l $ \(plane_ref,pos) ->
liftM (mapMaybe fromLocation .
sortBy (comparing (distanceBetweenSquared (center_pos pos) . parent)) .
filter ((/= generalizeReference attacker_ref) . child) .
filter (testF pos . parent)) $
dbGetContents plane_ref
liftM (sortBy (comparing (Position.distanceBetweenSquared (center_pos pos) . (detail :: DetailedLocation Planar -> MultiPosition))) .
filter ((/= genericReference attacker_ref) . asChild . detail) .
filter (testF pos . detail)) $
(liftM mapLocations $ getContents plane_ref)
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeFamilies, PatternGuards #-}
module Creature
(generateInitialPlayerCreature,
......@@ -18,6 +18,7 @@ module Creature
sweepDead)
where
import Prelude hiding (getContents)
import CreatureData
import DB
import SpeciesData
......@@ -32,6 +33,7 @@ import Facing
import Position
import Plane
import PlayerState
import DetailedLocation
-- |
-- Generates a new Creature from the specified species.
......@@ -52,7 +54,7 @@ generateInitialPlayerCreature species =
-- |
-- Generates a new Creature from the specified Species and adds it to the database.
--
newCreature :: (CreatureLocation l) => Faction -> Species -> l -> DB CreatureRef
newCreature :: (LocationConstructor l, ReferenceTypeOf l ~ Creature) => Faction -> Species -> l -> DB CreatureRef
newCreature faction species loc =
do creature <- generateCreature faction species
dbAddCreature creature loc
......@@ -85,10 +87,8 @@ rollCreatureAbilityScore score other_ideal creature_ref =
-- | Ability bonus based on being good at working on specific types of terrain.
getTerrainAffinity :: (DBReadable db) => CreatureRef -> db Integer
getTerrainAffinity creature_ref =
do l <- liftM (fmap parent) $ getPlanarPosition creature_ref
terrain_affinity_points <- case l of
Nothing -> return 0
Just (plane_ref,pos) -> liftM sum $ forM [minBound..maxBound] $ \face ->
do (Parent plane_ref,pos) <- liftM detail $ getPlanarLocation creature_ref
terrain_affinity_points <- liftM sum $ forM [minBound..maxBound] $ \face ->
do t <- terrainAt plane_ref $ offsetPosition (facingToRelative face) pos
liftM (creatureAbilityScore $ TerrainAffinity t) $ dbGetCreature creature_ref
return $ terrain_affinity_points `div` 4
......@@ -125,14 +125,12 @@ getCreatureHealth :: (DBReadable db) => CreatureRef -> db Rational
getCreatureHealth creature_ref = liftM2 (%) (getCreatureAbsoluteHealth creature_ref) (getCreatureMaxHealth creature_ref)
getDead :: (DBReadable db) => Reference a -> db [CreatureRef]
getDead parent_ref = filterRO (liftM (<= 0) . getCreatureHealth) =<< dbGetContents parent_ref
getDead parent_ref = filterRO (liftM (<= 0) . getCreatureHealth) =<< liftM asChildren (getContents parent_ref)
deleteCreature :: CreatureRef -> DB ()
deleteCreature = dbUnsafeDeleteObject $ \l ->
do m_dropped_loc <- maybe (return Nothing) (liftM Just . dbDropTool) $ coerceChildTyped _tool l
return $ case m_dropped_loc of
Just dropped_loc -> generalizeLocation dropped_loc
Nothing -> error "dbDeleteCreature: no case for this type of entity"
deleteCreature creature_ref =
do planar <- liftM identityDetail $ getPlanarLocation creature_ref
dbUnsafeDeleteObject creature_ref $ const $ return planar
-- | Delete all dead creatures from the database.
sweepDead :: Reference a -> DB ()
......
This diff is collapsed.
This diff is collapsed.
......@@ -11,7 +11,7 @@ data ErrorFlag =
| NoToolWielded -- tried to perform an action that requires a wielded tool
| ToolIs_NotAtFeet -- tried to pick something up, but it isn't at your feet
| ToolIs_NotInInventory -- tried to perform an inventory action on a tool that isn't in inventory
| ToolIs_NotWieldable -- tried to wield a tool that can't be wielded. As of March 2010, there are no such tools, so this is a bug.
| ToolIs_NotWieldable -- tried to wield a tool that can't be wielded. As of January 2012, there are no such tools, so this is a bug.
| ToolIs_Unreachable -- tried to perform an action with a tool that isn't in reach (not in inventory, wielded, or at feet)
| ToolIs_Innapropriate -- tried to perform an action with a tool that can be used for that purpose
| Unable -- you can't do it
......
{-# OPTIONS_GHC -fglasgow-exts #-}
module DBPrivate
(Reference(..),
unsafeReference,
toUID,
Location(..),
unsafeLocation,
Position(..),
Standing(..),
Dropped(..),
......@@ -27,6 +24,7 @@ import CreatureData
import ToolData
import PlaneData
import BuildingData
import PlanetData
import Position
--
......@@ -34,8 +32,8 @@ import Position
-- to guarantee that such data structures are always consistent with the game logic,
-- e.g. a planet can not be wielded as a weapon.
--
-- DB and DBData import and re-export most of DBPrivate. Other modules should not
-- import DBPrivate.
-- DB and DBData import and re-export most of DBPrivate, but the un-exported portions
-- of this module are unsafe. Other modules should not import DBPrivate.
--
-- |
......@@ -52,11 +50,11 @@ type BuildingRef = Reference Building
-- A typesafe reference to any entity.
--
data Reference a = CreatureRef { uid:: Integer }
| PlaneRef { uid :: Integer }
| ToolRef { uid :: Integer }
| PlaneRef { uid :: Integer }
| ToolRef { uid :: Integer }
| BuildingRef { uid :: Integer }
| UniverseRef
deriving (Eq,Ord,Read,Show)
deriving (Eq,Ord,Read,Show)
unsafeReference :: Reference a -> Reference b
unsafeReference (CreatureRef x) = CreatureRef x
......@@ -92,7 +90,7 @@ data Dropped =
data Constructed =
Constructed { constructed_plane :: PlaneRef,
constructed_position :: Position,
constructed_type :: BuildingType }
constructed_shape :: BuildingShape }
deriving (Read,Show,Eq,Ord)
-- |
......@@ -114,7 +112,7 @@ data Wielded =
--
data Subsequent =
Subsequent { subsequent_to :: PlaneRef,
subsequent_via :: StargateType }
subsequent_via :: PlanetRegion }
deriving (Read,Show,Eq,Ord)
-- |
......@@ -125,13 +123,12 @@ data Beneath =
deriving (Read,Show,Eq,Ord)
-- |
-- A relational data structure defining the location of any entity.
--
-- c represents the type of the child entity, such as a Creature or Tool.
-- Represents a location.
--
-- p represents the type of the parent location, such as Standing or Dropped.
-- Up to roguestar 0.6, Locations were typed. As of 0.7 locations are untyped, but I added DetailedLocations.
--
data Location c p =
data Location =
IsStanding CreatureRef Standing
| IsDropped ToolRef Dropped
| InInventory ToolRef Inventory
......@@ -142,17 +139,7 @@ data Location c p =
| IsBeneath PlaneRef Beneath
deriving (Read,Show,Eq)
unsafeLocation :: Location a b -> Location c d
unsafeLocation (IsStanding a b) = IsStanding a b
unsafeLocation (IsDropped a b) = IsDropped a b
unsafeLocation (InInventory a b) = InInventory a b
unsafeLocation (IsWielded a b) = IsWielded a b
unsafeLocation (IsConstructed a b) = IsConstructed a b
unsafeLocation (InTheUniverse a) = InTheUniverse a
unsafeLocation (IsSubsequent a b) = IsSubsequent a b
unsafeLocation (IsBeneath a b) = IsBeneath a b
instance HierarchicalRelation (Location e t) where
instance HierarchicalRelation Location where
parent (IsStanding _ t) = toUID $ standing_plane t
parent (IsDropped _ t) = toUID $ dropped_plane t
parent (InInventory _ t) = toUID $ inventory_creature t
......
{-# LANGUAGE TypeFamilies, EmptyDataDecls, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
module Location
(AbstractLocation,
LocationView(..),
Child(..),
Parent(..),
fromLocation,
filterLocation,
LocationProvides(..),
abstractLocation,
coerceLocation,
Provided,
Motion(..))
where
import DBPrivate
import PlaneData
import CreatureData
import Data.Maybe
import Control.Monad
import Facing
newtype AbstractLocation a = AbstractLocation { concreteLocation :: (Location () ()) }
unsafeAbstractLocation :: AbstractLocation a -> AbstractLocation b