roguestar-engine 0.4.0.3 → 0.6.0.0
raw patch · 38 files changed
+1228/−729 lines, 38 filesdep +hslogger
Dependencies added: hslogger
Files
- roguestar-engine.cabal +39/−53
- src/Activate.hs +2/−2
- src/AttributeGeneration.hs +1/−1
- src/BeginGame.hs +5/−2
- src/Behavior.hs +27/−13
- src/Building.hs +28/−12
- src/BuildingData.hs +17/−4
- src/Character.hs +14/−3
- src/CharacterAdvancement.hs +81/−0
- src/CharacterData.hs +22/−21
- src/Construction.hs +1/−1
- src/Contact.hs +11/−8
- src/Creature.hs +10/−10
- src/CreatureAttribute.hs +4/−5
- src/CreatureData.hs +12/−9
- src/DB.hs +142/−115
- src/DBData.hs +177/−151
- src/DBErrorFlag.hs +1/−1
- src/DBPrivate.hs +24/−33
- src/Grids.hs +13/−13
- src/Logging.hs +22/−0
- src/Main.hs +32/−23
- src/NodeData.hs +13/−0
- src/Perception.hs +18/−10
- src/Plane.hs +84/−35
- src/PlaneVisibility.hs +16/−9
- src/Planet.hs +42/−5
- src/PlanetData.hs +41/−36
- src/PlayerState.hs +19/−8
- src/Protocol.hs +76/−38
- src/Species.hs +22/−19
- src/SpeciesData.hs +1/−0
- src/TerrainData.hs +62/−22
- src/Tool.hs +19/−14
- src/Travel.hs +73/−15
- src/TravelData.hs +6/−0
- src/Turns.hs +47/−30
- src/VisibilityData.hs +4/−8
roguestar-engine.cabal view
@@ -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
src/Activate.hs view
@@ -37,11 +37,11 @@ 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- +
src/AttributeGeneration.hs view
@@ -11,7 +11,7 @@ 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) }
src/BeginGame.hs view
@@ -34,6 +34,7 @@ homeBiome Perennial = GrasslandBiome homeBiome Recreant = TundraBiome homeBiome Reptilian = ForestBiome+homeBiome DustVortex = DesertBiome startingEquipmentByClass :: CharacterClass -> [Tool] startingEquipmentByClass Barbarian = [kinetic_fleuret]@@ -47,6 +48,7 @@ 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 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 @@ 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
src/Behavior.hs view
@@ -15,6 +15,7 @@ import Combat import Activate import Travel+import TravelData import Creature import CreatureData import Plane@@ -29,9 +30,11 @@ -- -- 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 @@ | 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 @@ 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 @@ () | 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 @@ 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 (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 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 @@ 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 @@ -- | 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
src/Building.hs view
@@ -16,6 +16,8 @@ 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 @@ 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 @@ -- | 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 }
src/BuildingData.hs view
@@ -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 @@ -- 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)]
src/Character.hs view
@@ -18,7 +18,7 @@ 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 @@ -- 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 @@ ------------------------------------------------------------------------------- -- -- 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@@ -93,4 +93,15 @@ 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
+ src/CharacterAdvancement.hs view
@@ -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)+
src/CharacterData.hs view
@@ -6,31 +6,32 @@ 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]
src/Construction.hs view
@@ -18,7 +18,7 @@ -- 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
src/Contact.hs view
@@ -19,7 +19,7 @@ -- | '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 @@ 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 @@ _ -> 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
src/Creature.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} -module Creature +module Creature (generateInitialPlayerCreature, newCreature, Roll(..),@@ -44,16 +44,16 @@ -- 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 @@ 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 @@ -- | 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 @@ 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 @@ 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
src/CreatureAttribute.hs view
@@ -28,12 +28,11 @@ 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)
src/CreatureData.hs view
@@ -1,5 +1,5 @@ -module CreatureData +module CreatureData (Creature(..), CreatureGender(..), CreatureAptitude(..),@@ -30,11 +30,12 @@ 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 @@ 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 @@ applyToCreature g c = c { creature_gender = g } -- | The seven aptitudes.-data CreatureAptitude = +data CreatureAptitude = Strength | Speed | Constitution
src/DB.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, FlexibleContexts, Rank2Types, RelaxedPolyRec #-}+{-# LANGUAGE MultiParamTypeClasses,+ ExistentialQuantification,+ FlexibleContexts,+ Rank2Types,+ RelaxedPolyRec,+ ScopedTypeVariables #-} module DB (DBResult,@@ -34,9 +39,10 @@ dbGetAncestors, dbWhere, dbGetContents,- dbSetStartingRace,- dbGetStartingRace,+ dbSetStartingSpecies,+ dbGetStartingSpecies, ro, atomic,+ logDB, mapRO, filterRO, sortByRO, dbGetTimeCoordinate, dbAdvanceTime,@@ -47,8 +53,7 @@ dbHasSnapshot, module DBData, module DBErrorFlag,- module Random,- dbTrace)+ module Random) where import DBPrivate@@ -59,7 +64,7 @@ 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 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 @@ 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 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,17 +168,19 @@ 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 @@ 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)+ 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)+-- | 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 @@ 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 = 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 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 = 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 @@ 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 @@ -- | -- 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 @@ -- | -- 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.+-- 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 })+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 @@ 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 = 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 }+ 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 ()
src/DBData.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances,+ MultiParamTypeClasses,+ FunctionalDependencies,+ UndecidableInstances,+ ScopedTypeVariables #-} module DBData (Reference,@@ -11,9 +15,9 @@ the_universe, (=:=), (=/=), GenericReference(..),- locationsOf, ReferenceType(..),- LocationType(..),+ LocationChild(..),+ LocationParent(..), Location, Position(..), Standing(..),@@ -22,6 +26,8 @@ Wielded(..), Constructed(..), Subsequent(..),+ Beneath(..),+ Type, _nullary, _creature, _tool,@@ -33,34 +39,35 @@ _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 @@ _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 @@ -- -- 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 @@ -- -- 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+generalizeParent :: Location e t -> Location e ()+generalizeParent = 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+generalizeChild :: Location e t -> Location (Reference ()) t+generalizeChild = unsafeLocation -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+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 -asLocationTyped :: (LocationType e,LocationType t) => Type e -> Type t -> Location m e t -> Location m e t+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+asType :: Type e -> e -> e+asType _ = id -coerceLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Maybe (Location m e t)-coerceLocationTyped = const coerceLocation+coerceParentTyped :: (LocationParent p) =>+ Type p -> Location c x -> Maybe (Location c p)+coerceParentTyped = const coerceParent -isLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Bool-isLocationTyped t = isJust . coerceLocationTyped t+isParentTyped :: (LocationParent p) => Type p -> Location c x -> Bool+isParentTyped t = isJust . coerceParentTyped t -coerceEntityTyped :: (LocationType e,LocationType t) => Type e -> Location m x t -> Maybe (Location m e t)-coerceEntityTyped = const coerceEntity+coerceChildTyped :: (LocationChild c) =>+ Type c -> Location x p -> Maybe (Location c p)+coerceChildTyped = const coerceChild -isEntityTyped :: (LocationType e,LocationType t) => Type e -> Location m x t -> Bool-isEntityTyped t = isJust . coerceEntityTyped t+isChildTyped :: (LocationChild c) => Type c -> Location x p -> Bool+isChildTyped t = isJust . coerceChildTyped t -coerceLocation :: (LocationType e,LocationType t) => Location m e x -> Maybe (Location m e t)-coerceLocation = coerceLocationRecord+coerceParent :: forall c x p. (LocationParent p) =>+ Location c x -> Maybe (Location c p)+coerceParent l =+ do (_ :: p) <- extractParent l+ return $ unsafeLocation l -coerceEntity :: (LocationType e,LocationType t) => Location m x t -> Maybe (Location m e t)-coerceEntity = coerceLocationRecord+coerceChild :: forall x p c. (LocationChild c) =>+ Location x p -> Maybe (Location c p)+coerceChild l =+ do (_ :: c) <- extractChild l+ return $ unsafeLocation l -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))+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 -location :: (LocationType t) => Location m e t -> t-location l = fromMaybe (error "location: type error") $ extractLocation l+parent :: (LocationParent p) => Location c p -> p+parent l = fromMaybe (error "parent: type error") $ extractParent l -entity :: (LocationType e) => Location m e t -> e-entity l = fromMaybe (error "entity: type error") $ extractEntity l+child :: (LocationChild c) => Location c p -> c+child l = fromMaybe (error "child: type error") $ extractChild l -class (Eq a,Ord a) => LocationType a where- extractLocation :: Location m e t -> Maybe a- extractEntity :: Location m e t -> Maybe a+class (Eq a,Ord a) => LocationParent a where+ extractParent :: Location e t -> Maybe a -instance LocationType Standing where- extractLocation (IsStanding _ s) = Just s- extractLocation _ = Nothing- extractEntity = const Nothing+class (Eq a,Ord a) => LocationChild a where+ extractChild :: Location e t -> Maybe a -instance LocationType Dropped where- extractLocation (IsDropped _ d) = Just d- extractLocation _ = Nothing- extractEntity = const Nothing+instance LocationParent Standing where+ extractParent (IsStanding _ s) = Just s+ extractParent _ = Nothing -instance LocationType Inventory where- extractLocation (InInventory _ i) = Just i- extractLocation _ = Nothing- extractEntity = const Nothing+instance LocationParent Dropped where+ extractParent (IsDropped _ d) = Just d+ extractParent _ = Nothing -instance LocationType Wielded where- extractLocation (IsWielded _ i) = Just i- extractLocation _ = Nothing- extractEntity = const Nothing+instance LocationParent Inventory where+ extractParent (InInventory _ i) = Just i+ extractParent _ = Nothing -instance LocationType Constructed where- extractLocation (IsConstructed _ i) = Just i- extractLocation _ = Nothing- extractEntity = const Nothing+instance LocationParent Wielded where+ extractParent (IsWielded _ i) = Just i+ extractParent _ = Nothing -instance LocationType TheUniverse where- extractLocation (InTheUniverse {}) = Just TheUniverse- extractLocation _ = Nothing- extractEntity = const Nothing+instance LocationParent Constructed where+ extractParent (IsConstructed _ i) = Just i+ extractParent _ = Nothing -instance LocationType Subsequent where- extractLocation (IsSubsequent _ i) = Just i- extractLocation _ = Nothing- extractEntity = const Nothing+instance LocationParent TheUniverse where+ extractParent (InTheUniverse {}) = Just TheUniverse+ extractParent _ = Nothing -instance LocationType () where- extractLocation = const $ Just ()- extractEntity = const Nothing+instance LocationParent Subsequent where+ extractParent (IsSubsequent _ i) = Just i+ extractParent _ = 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 LocationParent Beneath where+ extractParent (IsBeneath _ i) = Just i+ extractParent _ = 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 LocationParent () where+ extractParent = const $ Just () -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 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 ReferenceType a => LocationType (Reference a) where- extractLocation = coerceReference . getLocation- extractEntity = coerceReference . getEntity+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 (LocationType a,LocationType b) => LocationType (a,b) where- extractLocation l = liftM2 (,) (extractLocation l) (extractLocation l)- extractEntity l = liftM2 (,) (extractEntity l) (extractEntity l)+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)
src/DBErrorFlag.hs view
@@ -6,7 +6,7 @@ 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
src/DBPrivate.hs view
@@ -5,8 +5,6 @@ unsafeReference, toUID, Location(..),- M,- S, unsafeLocation, Position(..), Standing(..),@@ -16,6 +14,7 @@ Constructed(..), TheUniverse(..), Subsequent(..),+ Beneath(..), CreatureRef, ToolRef, PlaneRef,@@ -35,9 +34,8 @@ -- 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 @@ -- | -- 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 @@ -- | -- 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 @@ 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 (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 @@ 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 @@ child (IsConstructed e _) = toUID e child (InTheUniverse e) = toUID e child (IsSubsequent e _) = toUID e+ child (IsBeneath e _) = toUID e+
src/Grids.hs view
@@ -31,8 +31,8 @@ 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 @@ 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)+ 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 = +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)
+ src/Logging.hs view
@@ -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"+
src/Main.hs view
@@ -12,6 +12,7 @@ import Data.Version import Paths_roguestar_engine import Data.List (intersperse)+import System.Log.Logger roguestar_version_number :: String roguestar_version_number = concat $@@ -28,39 +29,46 @@ -- 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 = do args <- getArgs mapM_ runByArgs args+
+ src/NodeData.hs view
@@ -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+
src/Perception.hs view
@@ -15,7 +15,8 @@ Perception.getCreatureFaction, whereAmI, localBiome,- compass)+ compass,+ depth) where import Control.Monad.Reader@@ -32,6 +33,7 @@ import TerrainData import BuildingData import Building+import Plane newtype (DBReadable db) => DBPerception db a = DBPerception { fromPerception :: (ReaderT CreatureRef db a) } @@ -67,11 +69,11 @@ 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 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 @@ 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+
src/Plane.hs view
@@ -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 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 @@ -- 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 @@ -- | 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.
src/PlaneVisibility.hs view
@@ -23,14 +23,14 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ 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 @@ 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
src/Planet.hs view
@@ -12,21 +12,29 @@ 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 (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 }
src/PlanetData.hs view
@@ -2,7 +2,6 @@ module PlanetData (PlanetInfo(..), addTown,- addPriority, all_planets, pgto_planets) where@@ -25,51 +24,57 @@ 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,- 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,+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)] }+ 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]+
src/PlayerState.hs view
@@ -10,15 +10,17 @@ 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 @@ | 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 @@ 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 @@ 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
src/Protocol.hs view
@@ -45,7 +45,7 @@ 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 @@ -- 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 @@ 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 ["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 @@ 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,11 +308,23 @@ 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 terrain_map <- maybe (return []) (dbGetVisibleTerrainForFaction Player) maybe_plane_ref @@ -320,16 +334,17 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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",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 @@ 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 @@ 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`
src/Species.hs view
@@ -1,6 +1,6 @@ module Species- (player_race_names,+ (player_species_names, SpeciesData(..), speciesInfo) where@@ -13,10 +13,10 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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,
src/SpeciesData.hs view
@@ -9,6 +9,7 @@ | Androsynth | Ascendant | Caduceator+ | DustVortex | Encephalon | Goliath | Hellion
src/TerrainData.hs view
@@ -6,6 +6,8 @@ TerrainGenerationData(..), TerrainPlacement, recreantFactories,+ stairsUp,+ stairsDown, generateTerrain, generateExampleTerrain, prettyPrintTerrain,@@ -24,16 +26,21 @@ -- 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 @@ | 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 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 = [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 @@ 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 (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 @@ 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 Glass = '_' terrainPatchToASCII Lava = '^' terrainPatchToASCII RecreantFactory = 'o'+terrainPatchToASCII Upstairs = '<'+terrainPatchToASCII Downstairs = '>' exampleTerrainGenerator :: TerrainGenerationData exampleTerrainGenerator = TerrainGenerationData
src/Tool.hs view
@@ -18,38 +18,43 @@ 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 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 ()
src/Travel.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Travel (stepCreature, turnCreature,+ ClimbOutcome,+ resolveClimb,+ executeClimb, TeleportJumpOutcome, resolveTeleportJump, executeTeleportJump)@@ -19,28 +24,81 @@ 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. -- If the retries are negative, the teleport will be made artificially innacurate. --@@ -59,18 +117,18 @@ 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 ()
+ src/TravelData.hs view
@@ -0,0 +1,6 @@++module TravelData+ (ClimbDirection(..)) where++data ClimbDirection = ClimbUp | ClimbDown+ deriving (Read,Show)
src/Turns.hs view
@@ -20,10 +20,13 @@ 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 @@ 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 @@ 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
src/VisibilityData.hs view
@@ -2,7 +2,6 @@ module VisibilityData (distanceCostForSight, terrainHideMultiplier,- terrainSpotMultiplier, terrainOpacity, maximumRangeForSpotCheck) where@@ -31,13 +30,8 @@ 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 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.