diff --git a/roguestar-engine.cabal b/roguestar-engine.cabal --- a/roguestar-engine.cabal +++ b/roguestar-engine.cabal @@ -1,53 +1,39 @@ -name: roguestar-engine -version: 0.4.0.3 -license: OtherLicense -license-file: LICENSE -author: Christopher Lane Hinson -maintainer: Christopher Lane Hinson - -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 . -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 +build-depends: hslogger >=1.1.0 && <1.2, + priority-sync >=0.2.1.0 && <0.3, PSQueue >=1.1 && <1.2, + bytestring >=0.9.1.5 && <0.10, parallel >=2.2.0.1 && <2.3, + stm >=2.1.1.2 && <2.2, data-memocombinators >=0.4.0 && <0.5, + MonadRandom >=0.1.4 && <0.2, MaybeT >=0.1.2 && <0.2, + mtl >=1.1.0.2 && <1.2, random >=1.0.0.2 && <1.1, + old-time >=1.0.0.3 && <1.1, array >=0.3.0.0 && <0.3.1, + containers >=0.3.0.0 && <0.3.1, base >=4 && <5 +homepage: http://roguestar.downstairspeople.org/ +synopsis: Sci-fi roguelike game. Backend. +description: Requires roguestar and roguestar-glut. +category: Game +author: Christopher Lane Hinson +tested-with: GHC ==6.12.1 + +executable: roguestar-engine +main-is: Main.hs +pkgconfig-depends: +hs-source-dirs: src +other-modules: TravelData VisibilityData Stats FactionData Behavior + Alignment PlaneData Grids Perception PlaneVisibility Turns Plane + CreatureData StatsData Protocol Character Tool Substances + HierarchicalDatabase Travel ToolData CharacterData Creature Facing + DBPrivate RNG Species Position TerrainData Combat Tests DBData + GridRayCaster BeginGame SpeciesData TimeCoordinate DB + AttributeGeneration CreatureAttribute Building BuildingData Town + Random PlayerState MakeData DBErrorFlag Construction Make Activate + Contact DeviceActivation WorkCluster Planet PlanetData Logging + NodeData CharacterAdvancement +ghc-prof-options: -prof -auto-all +ghc-shared-options: -prof -auto-all +ghc-options: -threaded -fno-warn-type-defaults diff --git a/src/Activate.hs b/src/Activate.hs --- a/src/Activate.hs +++ b/src/Activate.hs @@ -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 - + diff --git a/src/AttributeGeneration.hs b/src/AttributeGeneration.hs --- a/src/AttributeGeneration.hs +++ b/src/AttributeGeneration.hs @@ -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) } diff --git a/src/BeginGame.hs b/src/BeginGame.hs --- a/src/BeginGame.hs +++ b/src/BeginGame.hs @@ -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 diff --git a/src/Behavior.hs b/src/Behavior.hs --- a/src/Behavior.hs +++ b/src/Behavior.hs @@ -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 diff --git a/src/Building.hs b/src/Building.hs --- a/src/Building.hs +++ b/src/Building.hs @@ -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 } diff --git a/src/BuildingData.hs b/src/BuildingData.hs --- a/src/BuildingData.hs +++ b/src/BuildingData.hs @@ -2,15 +2,28 @@ module BuildingData (Building(..), BuildingType(..), + NodeType(..), + all_nodes, + showBuilding, buildingOccupies) where data Building = Building deriving (Read,Show) -data BuildingType = Monolith | Portal +data BuildingType = Node NodeType | Portal deriving (Eq,Ord,Read,Show) +data NodeType = Monolith | Anchor + deriving (Eq,Ord,Read,Show,Enum,Bounded) + +all_nodes :: [NodeType] +all_nodes = [minBound..maxBound] + +showBuilding :: BuildingType -> String +showBuilding (Node n) = show n +showBuilding x = show x + -- | Get a list of squares, relative to the center of the building (0,0), -- that a building occupies. These squares must be free of unfriendly terrain -- (mountains, trees, water, lava, etc.) and no other objects can co-occupy these squares. @@ -18,8 +31,8 @@ -- A goal is that every building type has a unique occupation signature, -- so that it can be identified by it's shape alone. buildingOccupies :: BuildingType -> [(Integer,Integer)] --- Monolith: X -buildingOccupies Monolith = [(0,0)] --- Portal: XXX +-- Monolith: X +buildingOccupies (Node _) = [(0,0)] +-- Portal: XXX buildingOccupies Portal = [(0,0),(-1,0),(1,0)] diff --git a/src/Character.hs b/src/Character.hs --- a/src/Character.hs +++ b/src/Character.hs @@ -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 diff --git a/src/CharacterAdvancement.hs b/src/CharacterAdvancement.hs new file mode 100644 --- /dev/null +++ b/src/CharacterAdvancement.hs @@ -0,0 +1,81 @@ +module CharacterAdvancement + (CharacterBumpRequest(..), + CharacterBumpResult(..), + characterFitness, + bumpCharacter, + characterLevel, + newCharacterLevel, + newCharacterClass) + where + +import qualified Data.Map as Map +import CreatureData +import CharacterData + +-- | +-- Cause a character to advance in level or to gain a specific CharacterClass. +data CharacterBumpRequest = + -- Award a character points. If the character gain enough points to advance in character class, + -- then do this, otherwise, he just accumulates the points. + AwardCharacter Integer + -- Apply a specific CharacterClass to a character. If he already has this CharacterClass, + -- then we back off and give him the points instead. + | ForceCharacter CharacterClass + +data CharacterBumpResult = + CharacterAwarded { character_points_awarded :: Integer, + character_new :: Creature } + | CharacterAdvanced { character_new_level :: Integer, + character_new :: Creature } + | CharacterForced { character_new_character_class :: CharacterClass, + character_new :: Creature } + + +-- | +-- Increases the character score by the set amount. +-- If the score is high enough that the character can advance to the next level, +-- this function will apply that advancement. +-- +bumpCharacter :: CharacterBumpRequest -> Creature -> CharacterBumpResult +bumpCharacter (ForceCharacter character_class) c = + if character_class `elem` Map.keys (creature_levels c) + then bumpCharacter (AwardCharacter $ characterFitness new_character - characterFitness c) c + else CharacterForced { + character_new_character_class = character_class, + character_new = new_character } + where new_character = applyToCreature character_class c +bumpCharacter (AwardCharacter n) c = + if fitness_gain >= bumped_score + then CharacterAdvanced { + character_new_level = characterLevel new_character, + character_new = new_character { creature_points = bumped_score - fitness_gain } } + else CharacterAwarded { + character_points_awarded = n, + character_new = c { creature_points = bumped_score } } + where bumped_score = creature_points c + n + fitness_gain = characterFitness new_character - characterFitness c + new_character = applyToCreature (Map.keys $ creature_levels c) c + +newCharacterClass :: CharacterBumpResult -> Maybe CharacterClass +newCharacterClass (CharacterForced character_class _) = Just character_class +newCharacterClass _ = Nothing + +newCharacterLevel :: CharacterBumpResult -> Maybe Integer +newCharacterLevel (CharacterAdvanced new_level _) = Just new_level +newCharacterLevel _ = Nothing + +-- | +-- Answers the character level. This is the maximum of the number +-- of levels the Character has in any class. +-- A rather arbitrary (non-representative of game balance) +-- measure of Character power. +-- +characterLevel :: Creature -> Integer +characterLevel = maximum . Map.elems . creature_levels + +-- | +-- Answers the estimated fitness (powerfulness) of the Character. +-- +characterFitness :: Creature -> Integer +characterFitness c = sum $ (Map.elems $ creature_aptitude c) ++ (Map.elems $ creature_ability c) + diff --git a/src/CharacterData.hs b/src/CharacterData.hs --- a/src/CharacterData.hs +++ b/src/CharacterData.hs @@ -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] diff --git a/src/Construction.hs b/src/Construction.hs --- a/src/Construction.hs +++ b/src/Construction.hs @@ -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 diff --git a/src/Contact.hs b/src/Contact.hs --- a/src/Contact.hs +++ b/src/Contact.hs @@ -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 diff --git a/src/Creature.hs b/src/Creature.hs --- a/src/Creature.hs +++ b/src/Creature.hs @@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} -module Creature +module Creature (generateInitialPlayerCreature, newCreature, Roll(..), @@ -44,16 +44,16 @@ -- 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 diff --git a/src/CreatureAttribute.hs b/src/CreatureAttribute.hs --- a/src/CreatureAttribute.hs +++ b/src/CreatureAttribute.hs @@ -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) diff --git a/src/CreatureData.hs b/src/CreatureData.hs --- a/src/CreatureData.hs +++ b/src/CreatureData.hs @@ -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 diff --git a/src/DB.hs b/src/DB.hs --- a/src/DB.hs +++ b/src/DB.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, FlexibleContexts, Rank2Types, RelaxedPolyRec #-} +{-# LANGUAGE MultiParamTypeClasses, + ExistentialQuantification, + FlexibleContexts, + Rank2Types, + RelaxedPolyRec, + ScopedTypeVariables #-} module DB (DBResult, @@ -34,9 +39,10 @@ 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 () diff --git a/src/DBData.hs b/src/DBData.hs --- a/src/DBData.hs +++ b/src/DBData.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, + MultiParamTypeClasses, + FunctionalDependencies, + UndecidableInstances, + ScopedTypeVariables #-} module DBData (Reference, @@ -11,9 +15,9 @@ 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) diff --git a/src/DBErrorFlag.hs b/src/DBErrorFlag.hs --- a/src/DBErrorFlag.hs +++ b/src/DBErrorFlag.hs @@ -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 diff --git a/src/DBPrivate.hs b/src/DBPrivate.hs --- a/src/DBPrivate.hs +++ b/src/DBPrivate.hs @@ -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 + diff --git a/src/Grids.hs b/src/Grids.hs --- a/src/Grids.hs +++ b/src/Grids.hs @@ -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) diff --git a/src/Logging.hs b/src/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Logging.hs @@ -0,0 +1,22 @@ +module Logging + (log_database, + log_plane, + log_travel, + log_turns, + module System.Log.Logger) + where + +import System.Log.Logger + +log_database :: String +log_database = "engine.database" + +log_plane :: String +log_plane = "engine.plane" + +log_travel :: String +log_travel = "engine.travel" + +log_turns :: String +log_turns = "engine.turns" + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 + diff --git a/src/NodeData.hs b/src/NodeData.hs new file mode 100644 --- /dev/null +++ b/src/NodeData.hs @@ -0,0 +1,13 @@ +module NodeData + (nodeEffect) + where + +import BuildingData +import CreatureData +import CharacterData +import CharacterAdvancement + +nodeEffect :: NodeType -> CharacterBumpRequest +nodeEffect Anchor = AwardCharacter 1 +nodeEffect Monolith = ForceCharacter StarChild + diff --git a/src/Perception.hs b/src/Perception.hs --- a/src/Perception.hs +++ b/src/Perception.hs @@ -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 + diff --git a/src/Plane.hs b/src/Plane.hs --- a/src/Plane.hs +++ b/src/Plane.hs @@ -2,11 +2,15 @@ module Plane (dbNewPlane, planetName, + randomPlanetName, + planeDepth, dbGetCurrentPlane, dbDistanceBetweenSquared, pickRandomClearSite_withTimeout, pickRandomClearSite, getPlanarPosition, + getBeneath, + getSubsequent, terrainAt, setTerrainAt, whatIsOccupying, @@ -25,52 +29,77 @@ import 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. diff --git a/src/PlaneVisibility.hs b/src/PlaneVisibility.hs --- a/src/PlaneVisibility.hs +++ b/src/PlaneVisibility.hs @@ -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 diff --git a/src/Planet.hs b/src/Planet.hs --- a/src/Planet.hs +++ b/src/Planet.hs @@ -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 } diff --git a/src/PlanetData.hs b/src/PlanetData.hs --- a/src/PlanetData.hs +++ b/src/PlanetData.hs @@ -2,7 +2,6 @@ module PlanetData (PlanetInfo(..), addTown, - addPriority, all_planets, pgto_planets) where @@ -25,51 +24,57 @@ 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] + diff --git a/src/PlayerState.hs b/src/PlayerState.hs --- a/src/PlayerState.hs +++ b/src/PlayerState.hs @@ -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 diff --git a/src/Protocol.hs b/src/Protocol.hs --- a/src/Protocol.hs +++ b/src/Protocol.hs @@ -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` diff --git a/src/Species.hs b/src/Species.hs --- a/src/Species.hs +++ b/src/Species.hs @@ -1,6 +1,6 @@ module Species - (player_race_names, + (player_species_names, SpeciesData(..), speciesInfo) where @@ -13,10 +13,10 @@ import 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, diff --git a/src/SpeciesData.hs b/src/SpeciesData.hs --- a/src/SpeciesData.hs +++ b/src/SpeciesData.hs @@ -9,6 +9,7 @@ | Androsynth | Ascendant | Caduceator + | DustVortex | Encephalon | Goliath | Hellion diff --git a/src/TerrainData.hs b/src/TerrainData.hs --- a/src/TerrainData.hs +++ b/src/TerrainData.hs @@ -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 diff --git a/src/Tool.hs b/src/Tool.hs --- a/src/Tool.hs +++ b/src/Tool.hs @@ -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 () diff --git a/src/Travel.hs b/src/Travel.hs --- a/src/Travel.hs +++ b/src/Travel.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Travel (stepCreature, turnCreature, + ClimbOutcome, + resolveClimb, + executeClimb, TeleportJumpOutcome, resolveTeleportJump, executeTeleportJump) @@ -19,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 () diff --git a/src/TravelData.hs b/src/TravelData.hs new file mode 100644 --- /dev/null +++ b/src/TravelData.hs @@ -0,0 +1,6 @@ + +module TravelData + (ClimbDirection(..)) where + +data ClimbDirection = ClimbUp | ClimbDown + deriving (Read,Show) diff --git a/src/Turns.hs b/src/Turns.hs --- a/src/Turns.hs +++ b/src/Turns.hs @@ -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 diff --git a/src/VisibilityData.hs b/src/VisibilityData.hs --- a/src/VisibilityData.hs +++ b/src/VisibilityData.hs @@ -2,7 +2,6 @@ module VisibilityData (distanceCostForSight, terrainHideMultiplier, - terrainSpotMultiplier, terrainOpacity, maximumRangeForSpotCheck) where @@ -31,13 +30,8 @@ terrainHideMultiplier 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.