summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopherLaneHinson <>2011-04-03 01:04:27 (GMT)
committerLuite Stegeman <luite@luite.com>2011-04-03 01:04:27 (GMT)
commita75d811abbcd3a8482cee976bf79a2ff99102ea1 (patch)
tree481f732b819ee646c4060be0efd2f1db48a5edf5
parent9d5d83ab0ef34064c3fc855172b91792f7c29b16 (diff)
version 0.6.0.00.6.0.0
-rw-r--r--roguestar-engine.cabal92
-rw-r--r--src/Activate.hs4
-rw-r--r--src/AttributeGeneration.hs2
-rw-r--r--src/BeginGame.hs7
-rw-r--r--src/Behavior.hs40
-rw-r--r--src/Building.hs40
-rw-r--r--src/BuildingData.hs21
-rw-r--r--src/Character.hs17
-rw-r--r--src/CharacterAdvancement.hs81
-rw-r--r--src/CharacterData.hs43
-rw-r--r--src/Construction.hs2
-rw-r--r--src/Contact.hs19
-rw-r--r--src/Creature.hs20
-rw-r--r--src/CreatureAttribute.hs9
-rw-r--r--src/CreatureData.hs21
-rw-r--r--src/DB.hs263
-rw-r--r--src/DBData.hs380
-rw-r--r--src/DBErrorFlag.hs2
-rw-r--r--src/DBPrivate.hs57
-rw-r--r--src/Grids.hs28
-rw-r--r--src/Logging.hs22
-rw-r--r--src/Main.hs55
-rw-r--r--src/NodeData.hs13
-rw-r--r--src/Perception.hs28
-rw-r--r--src/Plane.hs119
-rw-r--r--src/PlaneVisibility.hs25
-rw-r--r--src/Planet.hs47
-rw-r--r--src/PlanetData.hs77
-rw-r--r--src/PlayerState.hs27
-rw-r--r--src/Protocol.hs114
-rw-r--r--src/Species.hs41
-rw-r--r--src/SpeciesData.hs1
-rw-r--r--src/TerrainData.hs84
-rw-r--r--src/Tool.hs33
-rw-r--r--src/Travel.hs88
-rw-r--r--src/TravelData.hs6
-rw-r--r--src/Turns.hs77
-rw-r--r--src/VisibilityData.hs12
38 files changed, 1258 insertions, 759 deletions
diff --git a/roguestar-engine.cabal b/roguestar-engine.cabal
index da22b70..f33bef0 100644
--- a/roguestar-engine.cabal
+++ b/roguestar-engine.cabal
@@ -1,53 +1,39 @@
-name: roguestar-engine
-version: 0.4.0.3
-license: OtherLicense
-license-file: LICENSE
-author: Christopher Lane Hinson
-maintainer: Christopher Lane Hinson <lane@downstairspeople.org>
-
-category: Game
-synopsis: Sci-fi roguelike (turn-based, chessboard-tiled, role playing) game
-description: Roguestar is a science fiction themed roguelike (turn-based,
- chessboard-tiled, role playing) game written in Haskell. This package
- provides the core game engine; you'll probably want to also install the
- OpenGL client.
- .
- The git repository is available at <http://www.downstairspeople.org/git/roguestar-engine.git>.
-homepage: http://roguestar.downstairspeople.org/
-
-build-depends: base>=4 && <5,
- containers>=0.3.0.0 && < 0.3.1,
- array>=0.3.0.0 && < 0.3.1,
- old-time>=1.0.0.3 && < 1.1,
- random>=1.0.0.2 && < 1.1,
- mtl>=1.1.0.2 && < 1.2,
- MaybeT>=0.1.2 && < 0.2,
- MonadRandom>=0.1.4 && < 0.2,
- data-memocombinators>=0.4.0 && < 0.5,
- stm>=2.1.1.2 && < 2.2,
- parallel>=2.2.0.1 && < 2.3,
- bytestring>=0.9.1.5 && < 0.10,
- PSQueue>=1.1 && < 1.2,
- priority-sync>=0.2.1.0 && < 0.3
-build-type: Simple
-tested-with: GHC==6.12.1
-
-executable: roguestar-engine
-main-is: Main.hs
-hs-source-dirs: src
-other-modules: VisibilityData, Stats, FactionData, Behavior, Alignment,
- PlaneData, Grids, Perception, PlaneVisibility,
- Turns, Plane, CreatureData,
- StatsData, 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
-
-ghc-options: -Wall -threaded -fno-warn-type-defaults
-ghc-prof-options: -prof -auto-all
+name: roguestar-engine
+version: 0.6.0.0
+cabal-version: -any
+build-type: Simple
+license: OtherLicense
+license-file: LICENSE
+maintainer: Christopher Lane Hinson <lane@downstairspeople.org>
+build-depends: hslogger >=1.1.0 && <1.2,
+ priority-sync >=0.2.1.0 && <0.3, PSQueue >=1.1 && <1.2,
+ bytestring >=0.9.1.5 && <0.10, parallel >=2.2.0.1 && <2.3,
+ stm >=2.1.1.2 && <2.2, data-memocombinators >=0.4.0 && <0.5,
+ MonadRandom >=0.1.4 && <0.2, MaybeT >=0.1.2 && <0.2,
+ mtl >=1.1.0.2 && <1.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 && <0.3.1, base >=4 && <5
+homepage: http://roguestar.downstairspeople.org/
+synopsis: Sci-fi roguelike game. Backend.
+description: Requires roguestar and roguestar-glut.
+category: Game
+author: Christopher Lane Hinson
+tested-with: GHC ==6.12.1
+
+executable: roguestar-engine
+main-is: Main.hs
+pkgconfig-depends:
+hs-source-dirs: src
+other-modules: TravelData VisibilityData Stats FactionData Behavior
+ Alignment PlaneData Grids Perception PlaneVisibility Turns Plane
+ CreatureData StatsData 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
+ghc-prof-options: -prof -auto-all
+ghc-shared-options: -prof -auto-all
+ghc-options: -threaded -fno-warn-type-defaults
diff --git a/src/Activate.hs b/src/Activate.hs
index 447d8c2..4317da3 100644
--- a/src/Activate.hs
+++ b/src/Activate.hs
@@ -37,11 +37,11 @@ resolveActivation creature_ref =
executeActivation :: ActivationOutcome -> DB ()
executeActivation (NoEffect) = return ()
-executeActivation (Heal creature_ref x) =
+executeActivation (Heal creature_ref x) =
do healCreature x creature_ref
dbPushSnapshot $ HealEvent creature_ref
executeActivation (ExpendTool tool_ref activation_outcome) =
do executeActivation activation_outcome
dbPushSnapshot $ ExpendToolEvent tool_ref
deleteTool tool_ref
-
+
diff --git a/src/AttributeGeneration.hs b/src/AttributeGeneration.hs
index 5c02823..f3836b1 100644
--- a/src/AttributeGeneration.hs
+++ b/src/AttributeGeneration.hs
@@ -11,7 +11,7 @@ import Data.Monoid
import Control.Monad
-- | Description of the random data to be generated.
-data AttributeGenerator a =
+data AttributeGenerator a =
AttributeAlways {
attribute_actual :: a,
attribute_min_max :: (Integer,Integer) }
diff --git a/src/BeginGame.hs b/src/BeginGame.hs
index 432a4fa..0620b12 100644
--- a/src/BeginGame.hs
+++ b/src/BeginGame.hs
@@ -34,6 +34,7 @@ homeBiome Myrmidon = DesertBiome
homeBiome Perennial = GrasslandBiome
homeBiome Recreant = TundraBiome
homeBiome Reptilian = ForestBiome
+homeBiome DustVortex = DesertBiome
startingEquipmentByClass :: CharacterClass -> [Tool]
startingEquipmentByClass Barbarian = [kinetic_fleuret]
@@ -47,6 +48,7 @@ startingEquipmentByClass Scout = [phase_pistol]
startingEquipmentByClass Shepherd = [sphere Wood]
startingEquipmentByClass Thief = [sphere Platinum]
startingEquipmentByClass Warrior = [phaser,kinetic_fleuret]
+startingEquipmentByClass StarChild = [sphere Diamond]
startingEquipmentBySpecies :: Species -> [Tool]
startingEquipmentBySpecies Anachronid = [sphere Radon]
@@ -61,10 +63,11 @@ startingEquipmentBySpecies Myrmidon = [sphere Krypton]
startingEquipmentBySpecies Perennial = [sphere Wood]
startingEquipmentBySpecies Recreant = [sphere Malignite]
startingEquipmentBySpecies Reptilian = [sphere Oxygen]
+startingEquipmentBySpecies DustVortex = []
dbCreateStartingPlane :: Creature -> DB PlaneRef
dbCreateStartingPlane creature =
- do dbNewPlane (Just "belhaven") (TerrainGenerationData {
+ do dbNewPlane "belhaven" (TerrainGenerationData {
tg_smootheness = 3,
tg_biome = homeBiome $ creature_species creature,
tg_placements = [] }) TheUniverse
@@ -79,7 +82,7 @@ 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,Monolith]
+ _ <- createTown plane_ref [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
diff --git a/src/Behavior.hs b/src/Behavior.hs
index 28874fb..ee7ea2c 100644
--- a/src/Behavior.hs
+++ b/src/Behavior.hs
@@ -15,6 +15,7 @@ import Control.Monad.Error
import Combat
import Activate
import Travel
+import TravelData
import Creature
import CreatureData
import Plane
@@ -29,9 +30,11 @@ import Building
--
-- Every possible behavior that a creature might take, AI or Human.
--
-data Behavior =
+data Behavior =
Step Facing
| TurnInPlace Facing
+ | StepDown
+ | StepUp
| Jump Facing
| Pickup ToolRef
| Wield ToolRef
@@ -45,13 +48,14 @@ data Behavior =
| Make PrepareMake
| ClearTerrain Facing
| ActivateBuilding Facing
+ deriving (Show)
-- | Get an appropriate behavior facing in the given direction.
-- If the adjacent facing square is empty, this is 'Step', but
-- 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 location) $ getPlanarPosition creature_ref
+ do (m_standing :: Maybe (PlaneRef,Position)) <- liftM (fmap parent) $ getPlanarPosition creature_ref
case m_standing of
Nothing -> return Wait
Just (plane_ref,pos) ->
@@ -62,9 +66,9 @@ facingBehavior creature_ref face =
case t of
_ | not (null who) -> return $ Attack face
_ | not (null what) -> return $ ActivateBuilding face
- Forest -> return $ TurnInPlace face
- DeepForest -> return $ TurnInPlace face
- RockFace -> return $ TurnInPlace face
+ Forest -> return $ ClearTerrain face
+ DeepForest -> return $ ClearTerrain face
+ RockFace -> return $ ClearTerrain face
_ -> return $ Step face
dbBehave :: Behavior -> CreatureRef -> DB ()
@@ -76,8 +80,18 @@ dbBehave (Step face) creature_ref =
() | face `elem` [North,South,East,West] -> move1ActionTime creature_ref
() | otherwise -> move2ActionTime creature_ref
+dbBehave StepDown creature_ref =
+ do _ <- atomic executeClimb $ resolveClimb creature_ref ClimbDown
+ -- FIXME: should be conditional
+ dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+
+dbBehave StepUp creature_ref =
+ do _ <- atomic executeClimb $ resolveClimb creature_ref ClimbUp
+ -- FIXME: should be conditional
+ dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+
dbBehave (Jump face) creature_ref =
- do atomic $ liftM executeTeleportJump $ resolveTeleportJump creature_ref face
+ do _ <- atomic executeTeleportJump $ resolveTeleportJump creature_ref face
dbAdvanceTime creature_ref =<< fullActionTime creature_ref
dbBehave (TurnInPlace face) creature_ref =
@@ -102,7 +116,7 @@ dbBehave (Unwield) creature_ref =
dbAdvanceTime creature_ref =<< quickActionTime creature_ref
dbBehave (Drop tool_ref) creature_ref =
- do tool_parent <- liftM extractLocation $ dbWhere tool_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
@@ -113,14 +127,14 @@ dbBehave (Drop tool_ref) creature_ref =
dbBehave (Fire face) creature_ref =
do _ <- dbMove (turnCreature face) creature_ref
ranged_attack_model <- rangedAttackModel creature_ref
- atomic $ liftM executeAttack $ resolveAttack ranged_attack_model face
+ _ <- 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
melee_attack_model <- meleeAttackModel creature_ref
- atomic $ liftM executeAttack $ resolveAttack melee_attack_model face
+ _ <- atomic executeAttack $ resolveAttack melee_attack_model face
dbAdvanceTime creature_ref =<< move1ActionTime creature_ref
return ()
@@ -129,7 +143,7 @@ dbBehave Wait creature_ref = dbAdvanceTime creature_ref =<< quickActionTime crea
dbBehave Vanish creature_ref =
do dbAdvanceTime creature_ref =<< quickActionTime creature_ref
_ <- runMaybeT $
- do (plane_ref :: PlaneRef) <- MaybeT $ liftM (fmap location) $ getPlanarPosition creature_ref
+ 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`)) $
@@ -139,12 +153,12 @@ dbBehave Vanish creature_ref =
return ()
dbBehave Activate creature_ref =
- do atomic $ liftM executeActivation $ resolveActivation creature_ref
+ do _ <- atomic executeActivation $ resolveActivation creature_ref
dbAdvanceTime creature_ref =<< quickActionTime creature_ref
return ()
dbBehave (Make make_prep) creature_ref =
- do atomic $ liftM executeMake $ resolveMake creature_ref make_prep
+ do _ <- atomic executeMake $ resolveMake creature_ref make_prep
dbAdvanceTime creature_ref =<< fullActionTime creature_ref
return ()
@@ -168,7 +182,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 (asReferenceTyped _tool)) $ dbGetContents creature_ref
+ do inventory_size <- liftM (genericLength . map (asType _tool)) $ dbGetContents creature_ref
inventory_skill <- liftM roll_ideal $ rollCreatureAbilityScore InventorySkill 0 creature_ref
return $ (inventory_size ^ 2) % inventory_skill
diff --git a/src/Building.hs b/src/Building.hs
index ce9434a..921ce70 100644
--- a/src/Building.hs
+++ b/src/Building.hs
@@ -16,6 +16,8 @@ import Plane
import Position
import TerrainData
import Control.Monad.Error
+import NodeData
+import CharacterAdvancement
-- | The total occupied surface area of a building.
buildingSize :: (DBReadable db) => BuildingRef -> db Integer
@@ -23,36 +25,41 @@ buildingSize = liftM (genericLength . buildingOccupies) . buildingType
buildingType :: (DBReadable db) => BuildingRef -> db BuildingType
buildingType building_ref =
- do constructed <- liftM extractLocation $ dbWhere building_ref
+ do constructed <- liftM extractParent $ dbWhere building_ref
case constructed of
Just (Constructed _ _ building_type) -> return building_type
_ -> error "buildingSize: impossible case"
+deleteBuilding :: BuildingRef -> DB ()
+deleteBuilding = dbUnsafeDeleteObject (error "deleteBuilding: impossible case, buildings shouldn't contain anything.")
+
-- | Activate the facing building, returns True iff any building was actually activated.
activateFacingBuilding :: Facing -> CreatureRef -> DB Bool
activateFacingBuilding face creature_ref = liftM (fromMaybe False) $ runMaybeT $
- do (plane_ref,position) <- MaybeT $ liftM extractLocation $ dbWhere creature_ref
+ do (plane_ref,position) <- MaybeT $ liftM extractParent $ dbWhere creature_ref
buildings <- lift $ whatIsOccupying plane_ref $ offsetPosition (facingToRelative face) position
liftM or $ lift $ forM buildings $ \building_ref ->
do building_type <- buildingType building_ref
activateBuilding building_type creature_ref building_ref
activateBuilding :: BuildingType -> CreatureRef -> BuildingRef -> DB Bool
-activateBuilding Monolith _ _ = return False
+activateBuilding (Node n) creature_ref building_ref =
+ do captureNode n creature_ref building_ref
+ return True
activateBuilding Portal creature_ref building_ref =
- do m_creature_position :: Maybe (PlaneRef,Position) <- liftM extractLocation $ dbWhere creature_ref
- m_portal_position :: Maybe (PlaneRef,Position) <- liftM extractLocation $ dbWhere 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"
case (m_creature_position,m_portal_position) of
(Just (plane_ref,Position (_,cy)),Just (_,Position (_,py))) ->
case () of
() | cy < py ->
- do m_subsequent_loc :: Maybe (Location S PlaneRef Subsequent) <- liftM listToMaybe $ dbGetContents plane_ref
+ do m_subsequent_loc :: Maybe (Location PlaneRef Subsequent) <- liftM listToMaybe $ dbGetContents plane_ref
case m_subsequent_loc of
- Just loc -> (portalCreatureTo 1 creature_ref $ entity loc) >> return True
+ Just loc -> (portalCreatureTo 1 creature_ref $ child loc) >> return True
_ -> throwError $ DBErrorFlag NoStargateAddress
() | cy > py ->
- do m_previous_loc :: Maybe Subsequent <- liftM extractLocation $ dbWhere plane_ref
+ do m_previous_loc :: Maybe Subsequent <- liftM extractParent $ dbWhere plane_ref
case m_previous_loc of
Just loc -> (portalCreatureTo (-1) creature_ref $ subsequent_to loc) >> return True
_ -> throwError $ DBErrorFlag NoStargateAddress
@@ -62,17 +69,26 @@ activateBuilding Portal creature_ref building_ref =
-- | Deposit a creature in front of (-1) or behind (+1) a random portal on the specified plane. Returns
-- the dbMove result from the action.
-portalCreatureTo :: Integer -> CreatureRef -> PlaneRef -> DB (Location S CreatureRef (),Location S CreatureRef Standing)
+portalCreatureTo :: Integer -> CreatureRef -> PlaneRef -> DB (Location CreatureRef (),Location CreatureRef Standing)
portalCreatureTo offset creature_ref plane_ref =
do portals <- filterM (liftM (== Portal) . buildingType) =<< dbGetContents plane_ref
ideal_position <- if null portals
then liftM2 (\x y -> Position (x,y)) (getRandomR (-100,100)) (getRandomR (-100,100))
else do portal <- pickM portals
- m_position <- liftM (fmap (offsetPosition (0,offset)) . extractLocation) $ dbWhere portal
+ m_position <- liftM (fmap (offsetPosition (0,offset)) . extractParent) $ dbWhere portal
return $ fromMaybe (Position (0,0)) m_position
position <- pickRandomClearSite 1 0 0 ideal_position (not . (`elem` impassable_terrains)) plane_ref
dbPushSnapshot $ TeleportEvent creature_ref
dbMove (return . toStanding (Standing plane_ref position Here)) creature_ref
-
-
+
+captureNode :: NodeType -> CreatureRef -> BuildingRef -> DB ()
+captureNode n creature_ref building_ref =
+ do c <- dbGetCreature creature_ref
+ let result = bumpCharacter (nodeEffect n) c
+ dbModCreature (const $ character_new result) creature_ref
+ deleteBuilding building_ref
+ dbPushSnapshot $ BumpEvent {
+ bump_event_creature = creature_ref,
+ bump_event_new_level = newCharacterLevel result,
+ bump_event_new_class = newCharacterClass result }
diff --git a/src/BuildingData.hs b/src/BuildingData.hs
index c388aaf..392b83c 100644
--- a/src/BuildingData.hs
+++ b/src/BuildingData.hs
@@ -2,15 +2,28 @@
module BuildingData
(Building(..),
BuildingType(..),
+ NodeType(..),
+ all_nodes,
+ showBuilding,
buildingOccupies)
where
data Building = Building
deriving (Read,Show)
-data BuildingType = Monolith | Portal
+data BuildingType = Node NodeType | Portal
deriving (Eq,Ord,Read,Show)
+data NodeType = Monolith | Anchor
+ deriving (Eq,Ord,Read,Show,Enum,Bounded)
+
+all_nodes :: [NodeType]
+all_nodes = [minBound..maxBound]
+
+showBuilding :: BuildingType -> String
+showBuilding (Node n) = show n
+showBuilding x = show x
+
-- | 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
-- (mountains, trees, water, lava, etc.) and no other objects can co-occupy these squares.
@@ -18,8 +31,8 @@ data BuildingType = Monolith | Portal
-- 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 Monolith = [(0,0)]
--- Portal: XXX
+-- Monolith: X
+buildingOccupies (Node _) = [(0,0)]
+-- Portal: XXX
buildingOccupies Portal = [(0,0),(-1,0),(1,0)]
diff --git a/src/Character.hs b/src/Character.hs
index 1a9a051..e21fdf4 100644
--- a/src/Character.hs
+++ b/src/Character.hs
@@ -18,7 +18,7 @@ data CharacterClassData = CharacterClassData {
character_class_attributes :: CreatureAttribute }
getEligableCharacterClassesComposable :: [CharacterClass] -> Creature -> [CharacterClass]
-getEligableCharacterClassesComposable allowed_classes creature =
+getEligableCharacterClassesComposable allowed_classes creature =
filter (\x -> character_class_prerequisite (classInfo x) creature || isFavoredClass x creature) allowed_classes
getEligableCharacterClasses :: Creature -> [CharacterClass]
@@ -40,7 +40,7 @@ mustHave score min_score creature = (rawScore score creature) >= min_score
-- function). The prerequisite(s) restrict what 'Creatures' can advance in the 'CharacterClass'.
--
-- The second parameter is the list of 'CreatureAttribute's that a Creature gains when it levels in the
--- 'CharacterClass'.
+-- 'CharacterClass'.
--
characterClass :: Prerequisite -> CreatureAttribute -> CharacterClassData
characterClass prereqs attribs = CharacterClassData prereqs attribs
@@ -53,7 +53,7 @@ classInfo :: CharacterClass -> CharacterClassData
-------------------------------------------------------------------------------
--
-- Base Classes
---
+--
-- These are base classes: these classes have very low prerequisites,
-- with the intention that characters can choose them at the beginning
-- of a game. They also contain extra information about the character's
@@ -94,3 +94,14 @@ classInfo Thief = characterClass (mustHave Perception 20) $
classInfo Warrior = characterClass (prerequisites [mustHave Strength 15,mustHave Speed 15]) $
AttackSkill Melee & DefenseSkill Melee & Constitution & Strength & Speed & Mindfulness & Tactical
+-------------------------------------------------------------------------------
+--
+-- Special Classes
+--
+-- These are special character classes that are gained by taking specific actions.
+--
+-------------------------------------------------------------------------------
+
+classInfo StarChild = characterClass (prerequisites []) $
+ Intellect & Indifferent
+
diff --git a/src/CharacterAdvancement.hs b/src/CharacterAdvancement.hs
new file mode 100644
index 0000000..5f556e6
--- /dev/null
+++ b/src/CharacterAdvancement.hs
@@ -0,0 +1,81 @@
+module CharacterAdvancement
+ (CharacterBumpRequest(..),
+ CharacterBumpResult(..),
+ characterFitness,
+ bumpCharacter,
+ characterLevel,
+ newCharacterLevel,
+ newCharacterClass)
+ where
+
+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
+
+data CharacterBumpResult =
+ CharacterAwarded { character_points_awarded :: Integer,
+ character_new :: Creature }
+ | CharacterAdvanced { character_new_level :: Integer,
+ character_new :: Creature }
+ | 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 (ForceCharacter character_class) c =
+ if character_class `elem` Map.keys (creature_levels c)
+ then bumpCharacter (AwardCharacter $ characterFitness new_character - characterFitness c) c
+ else CharacterForced {
+ character_new_character_class = character_class,
+ character_new = new_character }
+ where new_character = applyToCreature character_class c
+bumpCharacter (AwardCharacter n) c =
+ if fitness_gain >= bumped_score
+ then CharacterAdvanced {
+ character_new_level = characterLevel new_character,
+ character_new = new_character { creature_points = bumped_score - fitness_gain } }
+ else CharacterAwarded {
+ character_points_awarded = n,
+ character_new = c { creature_points = bumped_score } }
+ where bumped_score = creature_points c + n
+ fitness_gain = characterFitness new_character - characterFitness c
+ new_character = applyToCreature (Map.keys $ creature_levels c) c
+
+newCharacterClass :: CharacterBumpResult -> Maybe CharacterClass
+newCharacterClass (CharacterForced character_class _) = Just character_class
+newCharacterClass _ = Nothing
+
+newCharacterLevel :: CharacterBumpResult -> Maybe Integer
+newCharacterLevel (CharacterAdvanced new_level _) = Just new_level
+newCharacterLevel _ = Nothing
+
+-- |
+-- Answers the character level. This is the maximum of the number
+-- of levels the Character has in any class.
+-- A rather arbitrary (non-representative of game balance)
+-- measure of Character power.
+--
+characterLevel :: Creature -> Integer
+characterLevel = maximum . Map.elems . creature_levels
+
+-- |
+-- Answers the estimated fitness (powerfulness) of the Character.
+--
+characterFitness :: Creature -> Integer
+characterFitness c = sum $ (Map.elems $ creature_aptitude c) ++ (Map.elems $ creature_ability c)
+
diff --git a/src/CharacterData.hs b/src/CharacterData.hs
index 6685813..f061edc 100644
--- a/src/CharacterData.hs
+++ b/src/CharacterData.hs
@@ -6,31 +6,32 @@ module CharacterData
where
data CharacterClass = Barbarian
- | Consular
- | Engineer
- | ForceAdept
- | Marine
- | Ninja
- | Pirate
- | Scout
- | Shepherd
- | Thief
- | Warrior
- deriving (Eq,Enum,Bounded,Read,Show,Ord)
+ | Consular
+ | Engineer
+ | ForceAdept
+ | Marine
+ | Ninja
+ | Pirate
+ | Scout
+ | Shepherd
+ | StarChild
+ | Thief
+ | Warrior
+ deriving (Eq,Enum,Bounded,Read,Show,Ord)
all_character_classes :: [CharacterClass]
all_character_classes = [minBound..maxBound]
base_character_classes :: [CharacterClass]
base_character_classes = [Barbarian,
- Consular,
- Engineer,
- ForceAdept,
- Marine,
- Ninja,
- Pirate,
- Scout,
- Shepherd,
- Thief,
- Warrior]
+ Consular,
+ Engineer,
+ ForceAdept,
+ Marine,
+ Ninja,
+ Pirate,
+ Scout,
+ Shepherd,
+ Thief,
+ Warrior]
diff --git a/src/Construction.hs b/src/Construction.hs
index ee76e6c..0ceb2d3 100644
--- a/src/Construction.hs
+++ b/src/Construction.hs
@@ -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 extractLocation $ dbWhere creature_ref
+ do (plane_ref,position) <- MaybeT $ liftM extractParent $ dbWhere creature_ref
let target_position = offsetPosition (facingToRelative face) position
prev_terrain <- lift $ terrainAt plane_ref target_position
let new_terrain = f prev_terrain
diff --git a/src/Contact.hs b/src/Contact.hs
index c5eac40..f6cb1cb 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -19,7 +19,7 @@ import Data.Maybe
-- | '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
-- facing direction, out to infinity. 'Area' contacts lie inside a circle of radius 7, centered 7 squares in the
--- facing direction. Use 'Area' 'Here' for a circle centerd on the subject.
+-- facing direction. Use 'Area' 'Here' for a circle centered on the subject.
data ContactMode = Touch | Line | Area
class ContactModeType a where
@@ -34,11 +34,14 @@ instance ContactModeType CreatureInteractionMode where
contactMode Ranged = Line
contactMode Splash = Area
--- | Find contacts to a reference. The result is sorted by from closest to 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 S,ContactModeType c) => c -> Reference x -> Facing -> db [a]
+-- | Find contacts to a reference. The result is sorted by from closest to
+-- 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 contact_mode attacker_ref face =
- do (m_l :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap location) $ getPlanarPosition attacker_ref
+ do (m_l :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap parent) $ getPlanarPosition attacker_ref
let testF pos (x :: MultiPosition) = case contactMode contact_mode of
Touch -> min (x `distanceBetweenChessboard` (offsetPosition (facingToRelative face) pos))
(x `distanceBetweenChessboard` pos) == 0
@@ -49,8 +52,8 @@ findContacts contact_mode attacker_ref face =
_ -> pos
flip (maybe $ return []) m_l $ \(plane_ref,pos) ->
liftM (mapMaybe fromLocation .
- sortBy (comparing (distanceBetweenSquared (center_pos pos) . location)) .
- filter ((/= generalizeReference attacker_ref) . entity) .
- filter (testF pos . location)) $
+ sortBy (comparing (distanceBetweenSquared (center_pos pos) . parent)) .
+ filter ((/= generalizeReference attacker_ref) . child) .
+ filter (testF pos . parent)) $
dbGetContents plane_ref
diff --git a/src/Creature.hs b/src/Creature.hs
index b43c10a..19c7f8c 100644
--- a/src/Creature.hs
+++ b/src/Creature.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE PatternGuards #-}
-module Creature
+module Creature
(generateInitialPlayerCreature,
newCreature,
Roll(..),
@@ -44,16 +44,16 @@ generateCreature faction species = generateAttributes faction species $ mconcat
-- database's DBClassSelectionState.
--
generateInitialPlayerCreature :: Species -> DB ()
-generateInitialPlayerCreature species =
+generateInitialPlayerCreature species =
do newc <- generateCreature Player species
- dbSetStartingRace species
+ dbSetStartingSpecies species
setPlayerState (ClassSelectionState newc)
-- |
-- Generates a new Creature from the specified Species and adds it to the database.
--
newCreature :: (CreatureLocation l) => Faction -> Species -> l -> DB CreatureRef
-newCreature faction species loc =
+newCreature faction species loc =
do creature <- generateCreature faction species
dbAddCreature creature loc
@@ -62,7 +62,7 @@ data RollComponents = RollComponents {
component_other_situation_bonus :: Integer,
component_terrain_affinity_bonus :: Integer }
-data Roll = Roll {
+data Roll = Roll {
roll_ideal :: Integer,
roll_actual :: Integer,
roll_ideal_components :: RollComponents,
@@ -85,7 +85,7 @@ 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 location) $ getPlanarPosition 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 ->
@@ -129,10 +129,10 @@ getDead parent_ref = filterRO (liftM (<= 0) . getCreatureHealth) =<< dbGetConten
deleteCreature :: CreatureRef -> DB ()
deleteCreature = dbUnsafeDeleteObject $ \l ->
- do m_dropped_loc <- maybe (return Nothing) (liftM Just . dbDropTool) $ coerceEntityTyped _tool l
+ do m_dropped_loc <- maybe (return Nothing) (liftM Just . dbDropTool) $ coerceChildTyped _tool l
return $ case m_dropped_loc of
- Just dropped_loc -> generalizeLocationRecord dropped_loc
- Nothing -> error "dbDeleteCreature: no case for this type of entity"
+ Just dropped_loc -> generalizeLocation dropped_loc
+ Nothing -> error "dbDeleteCreature: no case for this type of entity"
-- | Delete all dead creatures from the database.
sweepDead :: Reference a -> DB ()
@@ -140,4 +140,4 @@ sweepDead ref =
do worst_to_best_critters <- sortByRO getCreatureHealth =<< getDead ref
flip mapM_ worst_to_best_critters $ \creature_ref ->
do dbPushSnapshot (KilledEvent creature_ref)
- deleteCreature creature_ref
+ deleteCreature creature_ref
diff --git a/src/CreatureAttribute.hs b/src/CreatureAttribute.hs
index 397a0b8..f6a0ac7 100644
--- a/src/CreatureAttribute.hs
+++ b/src/CreatureAttribute.hs
@@ -28,12 +28,11 @@ x & y = CreatureAttribute $ Endo $ applyToCreature x . applyToCreature y
type CreatureAttributeGenerator = AttributeGenerator CreatureAttribute
-- |
--- Generate a ratio of males to females with any gender dimorphism.
--- 'gender (1%3) [attributeStatic 5 Speed] [attributeStatic 5 Mindfulness]' generates a
--- creature with a 1:2 male:female ratio, faster males, and more mindful females.
+-- Generate a ratio of males to females.
--
-gender :: Rational -> [CreatureAttributeGenerator] -> [CreatureAttributeGenerator] -> CreatureAttributeGenerator
-gender r male_dimorphism female_dimorphism = AG.attributeChoice r (CreatureAttribute.attributeStatic 1 Male:male_dimorphism) (CreatureAttribute.attributeStatic 1 Female:female_dimorphism)
+gender :: Rational -> CreatureAttributeGenerator
+gender r = AG.attributeChoice r [CreatureAttribute.attributeStatic 1 Male]
+ [CreatureAttribute.attributeStatic 1 Female]
attributeStatic :: (CreatureEndo a) => Integer -> a -> CreatureAttributeGenerator
attributeStatic n a = AG.attributeStatic n (CreatureAttribute $ Endo $ applyToCreature a)
diff --git a/src/CreatureData.hs b/src/CreatureData.hs
index 8ab34ee..f613119 100644
--- a/src/CreatureData.hs
+++ b/src/CreatureData.hs
@@ -1,5 +1,5 @@
-module CreatureData
+module CreatureData
(Creature(..),
CreatureGender(..),
CreatureAptitude(..),
@@ -30,11 +30,12 @@ data Creature = Creature { creature_aptitude :: Map.Map CreatureAptitude Integer
creature_levels :: Map.Map CharacterClass Integer,
creature_favored_classes :: Set.Set CharacterClass,
creature_gender :: CreatureGender,
- creature_species :: Species,
- creature_random_id :: Integer, -- random number attached to the creature, not unique
- creature_damage :: Integer,
- creature_faction :: Faction }
- deriving (Read,Show)
+ creature_species :: Species,
+ creature_random_id :: Integer, -- random number attached to the creature, not unique
+ creature_damage :: Integer,
+ creature_faction :: Faction,
+ creature_points :: Integer }
+ deriving (Read,Show)
-- | Creature having no attributes and undefined 'creature_species', 'creature_random_id', and 'creature_faction'
--
@@ -49,11 +50,13 @@ empty_creature = Creature {
creature_species = error "empty_creature: undefined creature_species",
creature_random_id = error "empty_creature: undefined creature_random_id",
creature_damage = 0,
- creature_faction = error "empty_creature: undefined creature_faction" }
+ creature_faction = error "empty_creature: undefined creature_faction",
+ creature_points = 0 }
data CreatureGender = Male | Female | Neuter deriving (Eq,Read,Show)
--- | Endomorphisms over a 'Creature'. These are types that contribute some feature to a 'Creature', so that 'Creature's can be defined concisely by those properties.
+-- | Endomorphisms over a 'Creature'. These are types that contribute some feature to a 'Creature',
+-- so that 'Creature's can be defined concisely by those properties.
class CreatureEndo a where
applyToCreature :: a -> Creature -> Creature
@@ -72,7 +75,7 @@ instance CreatureEndo CreatureGender where
applyToCreature g c = c { creature_gender = g }
-- | The seven aptitudes.
-data CreatureAptitude =
+data CreatureAptitude =
Strength
| Speed
| Constitution
diff --git a/src/DB.hs b/src/DB.hs
index 7c692b1..06ba926 100644
--- a/src/DB.hs
+++ b/src/DB.hs
@@ -1,4 +1,9 @@
-{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, FlexibleContexts, Rank2Types, RelaxedPolyRec #-}
+{-# LANGUAGE MultiParamTypeClasses,
+ ExistentialQuantification,
+ FlexibleContexts,
+ Rank2Types,
+ RelaxedPolyRec,
+ ScopedTypeVariables #-}
module DB
(DBResult,
@@ -34,9 +39,10 @@ module DB
dbGetAncestors,
dbWhere,
dbGetContents,
- dbSetStartingRace,
- dbGetStartingRace,
+ dbSetStartingSpecies,
+ dbGetStartingSpecies,
ro, atomic,
+ logDB,
mapRO, filterRO, sortByRO,
dbGetTimeCoordinate,
dbAdvanceTime,
@@ -47,8 +53,7 @@ module DB
dbHasSnapshot,
module DBData,
module DBErrorFlag,
- module Random,
- dbTrace)
+ module Random)
where
import DBPrivate
@@ -59,7 +64,7 @@ import BuildingData
import RNG
import Data.Map as Map
import Data.List as List
-import HierarchicalDatabase
+import qualified HierarchicalDatabase as HD
import SpeciesData
import Data.Maybe
import ToolData
@@ -72,26 +77,27 @@ import Data.Ord
import Control.Arrow (first,second)
import Control.Monad.Random as Random
import Random
-import Debug.Trace
import PlayerState
import DBErrorFlag
import Control.Parallel.Strategies
+import System.IO.Unsafe
+import Logging
data DB_History = DB_History {
db_here :: DB_BaseType,
db_random :: RNG }
data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
- db_next_object_ref :: Integer,
- db_starting_race :: Maybe Species,
- db_creatures :: Map CreatureRef Creature,
- db_planes :: Map PlaneRef Plane,
- db_tools :: Map ToolRef Tool,
- db_buildings :: Map BuildingRef Building,
- db_hierarchy :: HierarchicalDatabase (Location S (Reference ()) ()),
- db_time_coordinates :: Map (Reference ()) TimeCoordinate,
- db_error_flag :: String,
- db_prior_snapshot :: Maybe DB_BaseType,
+ db_next_object_ref :: Integer,
+ db_starting_species :: Maybe Species,
+ db_creatures :: Map CreatureRef Creature,
+ db_planes :: Map PlaneRef Plane,
+ db_tools :: Map ToolRef Tool,
+ db_buildings :: Map BuildingRef Building,
+ db_hierarchy :: HD.HierarchicalDatabase (Location (Reference ()) ()),
+ db_time_coordinates :: Map (Reference ()) TimeCoordinate,
+ db_error_flag :: String,
+ db_prior_snapshot :: Maybe DB_BaseType,
db_action_count :: Integer }
deriving (Read,Show)
@@ -107,7 +113,7 @@ type DBResult r = Either DBError (r,DB_History)
data DB a = DB { cycleDB :: forall r. DB_History -> (a -> DB_History -> DBResult r) -> DBResult r }
runDB :: DB a -> DB_BaseType -> IO (Either DBError (a,DB_BaseType))
-runDB dbAction database =
+runDB dbAction database =
do hist <- setupDBHistory database
return $ (either Left (Right . second db_here)) $ cycleDB dbAction hist $ \a h -> Right (a,h)
@@ -130,12 +136,12 @@ instance MonadState DB_BaseType DB where
instance MonadReader DB_BaseType DB where
ask = get
- local modification actionM =
+ local modification actionM =
do split_rng <- dbRandomSplit
s <- get
- modify modification
+ modify modification
a <- catchError (liftM Right actionM) (return . Left)
- DB $ \h f -> f () $ h { db_here = s, db_random = split_rng }
+ DB $ \h f -> f () $ h { db_here = s, db_random = split_rng }
either throwError return a
instance MonadError DBError DB where
@@ -162,16 +168,18 @@ instance DBReadable DB where
dbSimulate = local id
dbPeepSnapshot actionM =
do s <- DB $ \h f -> f (db_here h) h
- m_snapshot <- gets db_prior_snapshot
- case m_snapshot of
- Just snapshot ->
- do split_rng <- dbRandomSplit
+ m_snapshot <- gets db_prior_snapshot
+ case m_snapshot of
+ Just snapshot ->
+ do split_rng <- dbRandomSplit
DB $ \h f -> f () $ h { db_here = snapshot }
- a <- dbSimulate actionM
+ a <- dbSimulate actionM
DB $ \h f -> f () $ h { db_here = s, db_random = split_rng }
- return $ Just a
+ return $ Just a
Nothing -> return Nothing
-
+
+logDB :: (DBReadable db) => String -> Priority -> String -> db ()
+logDB l p s = return $! unsafePerformIO $ logM l p s
ro :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
ro db = dbSimulate db
@@ -184,33 +192,34 @@ mapRO f xs = liftM (`using` parList rwhnf) $ mapM (dbSimulate . f) xs
sortByRO :: (DBReadable db,Ord b) => (forall m. DBReadable m => a -> m b) -> [a] -> db [a]
sortByRO f xs =
- liftM (List.map fst . sortBy (comparing snd)) $ flip mapRO xs $ \x ->
+ liftM (List.map fst . sortBy (comparing snd)) $ flip mapRO xs $ \x ->
do y <- f x
- return (x,y)
-
-atomic :: (forall m. DBReadable m => m (DB a)) -> DB a
-atomic transaction =
- do db_a <- ro transaction
- (a,s) <- dbSimulate $
- do a <- db_a
- s <- get
- return (a,s)
+ return (x,y)
+
+-- | Run action synthesized from a read-only action (prepare-execute pattern).
+atomic :: (x -> DB ()) -> (forall m. DBReadable m => m x) -> DB x
+atomic action ro_action =
+ do x <- ro ro_action
+ s <- dbSimulate $
+ do action x
+ s <- get
+ return s
put s
- return a
+ return x
-- |
-- Generates an initial DB state.
--
initial_db :: DB_BaseType
-initial_db = DB_BaseType {
- db_player_state = RaceSelectionState,
+initial_db = DB_BaseType {
+ db_player_state = SpeciesSelectionState,
db_next_object_ref = 0,
- db_starting_race = Nothing,
+ db_starting_species = Nothing,
db_creatures = Map.fromList [],
db_planes = Map.fromList [],
db_tools = Map.fromList [],
db_buildings = Map.fromList [],
- db_hierarchy = HierarchicalDatabase.fromList [],
+ db_hierarchy = HD.fromList [],
db_error_flag = [],
db_time_coordinates = Map.fromList [(generalizeReference the_universe, zero_time)],
db_prior_snapshot = Nothing,
@@ -221,7 +230,7 @@ setupDBHistory db =
do rng <- randomIO
return $ DB_History {
db_here = db,
- db_random = rng }
+ db_random = rng }
-- |
-- Returns the DBState of the database.
@@ -245,17 +254,17 @@ dbNextObjectRef :: DB Integer
dbNextObjectRef = do modify $ \db -> db { db_next_object_ref = succ $ db_next_object_ref db }
gets db_next_object_ref
-class (LocationType l) => CreatureLocation l where
- creatureLocation :: CreatureRef -> l -> Location m CreatureRef l
+class (LocationParent l) => CreatureLocation l where
+ creatureLocation :: CreatureRef -> l -> Location CreatureRef l
-class (LocationType l) => ToolLocation l where
- toolLocation :: ToolRef -> l -> Location m ToolRef l
+class (LocationParent l) => ToolLocation l where
+ toolLocation :: ToolRef -> l -> Location ToolRef l
-class (LocationType l) => BuildingLocation l where
- buildingLocation :: BuildingRef -> l -> Location m BuildingRef l
+class (LocationParent l) => BuildingLocation l where
+ buildingLocation :: BuildingRef -> l -> Location BuildingRef l
-class (LocationType l) => PlaneLocation l where
- planeLocation :: PlaneRef -> l -> Location m PlaneRef l
+class (LocationParent l) => PlaneLocation l where
+ planeLocation :: PlaneRef -> l -> Location PlaneRef l
instance CreatureLocation Standing where
creatureLocation a l = IsStanding (unsafeReference a) l
@@ -278,20 +287,25 @@ instance PlaneLocation TheUniverse where
instance PlaneLocation Subsequent where
planeLocation a l = IsSubsequent a l
+instance PlaneLocation Beneath where
+ planeLocation a l = IsBeneath a l
+
-- |
-- Adds something to a map in the database using a new object reference.
--
-dbAddObjectComposable :: (ReferenceType a,LocationType (Reference a),LocationType l) =>
- (Integer -> (Reference a)) ->
- (Reference a -> a -> DB ()) ->
- (Reference a -> l -> Location S (Reference a) l) ->
+dbAddObjectComposable :: (ReferenceType a,
+ LocationChild (Reference a),
+ LocationParent l) =>
+ (Integer -> (Reference a)) ->
+ (Reference a -> a -> DB ()) ->
+ (Reference a -> l -> Location (Reference a) l) ->
a -> l -> DB (Reference a)
-dbAddObjectComposable constructReference updateObject constructLocation thing loc =
+dbAddObjectComposable constructReference updateObject constructLocation thing loc =
do ref <- liftM constructReference $ dbNextObjectRef
updateObject ref thing
dbSetLocation $ constructLocation ref loc
- parent_ref <- liftM (getLocation) $ dbWhere ref
- dbSetTimeCoordinate (generalizeReference ref) =<< dbGetTimeCoordinate (generalizeReference parent_ref)
+ genericParent_ref <- liftM genericParent $ dbWhere ref
+ dbSetTimeCoordinate (generalizeReference ref) =<< dbGetTimeCoordinate (generalizeReference genericParent_ref)
return ref
-- |
@@ -319,13 +333,15 @@ dbAddBuilding :: (BuildingLocation l) => Building -> l -> DB BuildingRef
dbAddBuilding = dbAddObjectComposable BuildingRef dbPutBuilding buildingLocation
-- |
--- This deletes an object, but leaves any of it's contents dangling.
+-- This deletes an object, which will cause future references to the same object
+-- to fail. Accepts a function to move all of the objects nested within the
+-- object being deleted.
--
dbUnsafeDeleteObject :: (ReferenceType e) =>
- (forall m. DBReadable m =>
- Location M (Reference ()) (Reference e) ->
- m (Location M (Reference ()) ())) ->
- Reference e ->
+ (forall m. DBReadable m =>
+ Location (Reference ()) (Reference e) ->
+ m (Location (Reference ()) ())) ->
+ Reference e ->
DB ()
dbUnsafeDeleteObject f ref =
do _ <- dbMoveAllWithin f ref
@@ -333,47 +349,51 @@ dbUnsafeDeleteObject f ref =
db_creatures = Map.delete (unsafeReference ref) $ db_creatures db,
db_planes = Map.delete (unsafeReference ref) $ db_planes db,
db_tools = Map.delete (unsafeReference ref) $ db_tools db,
- db_hierarchy = HierarchicalDatabase.delete (toUID ref) $ db_hierarchy db,
+ db_hierarchy = HD.delete (toUID ref) $ db_hierarchy db,
db_time_coordinates = Map.delete (generalizeReference ref) $ db_time_coordinates db }
-- |
-- Puts an object into the database using getter and setter functions.
--
-dbPutObjectComposable :: (Ord a) => (DB_BaseType -> Map a b) ->
- (Map a b -> DB_BaseType -> DB_BaseType) ->
- a -> b ->
+dbPutObjectComposable :: (Ord a) => (DB_BaseType -> Map a b) ->
+ (Map a b -> DB_BaseType -> DB_BaseType) ->
+ a -> b ->
DB ()
-dbPutObjectComposable get_map_fn put_map_fn key thing =
+dbPutObjectComposable get_map_fn put_map_fn key thing =
modify (\db -> put_map_fn (Map.insert key thing $ get_map_fn db) db)
-- |
-- Puts a Creature under an arbitrary CreatureRef.
--
dbPutCreature :: CreatureRef -> Creature -> DB ()
-dbPutCreature = dbPutObjectComposable db_creatures (\x db_base_type -> db_base_type { db_creatures = x })
+dbPutCreature = dbPutObjectComposable db_creatures (\x db_base_type ->
+ db_base_type { db_creatures = x })
-- |
-- Puts a Plane under an arbitrary PlaneRef
--
dbPutPlane :: PlaneRef -> Plane -> DB ()
-dbPutPlane = dbPutObjectComposable db_planes (\x db_base_type -> db_base_type { db_planes = x })
+dbPutPlane = dbPutObjectComposable db_planes $
+ \x db_base_type -> db_base_type { db_planes = x }
-- |
-- Puts a Tool under an arbitrary ToolRef
--
dbPutTool :: ToolRef -> Tool -> DB ()
-dbPutTool = dbPutObjectComposable db_tools (\x db_base_type -> db_base_type { db_tools = x })
+dbPutTool = dbPutObjectComposable db_tools $
+ \x db_base_type -> db_base_type { db_tools = x }
-- |
-- Puts a Building under an arbitrary BuildingRef
--
dbPutBuilding :: BuildingRef -> Building -> DB ()
-dbPutBuilding = dbPutObjectComposable db_buildings (\x db_base_type -> db_base_type { db_buildings = x })
+dbPutBuilding = dbPutObjectComposable db_buildings $
+ \x db_base_type -> db_base_type { db_buildings = x }
-- |
-- Gets an object from the database using getter functions.
--
-dbGetObjectComposable :: (DBReadable db,Ord a,GenericReference a x) => String -> (DB_BaseType -> Map a b) -> a -> db b
+dbGetObjectComposable :: (DBReadable db,Ord a,GenericReference a) => String -> (DB_BaseType -> Map a b) -> a -> db b
dbGetObjectComposable type_info get_fn ref =
asks (fromMaybe (error $ "dbGetObjectComposable: Nothing. UID was " ++ show (toUID $ generalizeReference ref) ++ ", type info was " ++ type_info) . Map.lookup ref . get_fn)
@@ -404,7 +424,7 @@ dbGetBuilding = dbGetObjectComposable "BuildingRef" db_buildings
-- |
-- Modifies an Object based on an ObjectRef.
--
-dbModObjectComposable :: (Reference e -> DB e) -> (Reference e -> e -> DB ()) ->
+dbModObjectComposable :: (Reference e -> DB e) -> (Reference e -> e -> DB ()) ->
(e -> e) -> Reference e -> DB ()
dbModObjectComposable getter putter f ref = (putter ref . f) =<< (getter ref)
@@ -434,80 +454,93 @@ dbModBuilding = dbModObjectComposable dbGetBuilding dbPutBuilding
-- |
-- Set the location of an object.
--- 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.
---
-dbSetLocation :: (LocationType e,LocationType t) => Location S e t -> DB ()
-dbSetLocation loc =
- do case (fmap location $ coerceLocationTyped _wielded loc,fmap location $ coerceLocationTyped _subsequent loc) of
- (Just (Wielded c),_) -> dbUnwieldCreature c
- (_,Just (Subsequent b)) -> mapM_ (dbSetLocation . (InTheUniverse :: PlaneRef -> Location S PlaneRef TheUniverse)) =<< dbGetContents b
- (_,_) -> return ()
- modify (\db -> db { db_hierarchy=HierarchicalDatabase.insert (unsafeLocation loc) $ db_hierarchy db })
+-- 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.
+--
+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
+ (_,_,_) -> return ()
+ modify (\db -> db { db_hierarchy = HD.insert (unsafeLocation loc) $ db_hierarchy db })
-- |
-- Shunt any wielded objects into inventory.
--
dbUnwieldCreature :: CreatureRef -> DB ()
-dbUnwieldCreature c = mapM_ (dbSetLocation . returnToInventory) =<< dbGetContents c
+dbUnwieldCreature c = mapM_ (dbSetLocation . returnToInventory) =<<
+ dbGetContents c
+
+-- |
+-- Shunt a subordinate plane in the specified position to TheUniverse.
+--
+shuntPlane :: (LocationParent p) => Type p -> PlaneRef -> DB ()
+shuntPlane t p = mapM_ (dbSetLocation . shuntToTheUniverse t) =<<
+ dbGetContents p
-- |
-- Moves an object, returning the location of the object before and after
-- the move.
--
-dbMove :: (ReferenceType e, LocationType (Reference e),LocationType b) =>
- (forall m. DBReadable m => Location M (Reference e) () -> m (Location M (Reference e) b)) ->
+dbMove :: (ReferenceType e, LocationChild (Reference e),LocationParent b) =>
+ (forall m. DBReadable m => Location (Reference e) () ->
+ m (Location (Reference e) b)) ->
(Reference e) ->
- DB (Location S (Reference e) (),Location S (Reference e) b)
+ DB (Location (Reference e) (),Location (Reference e) b)
dbMove moveF ref =
do old <- dbWhere ref
new <- ro $ moveF (unsafeLocation old)
- dbSetLocation $ generalizeLocationRecord $ unsafeLocation new
- when (getLocation old =/= getLocation 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 (getLocation new)
+ dbSetLocation (unsafeLocation new :: Location (Reference ()) ())
+ 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)
dbMoveAllWithin :: (forall m. DBReadable m =>
- Location M (Reference ()) (Reference e) ->
- m (Location M (Reference ()) ())) ->
+ Location (Reference ()) (Reference e) ->
+ m (Location (Reference ()) ())) ->
Reference e ->
- DB [(Location S (Reference ()) (Reference e),Location S (Reference ()) ())]
+ DB [(Location (Reference ()) (Reference e),Location (Reference ()) ())]
dbMoveAllWithin f ref = mapM (liftM (first unsafeLocation) . dbMove (f . unsafeLocation)) =<< dbGetContents ref
-- |
-- Verifies that a reference is in the database.
--
dbVerify :: (DBReadable db) => Reference e -> db Bool
-dbVerify ref = asks (isJust . HierarchicalDatabase.parentOf (toUID ref) . db_hierarchy)
+dbVerify ref = asks (isJust . HD.parentOf (toUID ref) . db_hierarchy)
-- |
-- Returns the location of this object.
--
-dbWhere :: (DBReadable db) => Reference e -> db (Location S (Reference e) ())
+dbWhere :: (DBReadable db) => Reference e -> db (Location (Reference e) ())
dbWhere item = asks (unsafeLocation . fromMaybe (error "dbWhere: has no location") .
- HierarchicalDatabase.lookupParent (toUID item) . db_hierarchy)
+ HD.lookupParent (toUID item) . db_hierarchy)
-- |
-- Returns all ancestor Locations of this element starting with the location
-- of the element and ending with theUniverse.
--
-dbGetAncestors :: (DBReadable db,ReferenceType e) => Reference e -> db [Location S (Reference ()) ()]
+dbGetAncestors :: (DBReadable db,ReferenceType e) => Reference e -> db [Location (Reference ()) ()]
dbGetAncestors ref | isReferenceTyped _the_universe ref = return []
dbGetAncestors ref =
do this <- dbWhere $ generalizeReference ref
- rest <- dbGetAncestors $ getLocation this
+ rest <- dbGetAncestors $ genericParent this
return $ this : rest
-- |
-- Returns the location records of this object.
--
-dbGetContents :: (DBReadable db,GenericReference a S) => Reference t -> db [a]
-dbGetContents item = asks (Data.Maybe.mapMaybe fromLocation . HierarchicalDatabase.lookupChildren
+dbGetContents :: (DBReadable db,GenericReference a) => Reference t -> db [a]
+dbGetContents item = asks (Data.Maybe.mapMaybe fromLocation . HD.lookupChildren
(toUID item) . db_hierarchy)
-- |
-- Gets the time of an object.
---
+--
dbGetTimeCoordinate :: (DBReadable db,ReferenceType a) => Reference a -> db TimeCoordinate
dbGetTimeCoordinate ref = asks (fromMaybe (error "dbGetTimeCoordinate: missing time coordinate.") .
Map.lookup (generalizeReference ref) . db_time_coordinates)
@@ -535,16 +568,16 @@ dbNextTurn refs =
Map.lookup (generalizeReference r) (db_time_coordinates db))) refs)
-- |
--- Answers the starting race.
+-- Answers the starting species.
--
-dbGetStartingRace :: DB (Maybe Species)
-dbGetStartingRace = do gets db_starting_race
+dbGetStartingSpecies :: DB (Maybe Species)
+dbGetStartingSpecies = do gets db_starting_species
-- |
--- Sets the starting race.
+-- Sets the starting species.
--
-dbSetStartingRace :: Species -> DB ()
-dbSetStartingRace the_species = modify (\db -> db { db_starting_race = Just the_species })
+dbSetStartingSpecies :: Species -> DB ()
+dbSetStartingSpecies the_species = modify (\db -> db { db_starting_species = Just the_species })
-- |
-- Takes a snapshot of a SnapshotEvent in progress.
@@ -565,14 +598,8 @@ dbHasSnapshot :: (DBReadable db) => db Bool
dbHasSnapshot = liftM isJust $ dbPeepSnapshot (return ())
popOldestSnapshot :: DB_BaseType -> DB_BaseType
-popOldestSnapshot db =
+popOldestSnapshot db =
case isJust $ db_prior_snapshot =<< db_prior_snapshot db of
False -> db { db_prior_snapshot = Nothing }
- True -> db { db_prior_snapshot = fmap popOldestSnapshot $ db_prior_snapshot db }
-
--- | Print a debug/trace message from DB.
-{-# NOINLINE dbTrace #-}
-dbTrace :: (DBReadable db) => String -> db ()
-dbTrace s =
- do db <- ask
- trace ("trace (object count " ++ show (db_next_object_ref db) ++ ") : " ++ s) $ return ()
+ True -> db { db_prior_snapshot = fmap popOldestSnapshot $ db_prior_snapshot db }
+
diff --git a/src/DBData.hs b/src/DBData.hs
index 37c953e..17acd89 100644
--- a/src/DBData.hs
+++ b/src/DBData.hs
@@ -1,4 +1,8 @@
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances,
+ MultiParamTypeClasses,
+ FunctionalDependencies,
+ UndecidableInstances,
+ ScopedTypeVariables #-}
module DBData
(Reference,
@@ -11,9 +15,9 @@ module DBData
the_universe,
(=:=), (=/=),
GenericReference(..),
- locationsOf,
ReferenceType(..),
- LocationType(..),
+ LocationChild(..),
+ LocationParent(..),
Location,
Position(..),
Standing(..),
@@ -22,6 +26,8 @@ module DBData
Wielded(..),
Constructed(..),
Subsequent(..),
+ Beneath(..),
+ Type,
_nullary,
_creature,
_tool,
@@ -33,34 +39,35 @@ module DBData
_wielded,
_constructed,
_subsequent,
+ _beneath,
_position,
_multiposition,
_facing,
_the_universe,
asLocationTyped,
- asReferenceTyped,
- DBPrivate.S,
- location,
- entity,
+ asType,
+ parent,
+ child,
coerceReferenceTyped,
isReferenceTyped,
- coerceLocationTyped,
- isLocationTyped,
- coerceEntityTyped,
- isEntityTyped,
+ coerceParentTyped,
+ isParentTyped,
+ coerceChildTyped,
+ isChildTyped,
coerceLocationRecord,
- coerceLocation,
- coerceEntity,
- getLocation,
- getEntity,
+ coerceParent,
+ coerceChild,
+ genericParent,
+ genericChild,
+ generalizeParent,
+ generalizeChild,
generalizeLocation,
- generalizeEntity,
- generalizeLocationRecord,
toStanding,
toDropped,
toInventory,
toWielded,
- returnToInventory)
+ returnToInventory,
+ shuntToTheUniverse)
where
import Facing
@@ -111,6 +118,9 @@ _constructed = Type $ error "_constructed: undefined"
_subsequent :: Type Subsequent
_subsequent = Type $ error "_subsequent: undefined"
+_beneath :: Type Beneath
+_beneath = Type $ error "_subsequent: undefined"
+
_position :: Type Position
_position = Type $ error "_position: undefined"
@@ -126,35 +136,32 @@ _the_universe = Type $ error "_the_universe: undefined"
--
-- Getting References generically.
--
-class GenericReference a m | a -> m where
- fromLocation :: (ReferenceType x) => Location m (Reference x) b -> Maybe a
+class GenericReference a where
+ fromLocation :: (ReferenceType x) => Location (Reference x) b -> Maybe a
generalizeReference :: a -> Reference ()
-instance (GenericReference a m,GenericReference b m) => GenericReference (Either a b) m where
+instance (GenericReference a,GenericReference b) => GenericReference (Either a b) where
fromLocation x = case (fromLocation x,fromLocation x) of
(Just a,_) -> Just $ Left a
(_,Just b) -> Just $ Right b
_ | otherwise -> Nothing
generalizeReference = either generalizeReference generalizeReference
-instance (ReferenceType a) => GenericReference (Reference a) m where
- fromLocation = coerceReference . entity
+instance (ReferenceType a) => GenericReference (Reference a) where
+ fromLocation = coerceReference . genericChild
generalizeReference = unsafeReference
-instance (LocationType a,LocationType b) => GenericReference (Location m a b) m where
+instance (LocationChild c,LocationParent p) => GenericReference (Location c p) where
fromLocation = coerceLocationRecord
- generalizeReference = getEntity
-
-locationsOf :: (Monad m,LocationType a) => m [Location S (Reference ()) a] -> m [a]
-locationsOf = liftM (map location)
+ generalizeReference = genericChild
--
-- Reference Equality
--
-(=:=) :: (GenericReference a m,GenericReference b n) => a -> b -> Bool
+(=:=) :: (GenericReference a,GenericReference b) => a -> b -> Bool
a =:= b = generalizeReference a == generalizeReference b
-(=/=) :: (GenericReference a m,GenericReference b n) => a -> b -> Bool
+(=/=) :: (GenericReference a,GenericReference b) => a -> b -> Bool
a =/= b = not $ a =:= b
--
@@ -199,167 +206,186 @@ instance ReferenceType TheUniverse where
--
-- Locations
--
-generalizeLocationRecord :: Location m e t -> Location m (Reference ()) ()
-generalizeLocationRecord = unsafeLocation
-
-generalizeLocation :: Location m e t -> Location m e ()
+generalizeLocation :: Location e t -> Location (Reference ()) ()
generalizeLocation = unsafeLocation
-generalizeEntity :: Location m e t -> Location m (Reference ()) t
-generalizeEntity = unsafeLocation
-
-getLocation :: Location m e t -> Reference ()
-getLocation (IsStanding _ s) = unsafeReference $ standing_plane s
-getLocation (IsDropped _ d) = unsafeReference $ dropped_plane d
-getLocation (InInventory _ c) = unsafeReference $ inventory_creature c
-getLocation (IsWielded _ c) = unsafeReference $ wielded_creature c
-getLocation (IsConstructed _ c) = unsafeReference $ constructed_plane c
-getLocation (InTheUniverse _) = unsafeReference UniverseRef
-getLocation (IsSubsequent _ b) = unsafeReference $ subsequent_to b
-
-getEntity :: Location m e t -> Reference ()
-getEntity (IsStanding r _) = unsafeReference r
-getEntity (IsDropped r _) = unsafeReference r
-getEntity (InInventory r _) = unsafeReference r
-getEntity (IsWielded r _) = unsafeReference r
-getEntity (IsConstructed r _) = unsafeReference r
-getEntity (InTheUniverse r) = unsafeReference r
-getEntity (IsSubsequent r _) = unsafeReference r
-
-asLocationTyped :: (LocationType e,LocationType t) => Type e -> Type t -> Location m e t -> Location m e t
+generalizeParent :: Location e t -> Location e ()
+generalizeParent = unsafeLocation
+
+generalizeChild :: Location e t -> Location (Reference ()) t
+generalizeChild = unsafeLocation
+
+genericParent :: Location e t -> Reference ()
+genericParent (IsStanding _ s) = unsafeReference $ standing_plane s
+genericParent (IsDropped _ d) = unsafeReference $ dropped_plane d
+genericParent (InInventory _ c) = unsafeReference $ inventory_creature c
+genericParent (IsWielded _ c) = unsafeReference $ wielded_creature c
+genericParent (IsConstructed _ c) = unsafeReference $ constructed_plane c
+genericParent (InTheUniverse _) = unsafeReference UniverseRef
+genericParent (IsSubsequent _ b) = unsafeReference $ subsequent_to b
+genericParent (IsBeneath _ b) = unsafeReference $ beneath_of b
+
+genericChild :: Location e t -> Reference ()
+genericChild (IsStanding r _) = unsafeReference r
+genericChild (IsDropped r _) = unsafeReference r
+genericChild (InInventory r _) = unsafeReference r
+genericChild (IsWielded r _) = unsafeReference r
+genericChild (IsConstructed r _) = unsafeReference r
+genericChild (InTheUniverse r) = unsafeReference r
+genericChild (IsSubsequent r _) = unsafeReference r
+genericChild (IsBeneath r _) = unsafeReference r
+
+asLocationTyped :: (LocationChild e,LocationParent t) =>
+ Type e -> Type t -> Location e t -> Location e t
asLocationTyped _ _ = id
-asReferenceTyped :: (LocationType e) => Type e -> e -> e
-asReferenceTyped _ = id
-
-coerceLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Maybe (Location m e t)
-coerceLocationTyped = const coerceLocation
-
-isLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Bool
-isLocationTyped t = isJust . coerceLocationTyped t
-
-coerceEntityTyped :: (LocationType e,LocationType t) => Type e -> Location m x t -> Maybe (Location m e t)
-coerceEntityTyped = const coerceEntity
-
-isEntityTyped :: (LocationType e,LocationType t) => Type e -> Location m x t -> Bool
-isEntityTyped t = isJust . coerceEntityTyped t
-
-coerceLocation :: (LocationType e,LocationType t) => Location m e x -> Maybe (Location m e t)
-coerceLocation = coerceLocationRecord
-
-coerceEntity :: (LocationType e,LocationType t) => Location m x t -> Maybe (Location m e t)
-coerceEntity = coerceLocationRecord
-
-coerceLocationRecord :: (LocationType e,LocationType t) => Location m x y -> Maybe (Location m e t)
-coerceLocationRecord = fmap fst . coerceUnify
- where coerceUnify :: (LocationType e,LocationType t) =>
- Location m x y -> Maybe (Location m e t,(e,t))
- coerceUnify l = do t <- extractLocation l
- e <- extractEntity l
- return (unsafeLocation l,(e,t))
-
-location :: (LocationType t) => Location m e t -> t
-location l = fromMaybe (error "location: type error") $ extractLocation l
-
-entity :: (LocationType e) => Location m e t -> e
-entity l = fromMaybe (error "entity: type error") $ extractEntity l
-
-class (Eq a,Ord a) => LocationType a where
- extractLocation :: Location m e t -> Maybe a
- extractEntity :: Location m e t -> Maybe a
-
-instance LocationType Standing where
- extractLocation (IsStanding _ s) = Just s
- extractLocation _ = Nothing
- extractEntity = const Nothing
-
-instance LocationType Dropped where
- extractLocation (IsDropped _ d) = Just d
- extractLocation _ = Nothing
- extractEntity = const Nothing
-
-instance LocationType Inventory where
- extractLocation (InInventory _ i) = Just i
- extractLocation _ = Nothing
- extractEntity = const Nothing
-
-instance LocationType Wielded where
- extractLocation (IsWielded _ i) = Just i
- extractLocation _ = Nothing
- extractEntity = const Nothing
-
-instance LocationType Constructed where
- extractLocation (IsConstructed _ i) = Just i
- extractLocation _ = Nothing
- extractEntity = const Nothing
-
-instance LocationType TheUniverse where
- extractLocation (InTheUniverse {}) = Just TheUniverse
- extractLocation _ = Nothing
- extractEntity = const Nothing
-
-instance LocationType Subsequent where
- extractLocation (IsSubsequent _ i) = Just i
- extractLocation _ = Nothing
- extractEntity = const Nothing
-
-instance LocationType () where
- extractLocation = const $ Just ()
- extractEntity = const Nothing
-
-instance LocationType Position where
- extractLocation (IsStanding _ s) = Just $ standing_position s
- extractLocation (IsDropped _ d) = Just $ dropped_position d
- extractLocation (InInventory {}) = Nothing
- extractLocation (IsWielded {}) = Nothing
- extractLocation (IsConstructed _ c) = Just $ constructed_position c
- extractLocation (InTheUniverse {}) = Nothing
- extractLocation (IsSubsequent {}) = Nothing
- extractEntity = const Nothing
-
-instance LocationType MultiPosition where
- extractLocation (IsConstructed _ c) = Just $ multiPosition (constructed_position c) (buildingOccupies $ constructed_type c)
- extractLocation x = fmap (toMultiPosition :: Position -> MultiPosition) $ extractLocation x
- extractEntity = const Nothing
-
-instance LocationType Facing where
- extractLocation (IsStanding _ s) = Just $ standing_facing s
- extractLocation (IsDropped {}) = Nothing
- extractLocation (InInventory {}) = Nothing
- extractLocation (IsWielded {}) = Nothing
- extractLocation (IsConstructed {}) = Nothing
- extractLocation (InTheUniverse {}) = Nothing
- extractLocation (IsSubsequent {}) = Nothing
- extractEntity = const Nothing
-
-instance ReferenceType a => LocationType (Reference a) where
- extractLocation = coerceReference . getLocation
- extractEntity = coerceReference . getEntity
-
-instance (LocationType a,LocationType b) => LocationType (a,b) where
- extractLocation l = liftM2 (,) (extractLocation l) (extractLocation l)
- extractEntity l = liftM2 (,) (extractEntity l) (extractEntity l)
+asType :: Type e -> e -> e
+asType _ = id
+
+coerceParentTyped :: (LocationParent p) =>
+ Type p -> Location c x -> Maybe (Location c p)
+coerceParentTyped = const coerceParent
+
+isParentTyped :: (LocationParent p) => Type p -> Location c x -> Bool
+isParentTyped t = isJust . coerceParentTyped t
+
+coerceChildTyped :: (LocationChild c) =>
+ Type c -> Location x p -> Maybe (Location c p)
+coerceChildTyped = const coerceChild
+
+isChildTyped :: (LocationChild c) => Type c -> Location x p -> Bool
+isChildTyped t = isJust . coerceChildTyped t
+
+coerceParent :: forall c x p. (LocationParent p) =>
+ Location c x -> Maybe (Location c p)
+coerceParent l =
+ do (_ :: p) <- extractParent l
+ return $ unsafeLocation l
+
+coerceChild :: forall x p c. (LocationChild c) =>
+ Location x p -> Maybe (Location c p)
+coerceChild l =
+ do (_ :: c) <- extractChild l
+ return $ unsafeLocation l
+
+coerceLocationRecord :: forall x y c p. (LocationChild c,LocationParent p) =>
+ Location x y -> Maybe (Location c p)
+coerceLocationRecord l =
+ do (_ :: p) <- extractParent l
+ (_ :: c) <- extractChild l
+ return $ unsafeLocation l
+
+parent :: (LocationParent p) => Location c p -> p
+parent l = fromMaybe (error "parent: type error") $ extractParent l
+
+child :: (LocationChild c) => Location c p -> c
+child l = fromMaybe (error "child: type error") $ extractChild l
+
+class (Eq a,Ord a) => LocationParent a where
+ extractParent :: Location e t -> Maybe a
+
+class (Eq a,Ord a) => LocationChild a where
+ extractChild :: Location e t -> Maybe a
+
+instance LocationParent Standing where
+ extractParent (IsStanding _ s) = Just s
+ extractParent _ = Nothing
+
+instance LocationParent Dropped where
+ extractParent (IsDropped _ d) = Just d
+ extractParent _ = Nothing
+
+instance LocationParent Inventory where
+ extractParent (InInventory _ i) = Just i
+ extractParent _ = Nothing
+
+instance LocationParent Wielded where
+ extractParent (IsWielded _ i) = Just i
+ extractParent _ = Nothing
+
+instance LocationParent Constructed where
+ extractParent (IsConstructed _ i) = Just i
+ extractParent _ = Nothing
+
+instance LocationParent TheUniverse where
+ extractParent (InTheUniverse {}) = Just TheUniverse
+ extractParent _ = Nothing
+
+instance LocationParent Subsequent where
+ extractParent (IsSubsequent _ i) = Just i
+ extractParent _ = Nothing
+
+instance LocationParent Beneath where
+ extractParent (IsBeneath _ i) = Just i
+ extractParent _ = Nothing
+
+instance LocationParent () where
+ extractParent = const $ Just ()
+
+instance LocationParent Position where
+ extractParent (IsStanding _ s) = Just $ standing_position s
+ extractParent (IsDropped _ d) = Just $ dropped_position d
+ extractParent (InInventory {}) = Nothing
+ extractParent (IsWielded {}) = Nothing
+ extractParent (IsConstructed _ c) = Just $ constructed_position c
+ extractParent (InTheUniverse {}) = Nothing
+ extractParent (IsSubsequent {}) = Nothing
+ extractParent (IsBeneath {}) = Nothing
+
+instance LocationParent MultiPosition where
+ extractParent (IsConstructed _ c) = Just $ multiPosition (constructed_position c) (buildingOccupies $ constructed_type c)
+ extractParent x = fmap (toMultiPosition :: Position -> MultiPosition) $ extractParent x
+
+instance LocationParent Facing where
+ extractParent (IsStanding _ s) = Just $ standing_facing s
+ extractParent (IsDropped {}) = Nothing
+ extractParent (InInventory {}) = Nothing
+ extractParent (IsWielded {}) = Nothing
+ extractParent (IsConstructed {}) = Nothing
+ extractParent (InTheUniverse {}) = Nothing
+ extractParent (IsSubsequent {}) = Nothing
+ extractParent (IsBeneath {}) = Nothing
+
+instance ReferenceType a => LocationParent (Reference a) where
+ extractParent = coerceReference . genericParent
+
+instance ReferenceType a => LocationChild (Reference a) where
+ extractChild = coerceReference . genericChild
+
+instance (LocationParent a,LocationParent b) => LocationParent (a,b) where
+ extractParent l = liftM2 (,) (extractParent l) (extractParent l)
+
+instance (LocationChild a,LocationChild b) => LocationChild (a,b) where
+ extractChild l = liftM2 (,) (extractChild l) (extractChild l)
--
-- Manipulating Locations
--
-toStanding :: (LocationType t) => Standing -> Location m CreatureRef t -> Location m CreatureRef Standing
-toStanding s l | isEntityTyped _creature l = IsStanding (entity l) s
+toStanding :: (LocationParent t) =>
+ Standing ->
+ Location CreatureRef t ->
+ Location CreatureRef Standing
+toStanding s l | isChildTyped _creature l = IsStanding (child l) s
toStanding _ _ = error "toStanding: type error"
-toDropped :: (LocationType t) => Dropped -> Location m ToolRef t -> Location m ToolRef Dropped
-toDropped d l | isEntityTyped _tool l = IsDropped (entity l) d
+toDropped :: (LocationParent t) => Dropped -> Location ToolRef t -> Location ToolRef Dropped
+toDropped d l | isChildTyped _tool l = IsDropped (child l) d
toDropped _ _ = error "toDropped: type error"
-toInventory :: (LocationType t) => Inventory -> Location m ToolRef t -> Location m ToolRef Inventory
-toInventory i l | isEntityTyped _tool l = InInventory (entity l) i
+toInventory :: (LocationParent t) => Inventory -> Location ToolRef t -> Location ToolRef Inventory
+toInventory i l | isChildTyped _tool l = InInventory (child l) i
toInventory _ _ = error "toInventory: type error"
-toWielded :: (LocationType t) => Wielded -> Location m ToolRef t -> Location m ToolRef Wielded
-toWielded i l | isEntityTyped _tool l = IsWielded (entity l) i
+toWielded :: (LocationParent t) => Wielded -> Location ToolRef t -> Location ToolRef Wielded
+toWielded i l | isChildTyped _tool l = IsWielded (child l) i
toWielded _ _ = error "toWielded: type error"
-returnToInventory :: Location m ToolRef Wielded -> Location m ToolRef Inventory
-returnToInventory l = InInventory (entity l) (Inventory c)
- where Wielded c = location l
+returnToInventory :: Location ToolRef Wielded -> Location ToolRef Inventory
+returnToInventory l = InInventory (child l) (Inventory c)
+ where Wielded c = parent l
+
+shuntToTheUniverse :: Type p ->
+ Location PlaneRef p ->
+ Location PlaneRef TheUniverse
+shuntToTheUniverse _ l = InTheUniverse (child l)
diff --git a/src/DBErrorFlag.hs b/src/DBErrorFlag.hs
index 726ab83..72c88bb 100644
--- a/src/DBErrorFlag.hs
+++ b/src/DBErrorFlag.hs
@@ -6,7 +6,7 @@ data ErrorFlag =
BuildingApproachWrongAngle -- some buildings (like stargates) are sensitive to the angle of approach
| NothingAtFeet -- tried to pick something up, but there is nothing at your feet
| NothingInInventory -- tried to perform an inventory action, but your inventory is empty
- | NotStanding -- the player is not standing on anything (e.g. race selection state)
+ | NotStanding -- the player is not standing on anything (e.g. species selection state)
| NoStargateAddress -- tried to move through the stargate network, but there was no destination
| 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
diff --git a/src/DBPrivate.hs b/src/DBPrivate.hs
index 8b2a760..4f70931 100644
--- a/src/DBPrivate.hs
+++ b/src/DBPrivate.hs
@@ -5,8 +5,6 @@ module DBPrivate
unsafeReference,
toUID,
Location(..),
- M,
- S,
unsafeLocation,
Position(..),
Standing(..),
@@ -16,6 +14,7 @@ module DBPrivate
Constructed(..),
TheUniverse(..),
Subsequent(..),
+ Beneath(..),
CreatureRef,
ToolRef,
PlaneRef,
@@ -35,9 +34,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 code should not
--- import DBPrivate since it could break the restrictions otherwise placed on
--- the type system.
+-- DB and DBData import and re-export most of DBPrivate. Other modules should not
+-- import DBPrivate.
--
-- |
@@ -74,7 +72,7 @@ toUID a = uid a
-- |
-- The location of a Creature standing on a Plane.
--
-data Standing =
+data Standing =
Standing { standing_plane :: PlaneRef,
standing_position :: Position,
standing_facing :: Facing }
@@ -83,7 +81,7 @@ data Standing =
-- |
-- The location of a Tool dropped on a Plane.
--
-data Dropped =
+data Dropped =
Dropped { dropped_plane :: PlaneRef,
dropped_position :: Position }
deriving (Read,Show,Eq,Ord)
@@ -119,42 +117,31 @@ data Subsequent =
deriving (Read,Show,Eq,Ord)
-- |
--- A relational data structure defining the location of any entity.
--- All of the type variables of Location are phantom types.
---
--- m represents the modification domain of the Location. Location M is
--- a location of an moving entity, while Location S is the location of
--- a static entity.
---
--- The M parameter ensures that the entity's identity can not be changed
--- when moving an entity, e.g. Robert can not turn into Susan by walking across the street.
--- No function Location M e t -> Location M e t can be written that
--- changes the what entity the location references.
+-- The location of a dungeon plane.
--
--- Thus, we accept functions of the type
--- (Location M e a -> Location M e b) -> DB (),
--- to move an object, a functions of the type
--- DB (Location S () ()) to get the location of an object.
+data Beneath =
+ Beneath { beneath_of :: PlaneRef }
+ deriving (Read,Show,Eq,Ord)
+
+-- |
+-- A relational data structure defining the location of any entity.
--
--- e represents the type of entity, such as a Creature or Tool.
+-- c represents the type of the child entity, such as a Creature or Tool.
--
--- t represents the type of location, such as Standing or Dropped.
+-- p represents the type of the parent location, such as Standing or Dropped.
--
-data M
-
-data S
-
-data Location m e t =
- IsStanding CreatureRef Standing
+data Location e t =
+ IsStanding CreatureRef Standing
| IsDropped ToolRef Dropped
| InInventory ToolRef Inventory
| IsWielded ToolRef Wielded
| IsConstructed BuildingRef Constructed
| InTheUniverse PlaneRef
| IsSubsequent PlaneRef Subsequent
- deriving (Read,Show,Eq,Ord)
+ | IsBeneath PlaneRef Beneath
+ deriving (Read,Show,Eq)
-unsafeLocation :: Location a b c -> Location d e f
+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
@@ -162,8 +149,9 @@ 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 m e t) where
+instance HierarchicalRelation (Location e t) where
parent (IsStanding _ t) = toUID $ standing_plane t
parent (IsDropped _ t) = toUID $ dropped_plane t
parent (InInventory _ t) = toUID $ inventory_creature t
@@ -171,6 +159,7 @@ instance HierarchicalRelation (Location m e t) where
parent (IsConstructed _ t) = toUID $ constructed_plane t
parent (InTheUniverse _) = toUID UniverseRef
parent (IsSubsequent _ t) = toUID $ subsequent_to t
+ parent (IsBeneath _ t) = toUID $ beneath_of t
child (IsStanding e _) = toUID e
child (IsDropped e _) = toUID e
child (InInventory e _) = toUID e
@@ -178,3 +167,5 @@ instance HierarchicalRelation (Location m e t) where
child (IsConstructed e _) = toUID e
child (InTheUniverse e) = toUID e
child (IsSubsequent e _) = toUID e
+ child (IsBeneath e _) = toUID e
+
diff --git a/src/Grids.hs b/src/Grids.hs
index 7ca0ada..4d2a7e6 100644
--- a/src/Grids.hs
+++ b/src/Grids.hs
@@ -31,8 +31,8 @@ seededGrid n = SeededGrid n
seededLookup :: SeededGrid -> (Integer,Integer) -> Integer
seededLookup (SeededGrid n) (x,y) = toInteger $ fst $ next $ mkRNG $
- (fst $ next $ mkRNG (fromInteger $ x `mod` max_int)) +
- (fst $ next $ mkRNG (fromInteger $ y `mod` max_int)) +
+ (fst $ next $ mkRNG (fromInteger $ (x*809) `mod` max_int)) +
+ (fst $ next $ mkRNG (fromInteger $ (y*233) `mod` max_int)) +
(fromInteger $ n `mod` max_int)
where max_int = toInteger (maxBound :: Int)
@@ -56,19 +56,19 @@ data Grid a = CompletelyRandomGrid {
gridAt :: (Ord a) => Grid a -> (Integer,Integer) -> a
gridAt (CompletelyRandomGrid seeded weights) at = fst $ weightedPick weights (mkRNG $ seededLookup seeded at)
-gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) =
+gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) =
let here = gridAt grid (x `div` 2,y `div` 2)
- there = gridAt grid (x `div` 2 + 1,y `div` 2 + 1)
- there_x = gridAt grid (x `div` 2 + 1,y `div` 2)
- there_y = gridAt grid (x `div` 2,y `div` 2 + 1)
- interpolate a1 a2 = fst $ weightedPick (interpolation_map ! (a1,a2)) (mkRNG $ seededLookup seeded at)
- in case (even x,even y) of
- (True,True) -> here
- (True,False) -> (interpolate here there_y)
- (False,True) -> (interpolate here there_x)
- (False,False) -> (interpolate here there)
-
-gridAt (ArbitraryReplacementGrid seeded sources replacements grid) at =
+ there = gridAt grid (x `div` 2 + 1,y `div` 2 + 1)
+ there_x = gridAt grid (x `div` 2 + 1,y `div` 2)
+ there_y = gridAt grid (x `div` 2,y `div` 2 + 1)
+ interpolate a1 a2 = fst $ weightedPick (interpolation_map ! (a1,a2)) (mkRNG $ seededLookup seeded at)
+ in case (even x,even y) of
+ (True,True) -> here
+ (True,False) -> (interpolate here there_y)
+ (False,True) -> (interpolate here there_x)
+ (False,False) -> (interpolate here there)
+
+gridAt (ArbitraryReplacementGrid seeded sources replacements grid) at =
case fmap fst $ find ((== here) . snd) sources of
Just frequency | (seededLookup seeded at `mod` denominator frequency < numerator frequency) ->
fst $ weightedPick replacements (mkRNG $ seededLookup seeded at)
diff --git a/src/Logging.hs b/src/Logging.hs
new file mode 100644
index 0000000..c4eed50
--- /dev/null
+++ b/src/Logging.hs
@@ -0,0 +1,22 @@
+module Logging
+ (log_database,
+ log_plane,
+ log_travel,
+ log_turns,
+ module System.Log.Logger)
+ where
+
+import System.Log.Logger
+
+log_database :: String
+log_database = "engine.database"
+
+log_plane :: String
+log_plane = "engine.plane"
+
+log_travel :: String
+log_travel = "engine.travel"
+
+log_turns :: String
+log_turns = "engine.turns"
+
diff --git a/src/Main.hs b/src/Main.hs
index e28922c..4ba0351 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,6 +12,7 @@ import GridRayCaster
import Data.Version
import Paths_roguestar_engine
import Data.List (intersperse)
+import System.Log.Logger
roguestar_version_number :: String
roguestar_version_number = concat $
@@ -28,38 +29,45 @@ roguestar_id_string = (roguestar_program_name ++ " " ++ roguestar_version_number
--
runByArgs :: String -> IO ()
-runByArgs "tests" = do testsPassed <- runAllTests ([sampleTestCase] ++
- insidenessTests ++
- gridRayCasterTests)
- if testsPassed
- then putStrLn "All tests passed."
- else putStrLn "Error: a test failed."
+runByArgs "tests" =
+ do testsPassed <- runAllTests ([sampleTestCase] ++
+ insidenessTests ++
+ gridRayCasterTests)
+ if testsPassed
+ then putStrLn "All tests passed."
+ else putStrLn "Error: a test failed."
runByArgs "version" = do putStrLn roguestar_id_string
-runByArgs "test-terrain-generator" = do seed <- randomIO
- let example_terrain = generateExampleTerrain seed
- in do putStrLn "Terrain Map of (-20..20),(-10..10)"
- mapM_ putStrLn $ prettyPrintTerrain ((-20,20),(-10,10)) example_terrain
- putStrLn "Terrain Map of (5460..5500),(-1010..-990)"
- mapM_ putStrLn $ prettyPrintTerrain ((5460,5500),(-1010,-990)) example_terrain
- putStrLn "Terrain Map of (5461..5501),(-1009..-989)"
- mapM_ putStrLn $ prettyPrintTerrain ((5461,5501),(-1009,-989)) example_terrain
+runByArgs "test-terrain-generator" =
+ do seed <- randomIO
+ let example_terrain = generateExampleTerrain seed
+ putStrLn "Terrain Map of (-20..20),(-10..10)"
+ mapM_ putStrLn $ prettyPrintTerrain ((-20,20),(-10,10)) example_terrain
+ putStrLn "Terrain Map of (5460..5500),(-1010..-990)"
+ mapM_ putStrLn $ prettyPrintTerrain ((5460,5500),(-1010,-990)) example_terrain
+ putStrLn "Terrain Map of (5461..5501),(-1009..-989)"
+ mapM_ putStrLn $ prettyPrintTerrain ((5461,5501),(-1009,-989)) example_terrain
runByArgs "begin" = mainLoop initial_db
runByArgs "over" = putStrLn "over"
-runByArgs "help" = do putStrLn "Commands:"
- putStrLn "begin - begin a protocol session (used by GUI clients and experts)"
- putStrLn "help - print this message"
- putStrLn "over - print \"over\" on a line by itself"
- putStrLn "tests - run a few tests"
- putStrLn "test-terrain-generator - display an example terrain map"
- putStrLn "version - print the version string"
+runByArgs "debug" = updateGlobalLogger rootLoggerName (setLevel DEBUG)
-runByArgs invalidArgument = do putStrLn ("Error: unrecognized argument: " ++ invalidArgument)
- fail "Unrecognized argument in runByArgs"
+runByArgs "help" =
+ do putStrLn "Commands:"
+ putStrLn "begin - begin a protocol session (used by GUI clients and experts)"
+ putStrLn "debug - set debugging verbosity"
+ putStrLn "help - print this message"
+ putStrLn "over - print \"over\" on a line by itself"
+ putStrLn "tests - run a few tests"
+ putStrLn "test-terrain-generator - display an example terrain map"
+ putStrLn "version - print the version string"
+
+runByArgs invalidArgument =
+ do putStrLn ("Error: unrecognized argument: " ++ invalidArgument)
+ fail "Unrecognized argument in runByArgs"
--
-- Each argument corresponds to a particular "runByArgs" command. Run them all in order.
@@ -68,3 +76,4 @@ main :: IO ()
main =
do args <- getArgs
mapM_ runByArgs args
+
diff --git a/src/NodeData.hs b/src/NodeData.hs
new file mode 100644
index 0000000..18e8031
--- /dev/null
+++ b/src/NodeData.hs
@@ -0,0 +1,13 @@
+module NodeData
+ (nodeEffect)
+ where
+
+import BuildingData
+import CreatureData
+import CharacterData
+import CharacterAdvancement
+
+nodeEffect :: NodeType -> CharacterBumpRequest
+nodeEffect Anchor = AwardCharacter 1
+nodeEffect Monolith = ForceCharacter StarChild
+
diff --git a/src/Perception.hs b/src/Perception.hs
index cb17090..75527d1 100644
--- a/src/Perception.hs
+++ b/src/Perception.hs
@@ -15,7 +15,8 @@ module Perception
Perception.getCreatureFaction,
whereAmI,
localBiome,
- compass)
+ compass,
+ depth)
where
import Control.Monad.Reader
@@ -32,6 +33,7 @@ import Position
import TerrainData
import BuildingData
import Building
+import Plane
newtype (DBReadable db) => DBPerception db a = DBPerception { fromPerception :: (ReaderT CreatureRef db a) }
@@ -67,11 +69,11 @@ whoAmI = DBPerception $ ask
runPerception :: (DBReadable db) => CreatureRef -> (forall m. DBReadable m => DBPerception m a) -> db a
runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref
-visibleObjects :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> DBPerception m Bool) -> DBPerception db [a]
+visibleObjects :: (DBReadable db,GenericReference a) => (forall m. DBReadable m => a -> DBPerception m Bool) -> DBPerception db [a]
visibleObjects filterF =
do me <- whoAmI
faction <- myFaction
- liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction (\a -> runPerception me $ filterF a) faction) =<< liftM extractLocation (dbWhere me)
+ liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction (\a -> runPerception me $ filterF a) faction) =<< liftM extractParent (dbWhere me)
myFaction :: (DBReadable db) => DBPerception db Faction
myFaction = Perception.getCreatureFaction =<< whoAmI
@@ -80,12 +82,12 @@ getCreatureFaction :: (DBReadable db) => CreatureRef -> DBPerception db Faction
getCreatureFaction creature_ref = liftDB $ Creature.getCreatureFaction creature_ref
whereAmI :: (DBReadable db) => DBPerception db (Facing,Position)
-whereAmI = liftM (fromMaybe (error "whereAmI: I'm not on a plane") . extractLocation) $ whereIs =<< whoAmI
+whereAmI = liftM (fromMaybe (error "whereAmI: I'm not on a plane") . extractParent) $ whereIs =<< whoAmI
whatPlaneAmIOn :: (DBReadable db) => DBPerception db PlaneRef
-whatPlaneAmIOn = liftM (fromMaybe (error "whatPlaneAmIOn: I'm not on a plane") . extractLocation) $ whereIs =<< whoAmI
+whatPlaneAmIOn = liftM (fromMaybe (error "whatPlaneAmIOn: I'm not on a plane") . extractParent) $ whereIs =<< whoAmI
-whereIs :: (DBReadable db) => Reference a -> DBPerception db (Location S (Reference a) ())
+whereIs :: (DBReadable db) => Reference a -> DBPerception db (Location (Reference a) ())
whereIs ref = liftDB $ dbWhere ref
localBiome :: (DBReadable db) => DBPerception db Biome
@@ -95,11 +97,17 @@ localBiome =
compass :: (DBReadable db) => DBPerception db Facing
compass =
- do let signalling_building_types = [Portal,Monolith]
+ do let signalling_building_types = [Portal] ++ map Node all_nodes
(_,pos) <- whereAmI
plane <- whatPlaneAmIOn
liftDB $
- do buildings <- liftM (sortBy $ comparing $ distanceBetweenSquared pos . location) $ filterM (liftM (`elem` signalling_building_types) . buildingType . entity) =<<
+ do buildings <- liftM (sortBy $ comparing $ distanceBetweenSquared pos . parent) $
+ filterM (liftM (`elem` signalling_building_types) . buildingType . child) =<<
dbGetContents plane
- return $ maybe Here (faceAt pos . location) $ listToMaybe buildings
-
+ return $ maybe Here (faceAt pos . parent) $ listToMaybe buildings
+
+depth :: (DBReadable db) => DBPerception db Integer
+depth =
+ do plane <- whatPlaneAmIOn
+ liftDB $ planeDepth plane
+
diff --git a/src/Plane.hs b/src/Plane.hs
index 8b5e272..801dc2e 100644
--- a/src/Plane.hs
+++ b/src/Plane.hs
@@ -2,11 +2,15 @@
module Plane
(dbNewPlane,
planetName,
+ randomPlanetName,
+ planeDepth,
dbGetCurrentPlane,
dbDistanceBetweenSquared,
pickRandomClearSite_withTimeout,
pickRandomClearSite,
getPlanarPosition,
+ getBeneath,
+ getSubsequent,
terrainAt,
setTerrainAt,
whatIsOccupying,
@@ -25,52 +29,77 @@ import Position
import PlayerState
import FactionData
import qualified Data.ByteString.Char8 as B
+import Logging
-dbNewPlane :: (PlaneLocation l) => Maybe B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef
-dbNewPlane name tg_data l =
+dbNewPlane :: (PlaneLocation l) => B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef
+dbNewPlane name tg_data l =
do rns <- getRandoms
random_id <- getRandomR (1,1000000)
- random_name <- randomPlanetName PanGalacticTreatyOrganization
dbAddPlane (Plane { plane_biome = tg_biome tg_data,
plane_terrain = generateTerrain tg_data rns,
plane_random_id = random_id,
- plane_planet_name = fromMaybe random_name name}) l
+ plane_planet_name = name}) l
planetName :: (DBReadable db) => PlaneRef -> db B.ByteString
planetName = liftM plane_planet_name . dbGetPlane
randomPlanetName :: (DBReadable db) => Faction -> db B.ByteString
-randomPlanetName faction =
+randomPlanetName faction =
do planet_number <- getRandomR (1000 :: Integer,9999)
return $ factionPrefix faction `B.append` "-" `B.append` B.pack (show planet_number)
+planeDepth :: (DBReadable db) => PlaneRef -> db Integer
+planeDepth this_plane =
+ do l <- dbWhere this_plane
+ case extractParent l of
+ Just (Beneath above) -> liftM succ $ planeDepth above
+ Nothing -> return 0
+
-- |
-- If this object is anywhere on a plane (such as carried by a creature who is on the plane),
-- returns the position of this object on that plane.
+-- TODO: this function seems generic enough that it should be moved and renamed.
--
-getPlanarPosition :: (DBReadable db,ReferenceType a,LocationType p) => Reference a -> db (Maybe (Location S (Reference ()) p))
+getPlanarPosition :: (DBReadable db,ReferenceType a,LocationParent p) =>
+ Reference a -> db (Maybe (Location (Reference ()) p))
getPlanarPosition ref =
liftM (listToMaybe . mapMaybe coerceLocationRecord) $ dbGetAncestors ref
-- |
+-- Get the plane beneath this one, if it exists.
+--
+getBeneath :: (DBReadable db) => PlaneRef -> db (Maybe PlaneRef)
+getBeneath item =
+ do (plane_locs :: [Location PlaneRef Beneath]) <- dbGetContents item
+ return $ fmap child $ listToMaybe plane_locs
+
+-- |
+-- Get the plane subsequent to this one, if it exists.
+--
+getSubsequent :: (DBReadable db) => PlaneRef -> db (Maybe PlaneRef)
+getSubsequent item =
+ do (plane_locs :: [Location PlaneRef Subsequent]) <- dbGetContents item
+ return $ fmap child $ listToMaybe plane_locs
+
+-- |
-- Distance between two entities. If the entities are not on the same plane, or for some other reason it doesn't make
-- sense to ask their distance, the Nothing.
--
dbDistanceBetweenSquared :: (DBReadable db,ReferenceType a,ReferenceType b) => Reference a -> Reference b -> db (Maybe Integer)
dbDistanceBetweenSquared a_ref b_ref =
- do m_a <- liftM (fmap location) $ getPlanarPosition a_ref
- m_b <- liftM (fmap location) $ getPlanarPosition b_ref
+ do m_a <- liftM (fmap parent) $ getPlanarPosition a_ref
+ m_b <- liftM (fmap parent) $ getPlanarPosition b_ref
return $
do (p_a :: PlaneRef,a :: MultiPosition) <- m_a
- (p_b,b :: MultiPosition) <- m_b
- guard $ p_a == p_b
- return $ distanceBetweenSquared a b
+ (p_b,b :: MultiPosition) <- m_b
+ guard $ p_a == p_b
+ return $ distanceBetweenSquared a b
-- |
-- Gets the current plane of interest based on whose turn it is.
--
dbGetCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef)
-dbGetCurrentPlane = liftM (fmap location) $ maybe (return Nothing) getPlanarPosition . creatureOf =<< playerState
+dbGetCurrentPlane = liftM (fmap parent) $ maybe (return Nothing) getPlanarPosition . creatureOf =<< playerState
-- |
-- Selects sites at random until one seems reasonably clear. It begins at
@@ -81,50 +110,67 @@ dbGetCurrentPlane = liftM (fmap location) $ maybe (return Nothing) getPlanarPosi
-- only appropriate terrain (as defined by a predicate) within terrain_clear squares.
-- Distance is chessboard distance.
--
--- This function will expand the search radius liberally if encounters the slightest
+-- This function will gradually expand the search radius if encounters the slightest
-- difficulty finding a qualifying position. The search radius parameter is strictly advisory.
--
-- This function can take an optional timeout parameter (pickRandomClearSite_withTimeout). When used
-- without a timeout parameter, it may not terminate. The only possible cause of non-termination is that no
--- site satisfies the terrain predicate.
+-- site satisfies the terrain predicate. However, if satisfactory sites are sufficiently rare,
+-- extreme slowness is likely.
--
--- The timeout value should be a small integer greater or equal to one, since this function is exponential in the timeout value.
+-- The timeout value should be a small integer greater or equal to one, since this function becomes slow with large timeout values.
--
pickRandomClearSite :: (DBReadable db) =>
- Integer -> Integer -> Integer ->
- Position -> (TerrainPatch -> Bool) -> PlaneRef ->
+ Integer -> Integer -> Integer ->
+ Position -> (TerrainPatch -> Bool) -> PlaneRef ->
db Position
-pickRandomClearSite search_radius object_clear terrain_clear p terrainPredicate plane_ref = liftM (fromMaybe $ error "pickRandomClearSite: impossible") $
- pickRandomClearSite_withTimeout Nothing search_radius object_clear terrain_clear p terrainPredicate plane_ref
+pickRandomClearSite search_radius
+ object_clear
+ terrain_clear
+ p
+ terrainPredicate
+ plane_ref =
+ liftM (fromMaybe $ error "pickRandomClearSite: impossible") $
+ pickRandomClearSite_withTimeout Nothing
+ search_radius
+ object_clear
+ terrain_clear
+ p
+ terrainPredicate
+ plane_ref
-pickRandomClearSite_withTimeout :: (DBReadable db) =>
- Maybe Integer -> Integer -> Integer -> Integer ->
- Position -> (TerrainPatch -> Bool) -> PlaneRef ->
+pickRandomClearSite_withTimeout :: (DBReadable db) =>
+ Maybe Integer -> Integer -> Integer -> Integer ->
+ Position -> (TerrainPatch -> Bool) -> PlaneRef ->
db (Maybe Position)
pickRandomClearSite_withTimeout (Just x) _ _ _ _ _ _ | x <= 0 = return Nothing
pickRandomClearSite_withTimeout timeout search_radius object_clear terrain_clear (Position (start_x,start_y)) terrainPredicate plane_ref =
- do xys <- liftM2 (\a b -> map Position $ zip a b)
+ do logDB log_plane DEBUG $ "Searching for clear site . . ."
+ xys <- liftM2 (\a b -> map Position $ zip a b)
(mapM (\x -> liftM (+start_x) $ getRandomR (-x,x)) [1..search_radius])
(mapM (\x -> liftM (+start_y) $ getRandomR (-x,x)) [1..search_radius])
terrain <- liftM plane_terrain $ dbGetPlane plane_ref
- (clutter_locations :: [MultiPosition]) <- locationsOf $ dbGetContents plane_ref
- let terrainIsClear (Position (x,y)) =
+ clutter_locations <- liftM (map (parent .
+ asLocationTyped _nullary _multiposition)) $ dbGetContents plane_ref
+ let terrainIsClear (Position (x,y)) =
all terrainPredicate $
- concat [[gridAt terrain (x',y') |
+ concat [[gridAt terrain (x',y') |
x' <- [x-terrain_clear..x+terrain_clear]] |
- y' <- [y-terrain_clear..y+terrain_clear]]
+ y' <- [y-terrain_clear..y+terrain_clear]]
let clutterIsClear here = not $ any (\p -> distanceBetweenChessboard here p <= object_clear) clutter_locations
let m_result = find (\p -> terrainIsClear p && clutterIsClear p) xys
case m_result of
- Just result -> return $ Just result
+ Just result ->
+ do logDB log_plane DEBUG "Found clear site."
+ return $ Just result
Nothing -> pickRandomClearSite_withTimeout
(fmap (subtract 1) timeout)
- (search_radius*2 + 1)
- object_clear
- (max 0 $ terrain_clear - 1)
+ (search_radius + 1)
+ object_clear
+ (max 0 $ terrain_clear - 1)
(Position (start_x,start_y))
- terrainPredicate
- plane_ref
+ terrainPredicate
+ plane_ref
terrainAt :: (DBReadable db) => PlaneRef -> Position -> db TerrainPatch
terrainAt plane_ref (Position (x,y)) =
@@ -136,9 +182,12 @@ setTerrainAt plane_ref (Position pos) patch = dbModPlane (\p -> p { plane_terrai
-- | Lists all of the entities that are on a specific spot, not including nested entities.
-- Typically this is zero or one creatures, and zero or more tools.
-whatIsOccupying :: (DBReadable db,GenericReference a S) => PlaneRef -> Position -> db [a]
+whatIsOccupying :: (DBReadable db,GenericReference a) => PlaneRef -> Position -> db [a]
whatIsOccupying plane_ref position =
- liftM (mapMaybe fromLocation . filter ((== 0) . (distanceBetweenChessboard position) . location) . map (asLocationTyped _nullary _multiposition)) $ dbGetContents plane_ref
+ liftM (mapMaybe fromLocation . filter ((== 0) .
+ (distanceBetweenChessboard position) . parent) .
+ map (asLocationTyped _nullary _multiposition)) $
+ dbGetContents 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.
diff --git a/src/PlaneVisibility.hs b/src/PlaneVisibility.hs
index 93d54ec..c7dae04 100644
--- a/src/PlaneVisibility.hs
+++ b/src/PlaneVisibility.hs
@@ -23,14 +23,14 @@ import Position
import Control.Applicative
dbGetSeersForFaction :: (DBReadable db) => Faction -> PlaneRef -> db [CreatureRef]
-dbGetSeersForFaction faction plane_ref =
+dbGetSeersForFaction faction plane_ref =
filterM (filterByFaction faction) =<< dbGetContents plane_ref
-- |
-- Returns a list of all terrain patches that are visible to any creature belonging
-- to the specified faction on the specified plane.
--
-dbGetVisibleTerrainForFaction :: (DBReadable db) => Faction -> PlaneRef ->
+dbGetVisibleTerrainForFaction :: (DBReadable db) => Faction -> PlaneRef ->
db [(TerrainPatch,Position)]
dbGetVisibleTerrainForFaction faction plane_ref =
do critters <- dbGetSeersForFaction faction plane_ref
@@ -41,7 +41,7 @@ dbGetVisibleTerrainForFaction faction plane_ref =
--
dbGetVisibleTerrainForCreature :: (DBReadable db) => CreatureRef -> db [(TerrainPatch,Position)]
dbGetVisibleTerrainForCreature creature_ref =
- do loc <- liftM (fmap location) $ getPlanarPosition creature_ref
+ do loc <- liftM (fmap parent) $ getPlanarPosition creature_ref
spot_check <- dbGetSpotCheck creature_ref
case loc of
Just (plane_ref,creature_at) -> liftM (visibleTerrain creature_at spot_check . plane_terrain) $ dbGetPlane plane_ref
@@ -52,7 +52,7 @@ dbGetVisibleTerrainForCreature creature_ref =
-- to the specified faction on the specified plane. Accepts a filter to
-- determine what kinds of objects will be tested..
--
-dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> Faction -> PlaneRef -> db [a]
+dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a) => (forall m. DBReadable m => a -> m Bool) -> Faction -> PlaneRef -> db [a]
dbGetVisibleObjectsForFaction filterF faction plane_ref =
do critters <- dbGetSeersForFaction faction plane_ref
liftM (nubBy (=:=) . concat) $ mapRO (dbGetVisibleObjectsForCreature filterF) critters
@@ -61,9 +61,9 @@ dbGetVisibleObjectsForFaction filterF faction plane_ref =
-- Returns a list of all objects that are visible to the specified creature.
-- Accepts a filter to determine what kinds of objects will be tested.
--
-dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> CreatureRef -> db [a]
+dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a) => (forall m. DBReadable m => a -> m Bool) -> CreatureRef -> db [a]
dbGetVisibleObjectsForCreature filterF creature_ref =
- do (loc :: Maybe PlaneRef) <- liftM (fmap location) $ getPlanarPosition creature_ref
+ do (loc :: Maybe PlaneRef) <- liftM (fmap parent) $ getPlanarPosition creature_ref
case loc of
Just plane_ref -> filterRO (\a -> (&&) <$> filterF a <*> (dbIsPlanarVisible creature_ref $ generalizeReference a)) =<< dbGetContents plane_ref
Nothing -> return []
@@ -74,8 +74,8 @@ dbGetVisibleObjectsForCreature filterF creature_ref =
dbIsPlanarVisible :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool
dbIsPlanarVisible creature_ref obj_ref | creature_ref =:= obj_ref = return True
dbIsPlanarVisible creature_ref obj_ref =
- do (creature_loc :: Maybe (PlaneRef,Position)) <- liftM (fmap location) $ getPlanarPosition creature_ref
- (obj_loc :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap location) $ getPlanarPosition obj_ref
+ do (creature_loc :: Maybe (PlaneRef,Position)) <- liftM (fmap parent) $ getPlanarPosition creature_ref
+ (obj_loc :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap parent) $ getPlanarPosition obj_ref
spot_check <- dbGetOpposedSpotCheck creature_ref obj_ref
case (creature_loc,obj_loc) of
(Nothing,_) -> return False
@@ -95,8 +95,15 @@ dbGetOpposedSpotCheck creature_ref object_ref =
hide <- dbGetHideCheck object_ref
return $ round $ (spot%1) * opposedLinearPowerRatio spot hide
+planarLightingBonus :: (DBReadable db) => PlaneRef -> db Integer
+planarLightingBonus = liftM (\x -> max 0 $ 17 - x*5) . planeDepth
+
dbGetSpotCheck :: (DBReadable db) => CreatureRef -> db Integer
-dbGetSpotCheck creature_ref = liftM (creatureAbilityScore SpotSkill) $ dbGetCreature creature_ref
+dbGetSpotCheck creature_ref =
+ do (m_plane_ref :: Maybe PlaneRef) <- liftM (fmap parent) $ getPlanarPosition creature_ref
+ bonus <- maybe (return 0) planarLightingBonus $ m_plane_ref
+ ability_score <- liftM (creatureAbilityScore SpotSkill) $ dbGetCreature creature_ref
+ return $ ability_score + bonus
dbGetHideCheck :: (DBReadable db) => Reference a -> db Integer
dbGetHideCheck ref | Just creature_ref <- coerceReferenceTyped _creature ref = liftM (creatureAbilityScore HideSkill) $ dbGetCreature creature_ref
diff --git a/src/Planet.hs b/src/Planet.hs
index e518a03..511cae5 100644
--- a/src/Planet.hs
+++ b/src/Planet.hs
@@ -12,21 +12,29 @@ import Data.Maybe
import Data.Ord
import Town
import Data.List
+import Data.ByteString.Char8 as B
+import FactionData
+import BuildingData
makePlanet :: (PlaneLocation l) => l -> PlanetInfo -> DB PlaneRef
makePlanet plane_location planet_info =
do seed <- getRandom
+ seed_down <- getRandom
+ planet_name <- liftM (`fromMaybe` planet_info_name planet_info) $
+ randomPlanetName PanGalacticTreatyOrganization
plane_ref <- dbNewPlane
- (planet_info_name planet_info)
+ planet_name
(TerrainGenerationData {
tg_smootheness = 3,
- tg_biome = planet_info_biome planet_info,
- tg_placements = [recreantFactories seed] })
+ tg_biome = planet_info_biome planet_info,
+ tg_placements = [recreantFactories seed,
+ stairsDown seed_down 0] })
plane_location
town <- liftM catMaybes $ forM (planet_info_town planet_info) $ \(r,b) ->
do p <- rationalRoll r
return $ if p then Just b else Nothing
_ <- createTown plane_ref town
+ _ <- makeDungeons planet_name (Beneath plane_ref) 1 planet_info
return plane_ref
makePlanets :: (PlaneLocation l) => l -> [PlanetInfo] -> DB PlaneRef
@@ -36,8 +44,37 @@ makePlanets l (planet_info:rest) =
_ <- makePlanets (Subsequent plane_ref) rest
return plane_ref
+makeDungeons :: (PlaneLocation l) =>
+ B.ByteString ->
+ l ->
+ Integer ->
+ PlanetInfo ->
+ DB PlaneRef
+makeDungeons planet_name plane_location i planet_info =
+ do let n = planet_info_depth planet_info
+ seed_up <- getRandom
+ seed_down <- getRandom
+ plane_ref <- dbNewPlane
+ planet_name
+ (TerrainGenerationData {
+ tg_smootheness = 2,
+ tg_biome = planet_info_dungeon planet_info,
+ tg_placements =
+ [stairsUp seed_up i] ++
+ if i < n then [stairsDown seed_down i] else [] })
+ plane_location
+ when (i == n) $
+ do _ <- createTown plane_ref [Node $ planet_info_node_type planet_info]
+ return ()
+ when (i < n) $
+ do _ <- makeDungeons planet_name (Beneath plane_ref) (succ i) planet_info
+ return ()
+ return plane_ref
+
generatePlanetInfo :: (DBReadable db) => [PlanetInfo] -> db [PlanetInfo]
generatePlanetInfo planet_infos = liftM (sortBy (comparing planet_info_priority)) $ forM planet_infos $ \planet_info ->
- do prio_bonus <- getRandomR (0.0,1.0) -- see documentation for 'PlanetData.PlanetInfo'
- return $ planet_info `addPriority` prio_bonus
+ do -- see documentation for 'PlanetData.PlanetInfo'
+ prio_bonus <- getRandomR (0.0,1.0)
+ return $ planet_info { planet_info_priority =
+ planet_info_priority planet_info + prio_bonus }
diff --git a/src/PlanetData.hs b/src/PlanetData.hs
index f4df3e1..1978bf1 100644
--- a/src/PlanetData.hs
+++ b/src/PlanetData.hs
@@ -2,7 +2,6 @@
module PlanetData
(PlanetInfo(..),
addTown,
- addPriority,
all_planets,
pgto_planets)
where
@@ -25,51 +24,57 @@ data PlanetInfo = PlanetInfo {
planet_info_priority :: Double,
-- | Some planets have names.
planet_info_name :: Maybe B.ByteString,
+ -- | Number of dungeon levels on the planet.
+ planet_info_depth :: Integer,
planet_info_biome :: Biome,
- planet_info_town :: [(Rational,BuildingType)] }
+ planet_info_dungeon :: Biome,
+ planet_info_town :: [(Rational,BuildingType)],
+ planet_info_node_type :: NodeType }
deriving (Read,Show)
-pgto :: B.ByteString -> Biome -> PlanetInfo
-pgto "" biome = PlanetInfo {
- planet_info_priority = 0.25,
- planet_info_name = Nothing,
+pgto :: Integer -> B.ByteString -> Biome -> PlanetInfo
+pgto x name biome = PlanetInfo {
+ planet_info_priority = fromInteger x / 3,
+ planet_info_name = case name of
+ "" -> Nothing
+ _ -> Just name,
+ planet_info_depth = x,
planet_info_biome = biome,
- planet_info_town = [(1,Portal),(1%2,Monolith),(1%2,Monolith)] }
-pgto name biome = PlanetInfo {
- planet_info_priority = 0.0,
- planet_info_name = Just name,
- planet_info_biome = biome,
- planet_info_town = [(1,Portal)] }
+ planet_info_dungeon = case () of
+ () | biome == OceanBiome -> AbyssalDungeon
+ () | biome == SwampBiome -> AbyssalDungeon
+ () | x == 1 -> ShallowDungeon
+ () -> DeepDungeon,
+ planet_info_town = [(1,Portal)],
+ planet_info_node_type = Anchor }
addTown :: PlanetInfo -> [(Rational,BuildingType)] -> PlanetInfo
addTown planet_info town = planet_info { planet_info_town = planet_info_town planet_info ++ town }
-addPriority :: PlanetInfo -> Double -> PlanetInfo
-addPriority planet_info prio = planet_info { planet_info_priority = planet_info_priority planet_info + prio }
-
all_planets :: [PlanetInfo]
all_planets = concat [pgto_planets]
pgto_planets :: [PlanetInfo]
pgto_planets = [
- pgto "" RockBiome,
- pgto "" IcyRockBiome,
- pgto "" TundraBiome,
- pgto "" DesertBiome,
- pgto "" MountainBiome,
- pgto "roanoke" SwampBiome,
- pgto "pamlico" SwampBiome,
- pgto "pungo" ForestBiome,
- pgto "neuse" ForestBiome,
- pgto "crabtree" SwampBiome,
- pgto "eno" SwampBiome `addTown` [(1%20,Monolith)],
- pgto "yadkin" SwampBiome,
- pgto "catawba" ForestBiome,
- pgto "pasquotank" ForestBiome,
- pgto "dogwood" GrasslandBiome `addPriority` 0.75,
- pgto "emerald" GrasslandBiome `addPriority` 0.75,
- pgto "cardinal" GrasslandBiome `addPriority` 0.75,
- pgto "currituck" OceanBiome `addPriority` 1.5,
- pgto "hatteras" OceanBiome `addPriority` 1.5,
- pgto "lookout" OceanBiome `addPriority` 1.5,
- pgto "ocracoke" OceanBiome `addPriority` 1.5]
+ pgto 1 "" RockBiome,
+ pgto 1 "" IcyRockBiome,
+ pgto 1 "" TundraBiome,
+ pgto 1 "" DesertBiome,
+ pgto 1 "" MountainBiome,
+ pgto 2 "roanoke" SwampBiome,
+ pgto 2 "pamlico" SwampBiome,
+ pgto 2 "pungo" ForestBiome,
+ pgto 2 "neuse" ForestBiome,
+ pgto 2 "crabtree" SwampBiome,
+ pgto 2 "eno" SwampBiome `addTown` [(1%20,Node Monolith)],
+ pgto 2 "yadkin" SwampBiome,
+ pgto 2 "catawba" ForestBiome,
+ pgto 2 "pasquotank" ForestBiome,
+ pgto 3 "dogwood" GrasslandBiome,
+ pgto 3 "emerald" GrasslandBiome,
+ pgto 3 "cardinal" GrasslandBiome,
+ pgto 4 "currituck" OceanBiome,
+ pgto 4 "hatteras" OceanBiome,
+ pgto 4 "lookout" OceanBiome,
+ pgto 4 "ocracoke" OceanBiome]
+
diff --git a/src/PlayerState.hs b/src/PlayerState.hs
index 3678113..0711965 100644
--- a/src/PlayerState.hs
+++ b/src/PlayerState.hs
@@ -10,15 +10,17 @@ module PlayerState
import DBData
import CreatureData
+import CharacterData
import MakeData
+import TravelData
-data PlayerState =
- RaceSelectionState
+data PlayerState =
+ SpeciesSelectionState
| ClassSelectionState Creature
| PlayerCreatureTurn CreatureRef CreatureTurnMode
| SnapshotEvent SnapshotEvent
| GameOver
- deriving (Read,Show)
+ deriving (Read,Show)
data CreatureTurnMode =
NormalMode
@@ -34,14 +36,14 @@ data CreatureTurnMode =
| ClearTerrainMode
deriving (Read,Show)
-data SnapshotEvent =
+data SnapshotEvent =
AttackEvent {
attack_event_source_creature :: CreatureRef,
attack_event_source_weapon :: Maybe ToolRef,
attack_event_target_creature :: CreatureRef }
| MissEvent {
miss_event_creature :: CreatureRef,
- miss_event_weapon :: Maybe ToolRef }
+ miss_event_weapon :: Maybe ToolRef }
| KilledEvent {
killed_event_creature :: CreatureRef }
| WeaponOverheatsEvent {
@@ -61,20 +63,27 @@ data SnapshotEvent =
sunder_event_target_tool :: ToolRef }
| TeleportEvent {
teleport_event_creature :: CreatureRef }
+ | ClimbEvent {
+ climb_event_direction :: ClimbDirection,
+ climb_event_creature :: CreatureRef }
| HealEvent {
heal_event_creature :: CreatureRef }
| ExpendToolEvent {
expend_tool_event_tool :: ToolRef }
+ | BumpEvent {
+ bump_event_creature :: CreatureRef,
+ bump_event_new_level :: Maybe Integer,
+ bump_event_new_class :: Maybe CharacterClass }
deriving (Read,Show)
-- | Get the 'Creature' acting in the given 'PlayerState'.
creatureOf :: PlayerState -> Maybe CreatureRef
-creatureOf state = case state of
+creatureOf state = case state of
PlayerCreatureTurn creature_ref _ -> Just creature_ref
SnapshotEvent event -> subjectOf event
GameOver -> Nothing
ClassSelectionState {} -> Nothing
- RaceSelectionState {} -> Nothing
+ SpeciesSelectionState {} -> Nothing
-- | Get the subject creature of a 'SnapshotEvent', that is, the creature taking action.
subjectOf :: SnapshotEvent -> Maybe CreatureRef
@@ -88,9 +97,11 @@ subjectOf event = case event of
SunderEvent { sunder_event_source_creature = attacker_ref } -> Just attacker_ref
TeleportEvent { teleport_event_creature = creature_ref } -> Just creature_ref
HealEvent { heal_event_creature = creature_ref } -> Just creature_ref
+ ClimbEvent { climb_event_creature = creature_ref } -> Just creature_ref
+ BumpEvent { bump_event_creature = creature_ref } -> Just creature_ref
ExpendToolEvent {} -> Nothing
--- | Current index into the menu, if there is one.
+-- | Current index into the menu, if there is one.
menuIndex :: PlayerState -> Maybe Integer
menuIndex state = fst $ modifyMenuIndex_ id state
diff --git a/src/Protocol.hs b/src/Protocol.hs
index a1253fa..3d21ac0 100644
--- a/src/Protocol.hs
+++ b/src/Protocol.hs
@@ -45,7 +45,7 @@ import Behavior hiding (dbBehave)
import DBPrivate (Reference(ToolRef))
mainLoop :: DB_BaseType -> IO ()
-mainLoop db_init =
+mainLoop db_init =
do db_var <- newMVar db_init
input_chan <- newChan
output_chan <- newChan
@@ -132,20 +132,20 @@ dbOldestSnapshotOnly =
-- Perform an action assuming the database is in the DBRaceSelectionState,
-- otherwise returns an error message.
--
-dbRequiresRaceSelectionState :: (DBReadable db) => db a -> db a
-dbRequiresRaceSelectionState action =
+dbRequiresSpeciesSelectionState :: (DBReadable db) => db a -> db a
+dbRequiresSpeciesSelectionState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
- RaceSelectionState -> action
- _ -> throwError $ DBError $ "protocol-error: not in race selection state (" ++ show state ++ ")"
+ SpeciesSelectionState -> action
+ _ -> throwError $ DBError $ "protocol-error: not in species selection state (" ++ show state ++ ")"
-- |
-- Perform an action assuming the database is in the DBClassSelectionState,
-- otherwise returns an error message.
--
dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db a) -> db a
-dbRequiresClassSelectionState action =
+dbRequiresClassSelectionState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
@@ -164,9 +164,9 @@ dbRequiresPlayerCenteredState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
- ClassSelectionState creature -> action creature
- PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref
- _ -> throwError $ DBError $ "protocol-error: not in player-centered state (" ++ show state ++ ")"
+ ClassSelectionState creature -> action creature
+ PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref
+ _ -> throwError $ DBError $ "protocol-error: not in player-centered state (" ++ show state ++ ")"
-- |
-- Perform an action that works during any creature's turn in a planar environment.
@@ -215,9 +215,9 @@ dbDispatchQuery :: (DBReadable db) => [B.ByteString] -> db B.ByteString
dbDispatchQuery ["state"] =
do state <- playerState
return $ case state of
- RaceSelectionState -> "answer: state race-selection"
- ClassSelectionState {} -> "answer: state class-selection"
- PlayerCreatureTurn _ NormalMode -> "answer: state player-turn"
+ SpeciesSelectionState -> "answer: state species-selection"
+ ClassSelectionState {} -> "answer: state class-selection"
+ PlayerCreatureTurn _ NormalMode -> "answer: state player-turn"
PlayerCreatureTurn _ MoveMode -> "answer: state move"
PlayerCreatureTurn _ (PickupMode {}) -> "answer: state pickup"
PlayerCreatureTurn _ (DropMode {}) -> "answer: state drop"
@@ -239,7 +239,9 @@ dbDispatchQuery ["state"] =
SnapshotEvent (SunderEvent {}) -> "answer: state sunder-event"
SnapshotEvent (TeleportEvent {}) -> "answer: state teleport-event"
SnapshotEvent (HealEvent {}) -> "answer: state heal-event"
+ SnapshotEvent (ClimbEvent {}) -> "answer: state climb-event"
SnapshotEvent (ExpendToolEvent {}) -> "answer: state expend-tool-event"
+ SnapshotEvent (BumpEvent {}) -> "answer: state bump-event"
GameOver -> "answer: state game-over"
dbDispatchQuery ["action-count"] =
@@ -306,10 +308,22 @@ dbDispatchQuery ["who-event"] =
SnapshotEvent event -> "answer: who-event " `B.append` fromMaybe "0" (fmap (B.pack . show . toUID) $ subjectOf event)
_ -> "answer: who-event 0"
-dbDispatchQuery ["player-races","0"] =
- return ("begin-table player-races 0 name\n" `B.append`
- B.unlines (map B.pack player_race_names) `B.append`
- "end-table")
+dbDispatchQuery ["new-level"] =
+ do state <- playerState
+ return $ case state of
+ SnapshotEvent event -> "answer: new-level " `B.append` maybe "nothing" (B.pack . show) (bump_event_new_level event)
+ _ -> "answer: new-level nothing"
+
+dbDispatchQuery ["new-character-class"] =
+ do state <- playerState
+ return $ case state of
+ SnapshotEvent event -> "answer: new-character-class " `B.append` maybe "nothing" (B.pack . show) (bump_event_new_class event)
+ _ -> "answer: new-character-class nothing"
+
+dbDispatchQuery ["player-species","0"] =
+ return ("begin-table player-species 0 name\n" `B.append`
+ B.unlines (map B.pack player_species_names) `B.append`
+ "end-table")
dbDispatchQuery ["visible-terrain","0"] =
do maybe_plane_ref <- dbGetCurrentPlane
@@ -320,16 +334,17 @@ dbDispatchQuery ["visible-terrain","0"] =
dbDispatchQuery ["who-player"] = return "answer: who-player 2"
-dbDispatchQuery ["visible-objects","0"] =
+dbDispatchQuery ["visible-objects","0"] =
do maybe_plane_ref <- dbGetCurrentPlane
- (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref
- table_rows <- mapM (dbObjectToTableRow . entity) objects
+ (objects :: [Location (Reference ()) ()]) <- maybe (return [])
+ (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref
+ table_rows <- mapM (dbObjectToTableRow . child) objects
return ("begin-table visible-objects 0 object-unique-id x y facing\n" `B.append`
(B.unlines $ table_rows) `B.append`
"end-table")
- where dbObjectToTableRow obj_ref =
+ where dbObjectToTableRow obj_ref =
do l <- dbWhere obj_ref
- return $ case (extractLocation l,extractLocation l) of
+ return $ case (extractParent l,extractParent l) of
(Just (Position (x,y)),maybe_face) -> B.unwords $ map B.pack $ [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]
_ -> ""
@@ -391,7 +406,7 @@ dbDispatchQuery ["object-details",uid] = ro $
buildingToTableData (ref,Building) = objectTableWrapper ref $
do building_type <- buildingType ref
return $ "object-type building\n" `B.append`
- "building-type " `B.append` B.pack (show building_type) `B.append` "\n"
+ "building-type " `B.append` B.pack (showBuilding building_type) `B.append` "\n"
dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats
@@ -409,10 +424,14 @@ dbDispatchQuery ["menu","0"] =
liftM (showToolMenuTable "menu" "0") $ toolsToMenuTable =<< toolMenuElements
dbDispatchQuery ["menu",s] | Just window_size <- readNumber s =
- do n <- liftM (fromMaybe 0) menuState
+ do -- constructs a scrolling window of menu items
+ -- FIXME! This should be done client side.
+ n <- liftM (fromMaybe 0) menuState
+ l <- menuLength
let half_window = window_size `div` 2
- let windowF (x,_,_) = abs (x - (max half_window n)) <= half_window
- liftM (showToolMenuTable "menu" s . filter windowF) $ toolsToMenuTable =<< toolMenuElements
+ let window_top = max 0 $ min (l-window_size-1) (n - half_window)
+ let windowFilter (x,_,_) = x >= window_top && x <= window_top + window_size
+ liftM (showToolMenuTable "menu" s . filter windowFilter) $ toolsToMenuTable =<< toolMenuElements
dbDispatchQuery ["wielded-objects","0"] =
do m_plane_ref <- dbGetCurrentPlane
@@ -455,16 +474,26 @@ dbDispatchQuery ["compass"] =
Nothing -> return "answer: compass nothing"
Just player_ref -> Perception.runPerception player_ref $ liftM (("answer: compass " `B.append`) . B.pack . show) Perception.compass
+dbDispatchQuery ["dungeon-depth"] =
+ do m_player_ref <- getCurrentCreature Player
+ case m_player_ref of
+ Nothing -> return "answer: compass nothing"
+ Just player_ref -> Perception.runPerception player_ref $ liftM (("answer: dungeon-depth " `B.append`) . B.pack . show) Perception.depth
+
dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" `B.append` B.unwords unrecognized `B.append` "`"
+-----------------------------------------------------
+-- Actions
+-----------------------------------------------------
+
dbDispatchAction :: [B.ByteString] -> DB ()
dbDispatchAction ["continue"] = dbPopOldestSnapshot
-dbDispatchAction ["select-race",race_name] =
- dbRequiresRaceSelectionState $ dbSelectPlayerRace race_name
+dbDispatchAction ["select-species",species_name] =
+ dbRequiresSpeciesSelectionState $ dbSelectPlayerRace species_name
dbDispatchAction ["reroll"] =
- dbRequiresClassSelectionState $ dbRerollRace
+ dbRequiresClassSelectionState $ dbRerollSpecies
dbDispatchAction ["select-class",class_name] =
dbRequiresClassSelectionState $ dbSelectPlayerClass class_name
@@ -486,7 +515,7 @@ dbDispatchAction ["normal"] =
dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref NormalMode)
dbDispatchAction ["normal",direction] | Just face <- stringToFacing direction =
- dbRequiresPlayerTurnState $ \creature_ref ->
+ dbRequiresPlayerTurnState $ \creature_ref ->
do behavior <- facingBehavior creature_ref face
dbPerformPlayerTurn behavior creature_ref
@@ -605,26 +634,32 @@ dbDispatchAction ["attack"] =
dbDispatchAction ["attack",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Attack $ fromJust $ stringToFacing direction) creature_ref
-dbDispatchAction ["activate"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Activate creature_ref
+dbDispatchAction ["activate"] = dbRequiresPlayerTurnState $ dbPerformPlayerTurn Activate
+
+dbDispatchAction ["down"] =
+ dbRequiresPlayerTurnState $ dbPerformPlayerTurn StepDown
+
+dbDispatchAction ["up"] =
+ dbRequiresPlayerTurnState $ dbPerformPlayerTurn StepUp
dbDispatchAction unrecognized = throwError $ DBError $ ("protocol-error: unrecognized action `" ++ (B.unpack $ B.unwords unrecognized) ++ "`")
dbSelectPlayerRace :: B.ByteString -> DB ()
-dbSelectPlayerRace race_name =
- case find (\s -> B.map toLower (B.pack $ show s) == race_name) player_species of
- Nothing -> throwError $ DBError $ "protocol-error: unrecognized race '" ++ B.unpack race_name ++ "'"
+dbSelectPlayerRace species_name =
+ case find (\s -> B.map toLower (B.pack $ show s) == species_name) player_species of
+ Nothing -> throwError $ DBError $ "protocol-error: unrecognized species '" ++ B.unpack species_name ++ "'"
Just species -> generateInitialPlayerCreature species
dbSelectPlayerClass :: B.ByteString -> Creature -> DB ()
-dbSelectPlayerClass class_name creature =
+dbSelectPlayerClass class_name creature =
let eligable_base_classes = getEligableBaseCharacterClasses creature
in case find (\x -> (B.map toLower . B.pack . show) x == class_name) eligable_base_classes of
Nothing -> throwError $ DBError $ "protocol-error: unrecognized or invalid class '" ++ B.unpack class_name ++ "'"
Just the_class -> dbBeginGame creature the_class
-dbRerollRace :: Creature -> DB ()
-dbRerollRace _ = do starting_race <- dbGetStartingRace
- generateInitialPlayerCreature $ fromJust starting_race
+dbRerollSpecies :: Creature -> DB ()
+dbRerollSpecies _ = do starting_species <- dbGetStartingSpecies
+ generateInitialPlayerCreature $ fromJust starting_species
dbQueryPlayerStats :: (DBReadable db) => Creature -> db B.ByteString
dbQueryPlayerStats creature = return $ playerStatsTable creature
@@ -655,6 +690,9 @@ toolsToMenuTable raw_uids =
tool_names <- mapM (liftM toolName . dbGetTool) uids
return $ zip3 [0..] uids tool_names
+menuLength :: (DBReadable db) => db Integer
+menuLength = liftM genericLength toolMenuElements
+
-- |
-- Generate a tool menu table in text form, with the specified name and element list.
--
@@ -706,7 +744,7 @@ baseClassesTable creature =
dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db B.ByteString
dbQueryCenterCoordinates creature_ref =
do l <- dbWhere creature_ref
- case (extractLocation l,extractLocation l :: Maybe Facing) of
+ case (extractParent l,extractParent l :: Maybe Facing) of
(Just (Position (x,y)),Nothing) ->
return (begin_table `B.append`
"x " `B.append` B.pack (show x) `B.append` "\n" `B.append`
diff --git a/src/Species.hs b/src/Species.hs
index 690e58a..da4be92 100644
--- a/src/Species.hs
+++ b/src/Species.hs
@@ -1,6 +1,6 @@
module Species
- (player_race_names,
+ (player_species_names,
SpeciesData(..),
speciesInfo)
where
@@ -13,10 +13,10 @@ import CreatureAttribute
import Data.Monoid
import TerrainData
-player_race_names :: [String]
-player_race_names = map (map toLower . show) player_species
+player_species_names :: [String]
+player_species_names = map (map toLower . show) player_species
-data SpeciesData = SpeciesData {
+data SpeciesData = SpeciesData {
species_recurring_attributes :: CreatureAttribute,
species_starting_attributes :: [CreatureAttributeGenerator] }
@@ -33,21 +33,19 @@ surpriseAptitudes = mconcat $ map (\a -> attributeChoice 0.05 [attributeMinMax (
speciesInfo :: Species -> SpeciesData
speciesInfo Anachronid = SpeciesData (Speed & Mindfulness & SpotSkill) [
- gender 0.8
- [aptitudeBlock 1 10 [Speed,Mindfulness],
- attributeStatic 2 SpotSkill]
- [aptitudeBlock 10 25 [Speed,Mindfulness],
- attributeStatic 15 SpotSkill,
- surpriseAptitudes],
+ gender 0.0,
+ aptitudeBlock 10 25 [Speed,Mindfulness],
+ attributeStatic 15 SpotSkill,
+ surpriseAptitudes,
attributeStatic 1 $ FavoredClass Barbarian,
attributeStatic 1 $ FavoredClass Pirate]
speciesInfo Androsynth = SpeciesData (Strength & Intellect) [
aptitudeBlock 12 17 [Strength,Intellect],
- attributeStatic 1 $ FavoredClass Engineer]
+ attributeStatic 1 $ FavoredClass Engineer]
speciesInfo Ascendant = SpeciesData (Strength & Mindfulness) [
- gender 0.45 [] [],
+ gender 0.5,
aptitudeBlock 5 15 [Strength,Mindfulness],
surpriseAptitudes,
attributeStatic 10 JumpSkill,
@@ -55,18 +53,23 @@ speciesInfo Ascendant = SpeciesData (Strength & Mindfulness) [
attributeStatic 1 $ FavoredClass ForceAdept]
speciesInfo Caduceator = SpeciesData (Strength & Charisma) [
- gender 0.6 [] [],
+ gender 0.5,
aptitudeBlock 5 15 [Strength,Charisma],
surpriseAptitudes,
attributeStatic 1 $ FavoredClass Consular]
+speciesInfo DustVortex = SpeciesData (Speed & Mindfulness) [
+ aptitudeBlock 3 5 [Speed,Mindfulness],
+ attributeStatic 10 JumpSkill,
+ attributeStatic 1 $ FavoredClass Barbarian]
+
speciesInfo Encephalon = SpeciesData (Constitution & Intellect) [
- gender 0.95 [] [],
+ gender 0.5,
aptitudeBlock 3 20 [Constitution,Intellect],
attributeStatic 1 $ FavoredClass Engineer]
speciesInfo Hellion = SpeciesData (Strength & Perception) [
- gender 0.5 [] [],
+ gender 0.5,
aptitudeBlock 5 15 [Strength,Perception],
surpriseAptitudes,
attributeStatic 5 $ HideSkill,
@@ -76,7 +79,7 @@ speciesInfo Hellion = SpeciesData (Strength & Perception) [
attributeStatic 1 $ FavoredClass Pirate]
speciesInfo Goliath = SpeciesData (Constitution & Perception) [
- gender 0.55 [] [],
+ gender 0.5,
aptitudeBlock 3 20 [Constitution,Perception],
surpriseAptitudes,
attributeStatic 4 $ DamageReductionTrait Melee,
@@ -87,14 +90,14 @@ speciesInfo Goliath = SpeciesData (Constitution & Perception) [
attributeStatic 1 $ FavoredClass Scout]
speciesInfo Kraken = SpeciesData (Constitution & Charisma) [
- gender 0.5 [] [],
+ gender 0.5,
aptitudeBlock 3 20 [Constitution,Charisma],
attributeStatic 1 $ TerrainAffinity Water,
surpriseAptitudes,
attributeStatic 1 $ FavoredClass Consular]
speciesInfo Myrmidon = SpeciesData (Speed & Intellect) [
- gender 0.0 [] [],
+ gender 0.0,
aptitudeBlock 5 15 [Speed,Intellect],
surpriseAptitudes,
attributeStatic 1 $ FavoredClass Barbarian,
@@ -122,7 +125,7 @@ speciesInfo Recreant = SpeciesData (Speed & Perception) [
attributeStatic 1 $ FavoredClass Scout]
speciesInfo Reptilian = SpeciesData (Speed & Charisma) [
- gender 0.35 [] [],
+ gender 0.5,
aptitudeBlock 5 15 [Speed,Charisma],
surpriseAptitudes,
attributeStatic 5 $ AttackSkill Unarmed,
diff --git a/src/SpeciesData.hs b/src/SpeciesData.hs
index 1db80d7..3d442e4 100644
--- a/src/SpeciesData.hs
+++ b/src/SpeciesData.hs
@@ -9,6 +9,7 @@ data Species =
| Androsynth
| Ascendant
| Caduceator
+ | DustVortex
| Encephalon
| Goliath
| Hellion
diff --git a/src/TerrainData.hs b/src/TerrainData.hs
index a2df7f3..f892429 100644
--- a/src/TerrainData.hs
+++ b/src/TerrainData.hs
@@ -6,6 +6,8 @@ module TerrainData
TerrainGenerationData(..),
TerrainPlacement,
recreantFactories,
+ stairsUp,
+ stairsDown,
generateTerrain,
generateExampleTerrain,
prettyPrintTerrain,
@@ -24,16 +26,21 @@ import Data.Ratio
-- Most automatically generated surface maps belong to a Biome, representing the kind of terrain
-- and plant life that dwells in terrain generated for the map.
--
-data Biome = RockBiome
+data Biome = ShallowDungeon
+ | DeepDungeon
+ | FrozenDungeon
+ | AbyssalDungeon
+ | InfernalDungeon
+ | RockBiome
| IcyRockBiome
| GrasslandBiome
- | ForestBiome
+ | ForestBiome
| TundraBiome
| DesertBiome
| OceanBiome
| MountainBiome
- | SwampBiome
- deriving (Read,Show,Eq,Ord,Enum,Bounded)
+ | SwampBiome
+ deriving (Read,Show,Eq,Ord,Enum,Bounded)
-- |
-- All static terrain elements are members of TerrainGrid
@@ -55,16 +62,18 @@ data TerrainPatch = RockFace
| Water
| DeepWater
| Ice
- | Lava
- | Glass -- what sand becomes when struck by intense heat
- | RecreantFactory
+ | Lava
+ | Glass -- what sand becomes when struck by intense heat
+ | RecreantFactory
+ | Upstairs
+ | Downstairs
deriving (Read,Show,Eq,Ord)
data TerrainGenerationData = TerrainGenerationData
- { tg_smootheness :: Integer,
- tg_biome :: Biome,
- tg_placements :: [TerrainPlacement] }
- deriving (Read,Show)
+ { tg_smootheness :: Integer,
+ tg_biome :: Biome,
+ tg_placements :: [TerrainPlacement] }
+ deriving (Read,Show)
data TerrainPlacement = TerrainPlacement {
placement_sources :: [(Rational,TerrainPatch)],
@@ -76,23 +85,46 @@ placeTerrain :: TerrainPlacement -> TerrainGrid -> TerrainGrid
placeTerrain terrain_placement =
arbitraryReplaceGrid (placement_sources terrain_placement)
(placement_replacements terrain_placement)
- (placement_seed terrain_placement)
+ (placement_seed terrain_placement)
recreantFactories :: Integer -> TerrainPlacement
recreantFactories seed = TerrainPlacement {
- placement_sources =
+ placement_sources =
[(1%25,Ice),
(1%100,Sand),
(1%25,Desert),
(1%50,Dirt),
(1%10,Glass),
- (1%200,Grass),
+ (1%200,Grass),
(1%1000,Forest),
(1%25,RockyGround)],
- placement_replacements =
+ placement_replacements =
[(1,RecreantFactory)],
placement_seed = seed }
+stairsUp :: Integer -> Integer -> TerrainPlacement
+stairsUp seed depth = TerrainPlacement {
+ placement_sources =
+ [(1%(15+3*depth),RockyGround),
+ (1%(25+5*depth),Ice),
+ (1%(50+10*depth),Water),
+ (1%(75+15*depth),RockFace)],
+ placement_replacements =
+ [(1,Upstairs)],
+ placement_seed = seed }
+
+stairsDown :: Integer -> Integer -> TerrainPlacement
+stairsDown seed depth = TerrainPlacement {
+ placement_sources =
+ [(1%(15+3*depth),RockyGround),
+ (1%(25+5*depth),Ice),
+ (1%(75+15*depth),RockFace),
+ (1%(40+10*depth),Dirt),
+ (1%60,Grass)],
+ placement_replacements =
+ [(1,Downstairs)],
+ placement_seed = seed }
+
-- |
-- A list of TerrainPatches that are considered "difficult", either for traveling
-- or for constructing buildings.
@@ -108,6 +140,11 @@ impassable_terrains :: [TerrainPatch]
impassable_terrains = [RockFace,Forest,DeepForest]
terrainFrequencies :: Biome -> [(Integer,TerrainPatch)]
+terrainFrequencies ShallowDungeon = [(40,RockFace),(50,RockyGround),(5,Sand),(5,Dirt)]
+terrainFrequencies DeepDungeon = [(50,RockFace),(25,Rubble),(25,RockyGround)]
+terrainFrequencies FrozenDungeon = [(75,RockFace),(5,Rubble),(10,RockyGround),(10,Ice)]
+terrainFrequencies AbyssalDungeon = [(60,RockFace),(10,Rubble),(10,RockyGround),(20,Water)]
+terrainFrequencies InfernalDungeon = [(70,RockFace),(15,Rubble),(15,Lava)]
terrainFrequencies RockBiome = [(15,RockFace),(15,Rubble),(55,RockyGround),(15,Sand)]
terrainFrequencies IcyRockBiome = [(10,RockFace),(10,Rubble),(20,RockyGround),(60,Ice)]
terrainFrequencies GrasslandBiome = [(5,RockFace),(5,RockyGround),(10,Dirt),(10,Sand),(10,Forest),(10,Water),(50,Grass)]
@@ -121,6 +158,7 @@ terrainFrequencies SwampBiome = [(40,Forest),(50,Water),(5,Sand),(5,Grass)]
terrainInterpFn :: (TerrainPatch,TerrainPatch) -> [(Integer,TerrainPatch)]
terrainInterpFn (a,b) = [(1,a),(1,b)] ++ (terrainInterpRule (a,b)) ++ (terrainInterpRule (b,a))
+-- Notice, in terrainInterpFn, we always throw in both terrain patches with a weight of 1.
terrainInterpRule :: (TerrainPatch,TerrainPatch) -> [(Integer,TerrainPatch)]
terrainInterpRule (RockFace,RockFace) = []
terrainInterpRule (RockFace,RockyGround) = [(3,RockFace),(1,Rubble),(3,RockyGround)]
@@ -129,12 +167,12 @@ terrainInterpRule (Rubble,x) = [(1,Rubble),(2,Sand),(2,Dirt),(5,x)]
terrainInterpRule (DeepWater,DeepWater) = []
terrainInterpRule (DeepWater,Water) = [(3,DeepWater)]
terrainInterpRule (DeepWater,_) = [(3,Water)]
-terrainInterpRule (DeepForest,DeepForest) = []
-terrainInterpRule (DeepForest,Forest) = [(3,DeepForest)]
-terrainInterpRule (DeepForest,_) = [(5,Forest)]
+terrainInterpRule (DeepForest,DeepForest) = [(1,Grass)]
+terrainInterpRule (DeepForest,Forest) = [(2,Grass)]
+terrainInterpRule (DeepForest,_) = [(1,Forest)]
terrainInterpRule (Forest,DeepForest) = []
-terrainInterpRule (Forest,Forest) = []
-terrainInterpRule (Forest,_) = [(1,Grass)]
+terrainInterpRule (Forest,Forest) = [(3,Grass)]
+terrainInterpRule (Forest,_) = [(3,Grass)]
terrainInterpRule (Water,Water) = [(20,Water),(1,Sand)]
terrainInterpRule (Water,DeepWater) = []
terrainInterpRule (Water,_) = [(1,Sand)]
@@ -149,8 +187,8 @@ baseTerrainPatches = nub $ List.map snd $ concatMap terrainFrequencies [minBound
terrainInterpMap :: Map (TerrainPatch,TerrainPatch) [(Integer,TerrainPatch)]
terrainInterpMap = let terrain_patch_pairs = [(a,b) | a <- baseTerrainPatches, b <- baseTerrainPatches]
- interps = List.map terrainInterpFn terrain_patch_pairs
- in fromList (zip terrain_patch_pairs interps)
+ interps = List.map terrainInterpFn terrain_patch_pairs
+ in fromList (zip terrain_patch_pairs interps)
type TerrainGrid = Grid TerrainPatch
@@ -184,6 +222,8 @@ terrainPatchToASCII Ice = '^'
terrainPatchToASCII Glass = '_'
terrainPatchToASCII Lava = '^'
terrainPatchToASCII RecreantFactory = 'o'
+terrainPatchToASCII Upstairs = '<'
+terrainPatchToASCII Downstairs = '>'
exampleTerrainGenerator :: TerrainGenerationData
exampleTerrainGenerator = TerrainGenerationData
diff --git a/src/Tool.hs b/src/Tool.hs
index 2f4fd8f..6a1a0d0 100644
--- a/src/Tool.hs
+++ b/src/Tool.hs
@@ -18,38 +18,43 @@ import Data.List as List
import ToolData
import Substances
-dbPickupTool :: (DBReadable db,LocationType a) => CreatureRef -> Location s ToolRef a -> db (Location s ToolRef Inventory)
-dbPickupTool c l =
- do (c_where :: Maybe (Position,PlaneRef)) <- liftM extractLocation $ dbWhere c
- when ((c_where /= extractLocation l && Just c /= extractLocation l) || isNothing c_where) $
+dbPickupTool :: (DBReadable db,LocationParent a) =>
+ CreatureRef ->
+ Location ToolRef a ->
+ db (Location ToolRef Inventory)
+dbPickupTool c l =
+ do (c_where :: Maybe (Position,PlaneRef)) <- liftM extractParent $ dbWhere c
+ when ((c_where /= extractParent l && Just c /= extractParent l) || isNothing c_where) $
throwError (DBErrorFlag ToolIs_NotAtFeet)
return $ toInventory (Inventory c) l
-- | Move a tool into wielded position for whatever creature is carrying it.
-dbWieldTool :: (DBReadable db,LocationType a) => Location s ToolRef a -> db (Location s ToolRef Wielded)
+dbWieldTool :: (DBReadable db,LocationParent a) =>
+ Location ToolRef a -> db (Location ToolRef Wielded)
dbWieldTool l =
case () of
- () | Just l' <- coerceLocation l -> return l' -- if it coerces into our return type, then it's already wielded
- () | Just (Dropped plane_ref position) <- extractLocation l ->
- do pickupers <- liftM (map entity . filter ((== position) . location)) $ dbGetContents plane_ref
+ () | Just l' <- coerceParent l -> return l' -- if it coerces into our return type, then it's already wielded
+ () | Just (Dropped plane_ref position) <- extractParent l ->
+ do pickupers <- liftM (map child . filter ((== position) . parent)) $ dbGetContents plane_ref
case pickupers of -- the creature that is standing over the tool -- there can be only one
[single_pickuper] -> return $ toWielded (Wielded single_pickuper) l
_ -> throwError $ DBError "dbWieldTool: there were multiple creatures in reach of a single tool"
- () | Just (Inventory c) <- extractLocation l -> return $ toWielded (Wielded c) l
+ () | Just (Inventory c) <- extractParent l -> return $ toWielded (Wielded c) l
() | otherwise -> throwError $ DBErrorFlag ToolIs_NotWieldable
-dbDropTool :: (DBReadable db,LocationType a) => Location s ToolRef a -> db (Location s ToolRef Dropped)
+dbDropTool :: (DBReadable db,LocationParent a) =>
+ Location ToolRef a -> db (Location ToolRef Dropped)
dbDropTool l =
- do lp <- liftM extractLocation $ dbWhere (getLocation l)
+ do lp <- liftM extractParent $ dbWhere (genericParent l)
flip (maybe (throwError $ DBErrorFlag NotStanding)) lp $ \(creature_position,plane_ref) ->
do return $ toDropped (Dropped plane_ref creature_position) l
dbAvailablePickups :: (DBReadable db) => CreatureRef -> db [ToolRef]
dbAvailablePickups creature_ref =
- do m_creature_where <- liftM extractLocation $ dbWhere creature_ref
+ do m_creature_where <- liftM extractParent $ dbWhere creature_ref
flip (maybe (return [])) m_creature_where $ \(creature_position :: Position,plane_ref :: PlaneRef) ->
do contents <- dbGetContents plane_ref
- return $ map entity $ filter ((== creature_position) . location) contents
+ return $ map child $ filter ((== creature_position) . parent) contents
-- | List of tools that the specified creature may choose to wield.
-- That is, they are either on the ground or in the creature's inventory.
@@ -57,7 +62,7 @@ availableWields :: (DBReadable db) => CreatureRef -> db [ToolRef]
availableWields creature_ref = liftM2 List.union (dbAvailablePickups creature_ref) (dbGetContents creature_ref)
dbGetWielded :: (DBReadable db) => CreatureRef -> db (Maybe ToolRef)
-dbGetWielded = liftM (listToMaybe . map (entity . asLocationTyped _tool _wielded)) . dbGetContents
+dbGetWielded = liftM (listToMaybe . map (child . asLocationTyped _tool _wielded)) . dbGetContents
-- | Safely delete tools.
deleteTool :: ToolRef -> DB ()
diff --git a/src/Travel.hs b/src/Travel.hs
index 5c711a6..f1a71d9 100644
--- a/src/Travel.hs
+++ b/src/Travel.hs
@@ -1,6 +1,11 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Travel
(stepCreature,
turnCreature,
+ ClimbOutcome,
+ resolveClimb,
+ executeClimb,
TeleportJumpOutcome,
resolveTeleportJump,
executeTeleportJump)
@@ -19,26 +24,79 @@ import TerrainData
import Data.List (minimumBy)
import Creature
import CreatureData
+import Logging
+import TravelData
-walkCreature :: (DBReadable db) => Facing -> (Integer,Integer) ->
- Location m CreatureRef () -> db (Location m CreatureRef ())
+walkCreature :: (DBReadable db) => Facing ->
+ (Integer,Integer) ->
+ Location CreatureRef () ->
+ db (Location CreatureRef ())
walkCreature face (x',y') l = liftM (fromMaybe l) $ runMaybeT $
- do (plane_ref,Position (x,y)) <- MaybeT $ return $ extractLocation l
+ do (plane_ref,Position (x,y)) <- MaybeT $ return $ extractParent l
let standing = Standing { standing_plane = plane_ref,
standing_position = Position (x+x',y+y'),
- standing_facing = face }
- flip unless (fail "") =<< (lift $ isTerrainPassable plane_ref (entity l) $ standing_position standing)
- return $ generalizeLocation $ toStanding standing l
+ standing_facing = face }
+ is_passable <- lift $ isTerrainPassable plane_ref
+ (child l)
+ (standing_position standing)
+ when (not is_passable) $
+ do lift $ logDB log_travel WARNING $ "Terrain not passable."
+ fail ""
+ return $ generalizeParent $ toStanding standing l
-stepCreature :: (DBReadable db) => Facing -> Location m CreatureRef () -> db (Location m CreatureRef ())
+stepCreature :: (DBReadable db) => Facing -> Location CreatureRef () -> db (Location CreatureRef ())
stepCreature face = walkCreature face (facingToRelative face)
-turnCreature :: (DBReadable db) => Facing -> Location m CreatureRef () -> db (Location m CreatureRef ())
+turnCreature :: (DBReadable db) => Facing -> Location CreatureRef () -> db (Location CreatureRef ())
turnCreature face = walkCreature face (0,0)
--------------------------------------------------------------------------------------------------------------
--- Teleportation/Jumping
--------------------------------------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
+-- Travel between planes.
+--------------------------------------------------------------------------------
+
+data ClimbOutcome =
+ ClimbGood ClimbDirection CreatureRef Standing
+ | ClimbFailed
+
+-- |
+-- Climb up or down between Planes.
+--
+resolveClimb :: (DBReadable db) => CreatureRef ->
+ ClimbDirection ->
+ db ClimbOutcome
+resolveClimb creature_ref direction = liftM (fromMaybe ClimbFailed) $ runMaybeT $
+ do l <- lift $ dbWhere creature_ref
+ ((p,pos) :: (PlaneRef,Position)) <- MaybeT $ return $ extractParent l
+ terrain_type <- lift $ terrainAt p pos
+ let (expected_starting_terrain, expected_landing_terrain) = case direction of
+ ClimbUp -> (Upstairs,Downstairs)
+ ClimbDown -> (Downstairs,Upstairs)
+ when (terrain_type /= expected_starting_terrain) $
+ do lift $ logDB log_travel WARNING $ "Not standing on correct stairway."
+ fail ""
+ lift $ logDB log_travel DEBUG $ "Stepping " ++ show direction ++ " from: " ++ show (p,pos)
+ let face = fromMaybe Here $ extractParent l
+ p' <- MaybeT $ case direction of
+ ClimbDown -> getBeneath p
+ ClimbUp -> liftM extractParent $ dbWhere p
+ lift $ logDB log_travel DEBUG $ "Stepping " ++ show direction ++ " to: " ++ show p'
+ pos' <- lift $ pickRandomClearSite 10 0 0 pos (== expected_landing_terrain) p'
+ return $ ClimbGood direction creature_ref $
+ Standing { standing_plane = p',
+ standing_position = pos',
+ standing_facing = face }
+
+-- | Execute a resolved climb attempt.
+executeClimb :: ClimbOutcome -> DB ()
+executeClimb ClimbFailed = return ()
+executeClimb (ClimbGood direction creature_ref standing_location) =
+ do _ <- dbMove (return . toStanding standing_location) creature_ref
+ dbPushSnapshot $ ClimbEvent direction creature_ref
+ return ()
+
+--------------------------------------------------------------------------------
+-- Teleportation/Jumping
+--------------------------------------------------------------------------------
-- |
-- Try to teleport the creature to the specified Position. The teleport attempt can be automatically retried a number of times, and the most accurate attempt will be used.
@@ -59,18 +117,18 @@ data TeleportJumpOutcome =
resolveTeleportJump :: (DBReadable db) => CreatureRef -> Facing -> db TeleportJumpOutcome
resolveTeleportJump creature_ref face = liftM (fromMaybe TeleportJumpFailed) $ runMaybeT $
do start_location <- lift $ dbWhere creature_ref
- jump_roll <- liftM roll_log $ lift $ rollCreatureAbilityScore JumpSkill 0 (entity start_location)
- standing_location <- MaybeT $ return $ extractLocation start_location
+ jump_roll <- liftM roll_log $ lift $ rollCreatureAbilityScore JumpSkill 0 (child start_location)
+ standing_location <- MaybeT $ return $ extractParent start_location
landing_position <- lift $ randomTeleportLanding jump_roll (standing_plane standing_location) (standing_position standing_location) $
offsetPosition (facingToRelative7 face) $ standing_position standing_location
case () of
() | jump_roll <= 0 -> return TeleportJumpFailed
- () | otherwise -> return $ TeleportJumpGood (entity start_location) $ standing_location { standing_position = landing_position, standing_facing = face }
+ () | otherwise -> return $ TeleportJumpGood (child start_location) $ standing_location { standing_position = landing_position, standing_facing = face }
-- | Execute a resolved teleport jump.
executeTeleportJump :: TeleportJumpOutcome -> DB ()
executeTeleportJump TeleportJumpFailed = return ()
-executeTeleportJump (TeleportJumpGood creature_ref standing_location) =
+executeTeleportJump (TeleportJumpGood creature_ref standing_location) =
do _ <- dbMove (return . toStanding standing_location) creature_ref
dbPushSnapshot $ TeleportEvent creature_ref
return ()
diff --git a/src/TravelData.hs b/src/TravelData.hs
new file mode 100644
index 0000000..7b7e9e2
--- /dev/null
+++ b/src/TravelData.hs
@@ -0,0 +1,6 @@
+
+module TravelData
+ (ClimbDirection(..)) where
+
+data ClimbDirection = ClimbUp | ClimbDown
+ deriving (Read,Show)
diff --git a/src/Turns.hs b/src/Turns.hs
index 31eb9df..adbdea4 100644
--- a/src/Turns.hs
+++ b/src/Turns.hs
@@ -20,10 +20,13 @@ import Behavior
import qualified Perception as P
import Position
import PlayerState
+import Logging
dbPerformPlayerTurn :: Behavior -> CreatureRef -> DB ()
dbPerformPlayerTurn beh creature_ref =
- do dbBehave beh creature_ref
+ do logDB log_turns INFO $ "Beginning player action: " ++ show beh
+ dbBehave beh creature_ref
+ logDB log_turns INFO $ "Finishing AI turns."
dbFinishPendingAITurns
dbFinishPendingAITurns :: DB ()
@@ -31,7 +34,7 @@ dbFinishPendingAITurns =
do m_current_plane <- dbGetCurrentPlane
case m_current_plane of
Just p -> dbFinishPlanarAITurns p
- Nothing -> return ()
+ Nothing -> return ()
dbFinishPlanarAITurns :: PlaneRef -> DB ()
dbFinishPlanarAITurns plane_ref =
@@ -41,46 +44,60 @@ dbFinishPlanarAITurns plane_ref =
next_turn <- dbNextTurn $ map generalizeReference all_creatures_on_plane ++ [generalizeReference plane_ref]
case next_turn of
_ | not any_players_left ->
- do setPlayerState GameOver
- return ()
- ref | ref =:= plane_ref ->
- do dbPerform1PlanarAITurn plane_ref
- dbFinishPlanarAITurns plane_ref
- ref | Just creature_ref <- coerceReferenceTyped _creature ref ->
- do faction <- getCreatureFaction creature_ref
- if (faction /= Player)
- then do dbPerform1CreatureAITurn creature_ref
- dbFinishPlanarAITurns plane_ref
- else setPlayerState (PlayerCreatureTurn creature_ref NormalMode)
- return ()
- _ -> error "dbFinishPlanarAITurns: impossible case"
+ do setPlayerState GameOver
+ return ()
+ ref | ref =:= plane_ref ->
+ do dbPerform1PlanarAITurn plane_ref
+ dbFinishPlanarAITurns plane_ref
+ ref | Just creature_ref <- coerceReferenceTyped _creature ref ->
+ do faction <- getCreatureFaction creature_ref
+ if (faction /= Player)
+ then do dbPerform1CreatureAITurn creature_ref
+ dbFinishPlanarAITurns plane_ref
+ else setPlayerState (PlayerCreatureTurn creature_ref NormalMode)
+ return ()
+ _ -> error "dbFinishPlanarAITurns: impossible case"
planar_turn_frequency :: Integer
planar_turn_frequency = 100
+monster_spawns :: [(TerrainPatch,Species)]
+monster_spawns = [(RecreantFactory,Recreant), (Dirt,DustVortex)]
+
dbPerform1PlanarAITurn :: PlaneRef -> DB ()
-dbPerform1PlanarAITurn plane_ref =
+dbPerform1PlanarAITurn plane_ref =
do creature_locations <- dbGetContents plane_ref
- player_locations <- filterRO (liftM (== Player) . getCreatureFaction . entity) creature_locations
- native_locations <- filterRO (liftM (/= Player) . getCreatureFaction . entity) creature_locations
- should_randomly_generate_monster <- liftM (<= 10) $ linearRoll planar_turn_frequency
- when (length native_locations < length player_locations * 2 && should_randomly_generate_monster) $
- do p <- pickM $ map location player_locations
- m_spawn_position <- pickRandomClearSite_withTimeout (Just 2) 7 0 0 p (== RecreantFactory) plane_ref
- maybe (return () )
- (\spawn_position -> newCreature Pirates Recreant (Standing plane_ref spawn_position Here) >> return ()) $
- m_spawn_position
+ player_locations <- filterRO (liftM (== Player) . getCreatureFaction . child) creature_locations
+ num_npcs <- liftM length $ filterRO (liftM (/= Player) . getCreatureFaction . child) creature_locations
+ when (num_npcs < length player_locations * 2) $
+ do (terrain_type,species) <- pickM monster_spawns
+ _ <- spawnNPC terrain_type species plane_ref $ map parent $ player_locations
+ return ()
dbAdvanceTime plane_ref (1%planar_turn_frequency)
+-- |
+-- Spawn a non-player creature on the specified terrain type (or fail if not finding that terrain type)
+-- and of the specified species, on the specified plane, near one of the specified positions
+-- (presumably the list of positions of all player characters).
+spawnNPC :: TerrainPatch -> Species -> PlaneRef -> [Position] -> DB Bool
+spawnNPC terrain_type species plane_ref player_locations =
+ do p <- pickM player_locations
+ m_spawn_position <- pickRandomClearSite_withTimeout (Just 2) 7 0 0 p (== terrain_type) plane_ref
+ case m_spawn_position of
+ Nothing -> return False
+ Just spawn_position ->
+ do _ <- newCreature Pirates species (Standing plane_ref spawn_position Here)
+ return True
+
dbPerform1CreatureAITurn :: CreatureRef -> DB ()
-dbPerform1CreatureAITurn creature_ref =
- atomic $ liftM (flip dbBehave creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $
- do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects (return . const True)
+dbPerform1CreatureAITurn creature_ref = liftM (const ()) $ atomic (flip dbBehave creature_ref) $
+ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $
+ do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . child) =<< P.visibleObjects (return . const True)
(rand_x :: Integer) <- lift $ getRandomR (1,100)
rand_face <- lift $ pickM [minBound..maxBound]
(_,my_position) <- lift P.whereAmI
- let face_to_player = faceAt my_position (location player)
- return $ case distanceBetweenChessboard my_position (location player) of
+ let face_to_player = faceAt my_position (parent player)
+ return $ case distanceBetweenChessboard my_position (parent player) of
_ | rand_x < 5 -> Wait -- if AI gets stuck, this will make sure they waste time so the game doesn't hang
_ | rand_x < 20 -> Step rand_face
1 -> Attack face_to_player
diff --git a/src/VisibilityData.hs b/src/VisibilityData.hs
index cf285f1..7b8b4f2 100644
--- a/src/VisibilityData.hs
+++ b/src/VisibilityData.hs
@@ -2,7 +2,6 @@
module VisibilityData
(distanceCostForSight,
terrainHideMultiplier,
- terrainSpotMultiplier,
terrainOpacity,
maximumRangeForSpotCheck)
where
@@ -31,13 +30,8 @@ terrainHideMultiplier Ice = 0
terrainHideMultiplier Lava = 0 -- you definitely can't hide on lava
terrainHideMultiplier Glass = 0
terrainHideMultiplier RecreantFactory = 0
-
--- |
--- We multiply a creature's spot check by this number if it is standing on this terrain.
---
-terrainSpotMultiplier :: TerrainPatch -> Integer
-terrainSpotMultiplier RockFace = 3
-terrainSpotMultiplier _ = 1
+terrainHideMultiplier Downstairs = 2
+terrainHideMultiplier Upstairs = 0
-- |
-- We cast a ray between the spotter and the hider. This indicates to what extent each terrain type
@@ -60,6 +54,8 @@ terrainOpacity Ice = 0
terrainOpacity Lava = 0
terrainOpacity Glass = 0
terrainOpacity RecreantFactory = 0
+terrainOpacity Downstairs = 0
+terrainOpacity Upstairs = 0
-- |
-- The difficulty to spot an object at the given relative coordinates, taking facing into account.