Use the Reader monad more heavily, starting to move some functions out of the DB monad.

parent 2fba10db
......@@ -6,10 +6,13 @@ dontuse:
echo "cabal install"
configure:
cabal-dev configure --ghc-options="-Werror" --enable-library-profiling --enable-executable-profiling
cabal-dev configure --ghc-options="-Werror"
configure-profiling:
--enable-library-profiling --enable-executable-profiling
build:
cabal-dev build
cabal-dev build -j
clean:
cabal-dev clean
......@@ -22,20 +25,4 @@ check: clean
cabal-dev build
depends:
cabal-dev install cipher-aes-0.1.8
cabal-dev install MaybeT
cabal-dev install MonadCatchIO-transformers
cabal-dev install aeson
cabal-dev install data-lens-template
cabal-dev install data-memocombinators
cabal-dev install hastache
cabal-dev install hslogger
cabal-dev install mwc-random
cabal-dev install snap-core
cabal-dev install snap-server
cabal-dev install snap
cabal-dev install streams
cabal-dev install system-uuid
cabal-dev install data-lens-template
cabal-dev install snap
cabal-dev install streams
cabal-dev install -j cipher-aes MaybeT MonadCatchIO-transformers aeson data-lens-template data-memocombinators hastache hslogger mwc-random snap-core snap-server snap streams system-uuid data-lens-template snap streams
......@@ -15,6 +15,7 @@ import Roguestar.Lib.Data.FacingData
import Roguestar.Lib.Time
import Roguestar.Lib.Tool
import Control.Monad.Error
import Control.Monad.Reader
import Roguestar.Lib.Behavior.Combat
import Roguestar.Lib.Behavior.Activate
import Roguestar.Lib.Behavior.Travel
......@@ -127,7 +128,7 @@ dbBehave_ (Unwield) creature_ref =
increaseTime creature_ref =<< actionTime creature_ref
dbBehave_ (Drop tool_ref) creature_ref =
do tool_parent <- liftM parentReference $ whereIs tool_ref
do tool_parent <- liftM parentReference $ asks $ whereIs tool_ref
already_wielded <- getWielded creature_ref
when (tool_parent =/= creature_ref) $ throwError $ DBErrorFlag ToolIs_NotInInventory
_ <- move tool_ref =<< dropTool tool_ref
......
......@@ -10,6 +10,7 @@ import Roguestar.Lib.Core.Monster
import Roguestar.Lib.DB
import Control.Monad.Error
import Control.Monad.Random
import Control.Monad.Reader
import Roguestar.Lib.Data.Substances
-- | Outcome of activating a tool.
......@@ -21,7 +22,7 @@ data ActivationOutcome =
resolveActivation :: (MonadRandom db, DBReadable db) => MonsterRef -> db ActivationOutcome
resolveActivation creature_ref =
do tool_ref <- maybe (throwError $ DBErrorFlag NoToolWielded) return =<< getWielded creature_ref
tool <- dbGetTool tool_ref
tool <- asks $ getTool tool_ref
case tool of
DeviceTool {} -> throwError $ DBErrorFlag ToolIs_Innapropriate
Sphere (ChromaliteSubstance c) ->
......
......@@ -15,6 +15,7 @@ import Roguestar.Lib.Tool
import Roguestar.Lib.Data.ToolData
import Control.Monad.Error
import Control.Monad.Random
import Control.Monad.Reader
import Roguestar.Lib.Data.FacingData
import Data.Maybe
import Roguestar.Lib.Utility.Contact
......@@ -49,7 +50,7 @@ attackModel attacker_ref =
case m_tool_ref of
Nothing -> return $ UnarmedAttackModel attacker_ref
Just tool_ref ->
do tool <- dbGetTool tool_ref
do tool <- asks $ getTool tool_ref
case tool of
DeviceTool Gun device -> return $ RangedAttackModel attacker_ref tool_ref device
DeviceTool Sword device -> return $ MeleeAttackModel attacker_ref tool_ref device
......
......@@ -13,7 +13,7 @@ import Roguestar.Lib.Data.TerrainData
import Roguestar.Lib.Data.FacingData
import Control.Monad
import Control.Monad.Maybe
import Control.Monad.Trans
import Control.Monad.Reader
import Roguestar.Lib.Position
import Data.Maybe
......@@ -21,7 +21,7 @@ import Data.Maybe
-- True iff any terrain modification actually occured.
modifyFacingTerrain :: (Terrain -> Terrain) -> Facing -> MonsterRef -> DB Bool
modifyFacingTerrain f face creature_ref = liftM (fromMaybe False) $ runMaybeT $
do (Parent plane_ref :: Parent Plane,position :: Position) <- MaybeT $ liftM fromLocation $ whereIs creature_ref
do (Parent plane_ref :: Parent Plane,position :: Position) <- MaybeT $ liftM fromLocation $ asks $ whereIs creature_ref
let target_position = offsetPosition (facingToRelative face) position
prev_terrain <- lift $ terrainAt plane_ref target_position
let new_terrain = f prev_terrain
......
......@@ -13,28 +13,28 @@ module Roguestar.Lib.Behavior.Travel
resolveStepWithTemporalWeb)
where
import Control.Monad.Maybe
import Roguestar.Lib.Data.FacingData
import Roguestar.Lib.DB as DB
import Roguestar.Lib.Core.Plane as Plane
import Data.Maybe
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Maybe
import Control.Monad.Random
import Control.Monad.Reader
import Data.Maybe
import Data.Ord
import Roguestar.Lib.Position as Position
import Roguestar.Lib.Data.TerrainData
import Data.List (minimumBy)
import Roguestar.Lib.Behavior.Outcome
import Roguestar.Lib.Core.Monster
import Roguestar.Lib.Core.Plane as Plane
import Roguestar.Lib.DB as DB
import Roguestar.Lib.Data.FacingData
import Roguestar.Lib.Data.MonsterData
import Roguestar.Lib.Logging
import Roguestar.Lib.Data.TerrainData
import Roguestar.Lib.Data.TravelData
import Roguestar.Lib.Logging
import Roguestar.Lib.PlaneVisibility
import Roguestar.Lib.Position as Position
import Roguestar.Lib.Time
import Roguestar.Lib.Utility.DetailedLocation
import Roguestar.Lib.Utility.DetailedTravel as DetailedTravel
import Roguestar.Lib.Behavior.Outcome
import Roguestar.Lib.Time
import Roguestar.Lib.PlaneVisibility
data MoveOutcome =
MoveGood { _move_monster :: MonsterRef, move_from :: Standing, _move_to :: Standing }
......@@ -114,7 +114,7 @@ resolveClimb creature_ref direction = liftM (fromMaybe ClimbFailed) $ runMaybeT
lift $ logDB gameplay_log DEBUG $ "Stepping " ++ show direction ++ " from: " ++ show (plane_ref,pos)
plane_destination <- MaybeT $ case direction of
ClimbDown -> getBeneath plane_ref
ClimbUp -> liftM (fmap asParent . fromLocation) $ DB.whereIs plane_ref
ClimbUp -> liftM (fmap asParent . fromLocation) $ asks $ DB.whereIs plane_ref
lift $ logDB gameplay_log DEBUG $ "Stepping " ++ show direction ++ " to: " ++ show plane_destination
pos' <- lift $ pickRandomClearSite 10 0 0 pos (== expected_landing_terrain) plane_destination
return $ ClimbGood direction creature_ref $
......
......@@ -13,6 +13,7 @@ import Roguestar.Lib.Data.SpeciesData
import Roguestar.Lib.Data.MonsterData (Monster)
import Roguestar.Lib.Core.Plane
import Control.Monad
import Control.Monad.Reader
import Roguestar.Lib.Core.Monster
import Data.Ratio
import Roguestar.Lib.Data.FacingData
......@@ -47,7 +48,7 @@ dbFinishPlanarAITurns :: PlaneRef -> DB ()
dbFinishPlanarAITurns plane_ref =
do logDB gameplay_log INFO $ "Running turns for plane: id=" ++ show (toUID plane_ref)
sweepDead plane_ref
(all_creatures_on_plane :: [MonsterRef]) <- liftM asChildren $ getContents plane_ref
(all_creatures_on_plane :: [MonsterRef]) <- liftM asChildren $ asks $ getContents plane_ref
any_players_left <- liftM (any (== Player)) $ mapM getMonsterFaction all_creatures_on_plane
next_turn <- dbNextTurn $ List.map genericReference all_creatures_on_plane ++ [genericReference plane_ref]
case next_turn of
......@@ -76,7 +77,7 @@ monster_spawns = [(RecreantFactory,RedRecreant)]
dbPerform1PlanarAITurn :: PlaneRef -> DB ()
dbPerform1PlanarAITurn plane_ref =
do logDB gameplay_log INFO $ "dbPerform1PlanarAITurn; Beginning planar AI turn (for the plane itself):"
(creature_locations :: [DetailedLocation (Child Monster)]) <- liftM mapLocations $ getContents plane_ref
(creature_locations :: [DetailedLocation (Child Monster)]) <- liftM mapLocations $ asks $ getContents plane_ref
player_locations <- filterRO (liftM (== Player) . getMonsterFaction . asChild . detail) creature_locations
num_npcs <- liftM length $ filterRO (liftM (/= Player) . getMonsterFaction . asChild . detail) creature_locations
when (num_npcs < length player_locations * 3) $
......
......@@ -16,11 +16,12 @@ import Roguestar.Lib.Data.FacingData
import Data.Maybe
import Control.Monad.Maybe
import Control.Monad.Random
import Control.Monad.Error
import Control.Monad.Reader
import Roguestar.Lib.Data.PlaneData
import Roguestar.Lib.Core.Plane
import Roguestar.Lib.Position
import Roguestar.Lib.Data.TerrainData
import Control.Monad.Error
import Roguestar.Lib.Data.PowerUpData
import Roguestar.Lib.Behavior.CharacterAdvancement
import Roguestar.Lib.Utility.DetailedLocation
......@@ -32,16 +33,16 @@ buildingSize = liftM (genericLength . buildingOccupies) . buildingShape
buildingShape :: (DBReadable db) => BuildingRef -> db BuildingShape
buildingShape building_ref =
do constructed <- liftM fromLocation $ whereIs building_ref
do constructed <- liftM fromLocation $ asks $ whereIs building_ref
case constructed of
Just building_shape -> return building_shape
_ -> error "buildingType: impossible case"
buildingSignal :: (DBReadable db) => BuildingRef -> db (Maybe BuildingSignal)
buildingSignal = liftM building_signal . dbGetBuilding
buildingSignal = liftM building_signal . asks . getBuilding
buildingBehavior :: (DBReadable db) => BuildingRef -> db BuildingBehavior
buildingBehavior building_ref = liftM building_behavior $ dbGetBuilding building_ref
buildingBehavior building_ref = liftM building_behavior $ asks $ getBuilding building_ref
deleteBuilding :: BuildingRef -> DB ()
deleteBuilding building_ref = dbUnsafeDeleteObject building_ref
......@@ -50,7 +51,7 @@ deleteBuilding building_ref = dbUnsafeDeleteObject building_ref
-- | Activate the facing building, returns True iff any building was actually activated.
activateFacingBuilding :: Facing -> MonsterRef -> DB Bool
activateFacingBuilding face creature_ref = liftM (fromMaybe False) $ runMaybeT $
do (Parent plane_ref,position) <- MaybeT $ liftM fromLocation $ whereIs creature_ref
do (Parent plane_ref,position) <- MaybeT $ liftM fromLocation $ asks $ whereIs creature_ref
buildings <- lift $ liftM mapLocations $ whatIsOccupying plane_ref $ offsetPosition (facingToRelative face) position
liftM or $ lift $ forM buildings $ \(Child building_ref) ->
do building_behavior_type <- buildingBehavior building_ref
......@@ -85,7 +86,7 @@ activateBuilding (OneWayStargate region) creature_ref building_ref =
-- the dbMove result from the action.
portalMonsterTo :: Maybe BuildingBehavior -> Integer -> MonsterRef -> PlaneRef -> DB (Location,Location)
portalMonsterTo building_behavior_type offset creature_ref plane_ref =
do (all_buildings :: [BuildingRef]) <- liftM asChildren (getContents plane_ref)
do (all_buildings :: [BuildingRef]) <- liftM asChildren (asks $ getContents plane_ref)
portals <- filterM (liftM ((== building_behavior_type) . Just) . buildingBehavior) all_buildings
ideal_position <- if null portals
then liftM2 (\x y -> Position (x,y)) (getRandomR (-40,40)) (getRandomR (-40,40))
......@@ -97,7 +98,7 @@ portalMonsterTo building_behavior_type offset creature_ref plane_ref =
captureNode :: PowerUpData -> MonsterRef -> BuildingRef -> DB ()
captureNode power_up_data creature_ref building_ref =
do c <- dbGetMonster creature_ref
do c <- asks $ getMonster creature_ref
let result = bumpCharacter power_up_data c
dbModMonster (const $ character_new result) creature_ref
deleteBuilding building_ref
......
module Roguestar.Lib.Core.Entities
(getAncestors)
where
import Roguestar.Lib.Data.LocationData
import Roguestar.Lib.DB
getAncestors :: Reference a -> DB_BaseType -> [Location]
getAncestors reference _ | reference =:= the_universe = []
getAncestors reference db = location : getAncestors reference' db
where reference' = parentReference location
location = whereIs reference db
......@@ -23,6 +23,7 @@ import Roguestar.Lib.Data.SpeciesTraits
import Roguestar.Lib.Data.FactionData
import Control.Monad.Error
import Control.Monad.Random
import Control.Monad.Reader
import Roguestar.Lib.Data.FacingData
import Roguestar.Lib.Position
import Roguestar.Lib.Core.Plane
......@@ -39,7 +40,7 @@ generateMonster faction species =
do r <- getRandomR (1,1000000)
return $ applyToMonster (species_specials $ speciesInfo species) $
applyToMonster (species_traits $ speciesInfo species) $
empty_creature {
empty_monster {
creature_species = species,
creature_faction = faction,
creature_random_id = r }
......@@ -61,11 +62,11 @@ newMonster faction species loc =
dbAddMonster creature loc
getMonsterSpecial :: (DBReadable db) => MonsterSpecial -> MonsterRef -> db Bool
getMonsterSpecial special creature_ref = liftM (Set.member special . creature_specials) $ dbGetMonster creature_ref
getMonsterSpecial special creature_ref = liftM (Set.member special . creature_specials) $ asks $ getMonster creature_ref
getMonsterAbilityScore :: (DBReadable db) => MonsterAbility -> MonsterRef -> db Integer
getMonsterAbilityScore ability creature_ref =
do raw_ideal <- liftM (creatureAbilityScore ability) $ dbGetMonster creature_ref
do raw_ideal <- liftM (creatureAbilityScore ability) $ asks $ getMonster creature_ref
terrain_ideal <- getTerrainAffinity creature_ref
return $ raw_ideal + terrain_ideal
......@@ -75,7 +76,7 @@ getTerrainAffinity creature_ref =
do (Parent plane_ref,pos) <- liftM detail $ getPlanarLocation creature_ref
terrain_affinity_points <- liftM sum $ forM [minBound..maxBound] $ \face ->
do t <- terrainAt plane_ref $ offsetPosition (facingToRelative face) pos
liftM (creatureAbilityScore $ TerrainAffinity t) $ dbGetMonster creature_ref
liftM (creatureAbilityScore $ TerrainAffinity t) $ asks $ getMonster creature_ref
return $ terrain_affinity_points `div` 4
-- | Get the current creature, if it belongs to the specified faction, based on the current playerState.
......@@ -86,7 +87,7 @@ getCurrentMonster faction =
return $ if is_one_of_us then m_who else Nothing
getMonsterFaction :: (DBReadable db) => MonsterRef -> db Faction
getMonsterFaction = liftM creature_faction . dbGetMonster
getMonsterFaction = liftM creature_faction . asks . getMonster
injureMonster :: Integer -> MonsterRef -> DB ()
injureMonster x = dbModMonster $ \c -> c { creature_damage = max 0 $ creature_damage c + x }
......@@ -96,10 +97,10 @@ healMonster = injureMonster . negate
-- | Health as a fraction of 1.
getMonsterHealth :: (DBReadable db) => MonsterRef -> db MonsterHealth
getMonsterHealth creature_ref = liftM creatureHealth $ dbGetMonster creature_ref
getMonsterHealth creature_ref = liftM creatureHealth $ asks $ getMonster creature_ref
getDead :: (DBReadable db) => Reference a -> db [MonsterRef]
getDead parent_ref = filterRO (liftM ((<= 0) . creature_health) . getMonsterHealth) =<< liftM asChildren (getContents parent_ref)
getDead parent_ref = filterRO (liftM ((<= 0) . creature_health) . getMonsterHealth) =<< liftM asChildren (asks $ getContents parent_ref)
deleteMonster :: MonsterRef -> DB ()
deleteMonster creature_ref =
......
......@@ -27,6 +27,7 @@ import Roguestar.Lib.Data.ToolData (Tool)
import Roguestar.Lib.Data.MonsterData (Monster)
import Control.Monad
import Control.Monad.Random as Random
import Control.Monad.Reader
import Data.Maybe
import Data.List as List
import Roguestar.Lib.Position as Position
......@@ -37,7 +38,7 @@ import qualified Data.ByteString.Char8 as B
import Roguestar.Lib.Data.BuildingData
import Roguestar.Lib.Logging
import Control.Monad.Maybe
import Control.Monad.Trans
import Roguestar.Lib.Core.Entities
dbNewPlane :: (LocationConstructor l, ReferenceTypeOf l ~ Plane) => B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef
dbNewPlane name tg_data l =
......@@ -49,7 +50,7 @@ dbNewPlane name tg_data l =
plane_planet_name = name}) l
planetName :: (DBReadable db) => PlaneRef -> db B.ByteString
planetName = liftM plane_planet_name . dbGetPlane
planetName = liftM plane_planet_name . asks . getPlane
randomPlanetName :: (MonadRandom db, DBReadable db) => Faction -> db B.ByteString
randomPlanetName faction =
......@@ -58,7 +59,7 @@ randomPlanetName faction =
planeDepth :: (DBReadable db) => PlaneRef -> db Integer
planeDepth this_plane =
do l <- whereIs this_plane
do l <- asks $ whereIs this_plane
case () of
() | Just (Beneath above) <- fromLocation l -> liftM succ $ planeDepth above
() | otherwise -> return 0
......@@ -74,14 +75,14 @@ instance AlwaysHasIndirectPlanarLocation Building
--
getPlanarLocation :: (DBReadable db,AlwaysHasIndirectPlanarLocation a) => Reference a -> db PlanarLocation
getPlanarLocation ref =
liftM (fromMaybe (error "getPlanarLocation: Implements AlwaysHasIndirectPlanarLocation, but doesn't.") . listToMaybe . mapLocations) $ dbGetAncestors ref
liftM (fromMaybe (error "getPlanarLocation: Implements AlwaysHasIndirectPlanarLocation, but doesn't.") . listToMaybe . mapLocations) $ asks $ getAncestors ref
-- |
-- Get the plane beneath this one, if it exists.
--
getBeneath :: (DBReadable db) => PlaneRef -> db (Maybe PlaneRef)
getBeneath item =
do (plane_locs :: [DetailedLocation Beneath]) <- liftM mapLocations $ getContents item
do (plane_locs :: [DetailedLocation Beneath]) <- liftM mapLocations $ asks $ getContents item
return $
do Child plane_ref <- liftM detail $ listToMaybe plane_locs
return plane_ref
......@@ -91,7 +92,7 @@ getBeneath item =
--
getSubsequent :: (DBReadable db) => PlanetRegion -> PlaneRef -> db (Maybe PlaneRef)
getSubsequent planet_region item =
do plane_locs <- liftM (filterLocations $ \subsequent -> subsequent_via subsequent == planet_region) $ getContents item
do plane_locs <- liftM (filterLocations $ \subsequent -> subsequent_via subsequent == planet_region) $ asks $ getContents item
return $
do Child plane_ref <- liftM detail $ listToMaybe plane_locs
return plane_ref
......@@ -169,8 +170,8 @@ pickRandomClearSite_withTimeout timeout search_radius object_clear terrain_clear
xys <- liftM2 (\a b -> List.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 <- liftM (List.map identityDetail . filterLocations (\(_ :: MultiPosition) -> True)) $ getContents plane_ref
terrain <- liftM plane_terrain $ asks $ getPlane plane_ref
clutter_locations <- liftM (List.map identityDetail . filterLocations (\(_ :: MultiPosition) -> True)) $ asks $ getContents plane_ref
let terrainIsClear (Position (x,y)) =
all terrainPredicate $ List.map (\(Terrain t) -> t) $
concat [[gridAt terrain (x',y') |
......@@ -193,7 +194,7 @@ pickRandomClearSite_withTimeout timeout search_radius object_clear terrain_clear
terrainAt :: (DBReadable db) => PlaneRef -> Position -> db Terrain
terrainAt plane_ref (Position (x,y)) =
do terrain <- liftM plane_terrain $ dbGetPlane plane_ref
do terrain <- liftM plane_terrain $ asks $ getPlane plane_ref
return $ case (gridAt terrain (x,y)) of
Terrain t -> t
Biome _ -> error "terrainAt: What's this biome doing here?"
......@@ -205,7 +206,7 @@ setTerrainAt plane_ref (Position pos) patch = dbModPlane (\p -> p { plane_terrai
-- Typically this is zero or one creatures, and zero or more tools. Might be a building.
whatIsOccupying :: (DBReadable db) => PlaneRef -> Position -> db [PlanarLocation]
whatIsOccupying plane_ref position =
liftM (mapLocations . filterLocations (\(x :: MultiPosition) -> distanceBetweenChessboard position x == 0)) $ getContents plane_ref
liftM (mapLocations . filterLocations (\(x :: MultiPosition) -> distanceBetweenChessboard position x == 0)) $ asks $ getContents 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.
......
{-# LANGUAGE OverloadedStrings #-}
module Roguestar.Lib.Core.Tests
(testcases)
where
import Control.Monad.Random
import Roguestar.Lib.Data.FacingData
import Roguestar.Lib.Data.MonsterData
import Roguestar.Lib.Data.TerrainData
import Roguestar.Lib.Data.ToolData
import Roguestar.Lib.DB
import Roguestar.Lib.Core.Entities
import Roguestar.Lib.Core.Plane
import Test.HUnit
testcases :: Test
testcases = TestLabel "Roguestar.Lib.Core.Tests" $ TestList [testAncestors]
spock :: Monster
spock = empty_monster
setupCreatureWithTool :: DB (ToolRef,MonsterRef,PlaneRef)
setupCreatureWithTool =
do seed <- getRandom
plane_ref <- dbNewPlane "vulcan" (TerrainGenerationData {
tg_smootheness = 3,
tg_biome = weightedSet [(1,CraterInterior)],
tg_placements = [recreantFactories seed] }) TheUniverse
monster_ref <- dbAddMonster spock $ Standing plane_ref (Position (0,0)) Here
tool_ref <- dbAddTool phaser $ Inventory monster_ref
return (tool_ref,monster_ref,plane_ref)
testAncestors :: Test
testAncestors = TestCase $
do (Right ((tool_ref,creature_ref,plane_ref),setup_db)) <- runDB setupCreatureWithTool initial_db
let ancestors = map parentReference $ getAncestors tool_ref setup_db
assertEqual "testAncestors" [genericReference creature_ref,genericReference plane_ref,genericReference the_universe] ancestors
......@@ -24,17 +24,16 @@ module Roguestar.Lib.DB
dbAddTool,
dbAddBuilding,
dbUnsafeDeleteObject,
dbGetMonster,
dbGetPlane,
dbGetTool,
dbGetBuilding,
getMonster,
getPlane,
getTool,
getBuilding,
dbModMonster,
dbModPlane,
dbModTool,
dbModBuilding,
dbUnwieldMonster,
dbVerify,
dbGetAncestors,
whereIs,
getContents,
move,
......@@ -193,6 +192,7 @@ logDB l p s = unsafePerformIO $
do logM l p $ l ++ ": " ++ s
return $ return ()
-- Not sure that these "ro" functions are really that useful.
ro :: (DBReadable db) => (forall m. (MonadRandom m, DBReadable m) => m a) -> db a
ro db = dbSimulate db
......@@ -274,7 +274,7 @@ dbAddObjectComposable constructReferenceAction updateObjectAction constructLocat
do ref <- liftM constructReferenceAction $ dbNextObjectRef
updateObjectAction ref thing
setLocation $ constructLocationAction ref loc
genericParent_ref <- liftM parentReference $ whereIs ref
genericParent_ref <- liftM parentReference $ asks $ whereIs ref
setTime (genericReference ref) =<< getTime (genericReference genericParent_ref)
return ref
......@@ -361,33 +361,33 @@ dbPutBuilding = dbPutObjectComposable db_buildings $
-- |
-- Gets an object from the database using getter functions.
--
dbGetObjectComposable :: (DBReadable db) => String -> (DB_BaseType -> Map (Reference a) b) -> Reference a -> db b
dbGetObjectComposable type_info get_fn ref =
asks (fromMaybe (error $ "dbGetObjectComposable: Nothing. UID was " ++ show (toUID ref) ++ ", type info was " ++ type_info) . Map.lookup ref . get_fn)
getObjectComposable :: String -> (DB_BaseType -> Map (Reference a) b) -> Reference a -> DB_BaseType -> b
getObjectComposable type_info get_fn ref =
fromMaybe (error $ "dbGetObjectComposable: Nothing. UID was " ++ show (toUID ref) ++ ", type info was " ++ type_info) . Map.lookup ref . get_fn
-- |
-- Gets a Monster from a MonsterRef
--
dbGetMonster :: (DBReadable m) => MonsterRef -> m Monster
dbGetMonster = dbGetObjectComposable "MonsterRef" db_creatures
getMonster :: MonsterRef -> DB_BaseType -> Monster
getMonster = getObjectComposable "MonsterRef" db_creatures
-- |
-- Gets a Plane from a PlaneRef
--
dbGetPlane :: (DBReadable m) => PlaneRef -> m Plane
dbGetPlane = dbGetObjectComposable "PlaneRef" db_planes
getPlane :: PlaneRef -> DB_BaseType -> Plane
getPlane = getObjectComposable "PlaneRef" db_planes
-- |
-- Gets a Plane from a PlaneRef
--
dbGetTool :: (DBReadable m) => ToolRef -> m Tool
dbGetTool = dbGetObjectComposable "ToolRef" db_tools
getTool :: ToolRef -> DB_BaseType -> Tool
getTool = getObjectComposable "ToolRef" db_tools
-- |
-- Gets a Plane from a PlaneRef
--
dbGetBuilding :: (DBReadable m) => BuildingRef -> m Building
dbGetBuilding = dbGetObjectComposable "BuildingRef" db_buildings
getBuilding :: BuildingRef -> DB_BaseType -> Building
getBuilding = getObjectComposable "BuildingRef" db_buildings
-- |
-- Modifies an Object based on an ObjectRef.
......@@ -400,25 +400,25 @@ dbModObjectComposable getter putter f ref = (putter ref . f) =<< (getter ref)
-- Modifies a Plane based on a PlaneRef.
--
dbModPlane :: (Plane -> Plane) -> PlaneRef -> DB ()
dbModPlane = dbModObjectComposable dbGetPlane dbPutPlane
dbModPlane = dbModObjectComposable (asks . getPlane) dbPutPlane
-- |
-- Modifies a Monster based on a PlaneRef.
--
dbModMonster :: (Monster -> Monster) -> MonsterRef -> DB ()
dbModMonster = dbModObjectComposable dbGetMonster dbPutMonster
dbModMonster = dbModObjectComposable (asks . getMonster) dbPutMonster
-- |
-- Modifies a Tool based on a PlaneRef.
--
dbModTool :: (Tool -> Tool) -> ToolRef -> DB ()
dbModTool = dbModObjectComposable dbGetTool dbPutTool
dbModTool = dbModObjectComposable (asks . getTool) dbPutTool
-- |
-- Modifies a Tool based on a PlaneRef.
--
dbModBuilding :: (Building -> Building) -> BuildingRef -> DB ()
dbModBuilding = dbModObjectComposable dbGetBuilding dbPutBuilding
dbModBuilding = dbModObjectComposable (asks . getBuilding) dbPutBuilding
-- | A low-level set location instruction. Merely guarantees the consistency of the location graph.
setLocation :: Location -> DB ()
......@@ -438,14 +438,14 @@ setLocation loc =
--
shuntPlane :: (LocationDetail a) => (a -> Bool) -> PlaneRef -> DB ()
shuntPlane f p =
do locations <- liftM (List.filter (maybe False f . fromLocation)) $ getContents p
do locations <- liftM (List.filter (maybe False f . fromLocation)) $ asks $ getContents p
mapM_ (maybe (return ()) setLocation . shuntToTheUniverse) locations
-- |
-- Shunt any wielded objects into inventory.
--
dbUnwieldMonster :: MonsterRef -> DB ()
dbUnwieldMonster c = mapM_ (maybe (return ()) setLocation . returnToInventory) =<< getContents c
dbUnwieldMonster c = mapM_ (maybe (return ()) setLocation . returnToInventory) =<< asks (getContents c)
-- |
-- Moves an object, returning the location of the object before and after
......@@ -453,7 +453,7 @@ dbUnwieldMonster c = mapM_ (maybe (return ()) setLocation . returnToInventory) =
--
move :: (LocationConstructor l, ReferenceTypeOf l ~ e, ReferenceType e) => Reference e -> l -> DB (Location,Location)
move ref location_data =
do old <- whereIs ref
do old <- asks $ whereIs ref
let new = constructLocation ref location_data (Just old)
setLocation new
when (childReference old /= childReference new) $
......@@ -467,7 +467,7 @@ moveAllWithin :: (LocationConstructor l, ReferenceTypeOf l ~ ()) =>
(forall m. (DBReadable m) => Reference () -> m l) ->
DB [(Location,Location)]
moveAllWithin ref f =
do all_entities <- liftM (List.map childReference) $ getContents ref
do all_entities <- liftM (List.map childReference) $ asks $ getContents ref
forM all_entities $ \e -> move e =<< f e
-- |
......@@ -476,25 +476,14 @@ moveAllWithin ref f =
dbVerify :: (DBReadable db) => Reference e -> db Bool
dbVerify ref = asks (isJust . HD.parentOf (toUID ref) . db_hierarchy)
whereIs :: (DBReadable db) => Reference e -> db Location
whereIs item = asks (fromMaybe (error "whereIs: has no location") . 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) => Reference e -> db [Location]
dbGetAncestors ref | genericReference ref == genericReference the_universe = return []
dbGetAncestors ref =
do this <- whereIs ref
rest <- dbGetAncestors $ parentReference this
return $ this : rest
whereIs :: Reference e -> DB_BaseType -> Location
whereIs item = fromMaybe (error "whereIs: has no location") . HD.lookupParent (toUID item) . db_hierarchy
-- |
-- Returns locations of all children of a reference.
--
getContents :: (DBReadable db) => Reference t -> db [Location]
getContents item = asks (HD.lookupChildren (toUID item) . db_hierarchy)
getContents :: Reference t -> DB_BaseType -> [Location]
getContents item = HD.lookupChildren (toUID item) . db_hierarchy
-- |
-- Gets the time of an object.
......
......@@ -10,7 +10,7 @@ module Roguestar.Lib.Data.MonsterData
MonsterHealth(..),
creatureHealth,
creatureAbilityScore,
empty_creature)
empty_monster)
where
import Roguestar.Lib.Data.PersistantData
......@@ -35,8 +35,8 @@ data Monster = Monster { creature_traits :: Map.Map MonsterTrait Integer,
-- | Monster having no attributes and undefined 'creature_species', 'creature_random_id', and 'creature_faction'
--
empty_creature :: Monster
empty_creature = Monster {
empty_monster :: Monster
empty_monster = Monster {
creature_traits = Map.empty,
creature_specials = Set.empty,
creature_species = error "empty_creature: undefined creature_species",
......
......@@ -8,8 +8,8 @@ import qualified Data.ByteString.Char8 as B
import Roguestar.Lib.Random as Random
data Plane = Plane
{ plane_biome :: WeightedSet Biome,
plane_terrain :: TerrainGrid,
plane_random_id :: Integer,
plane_planet_name :: B.ByteString }
{ plane_biome :: WeightedSet Biome, -- TODO: Get rid of this.
plane_terrain :: TerrainGrid, -- TODO: Use a persistable domain-specific language to procedurally generate these grids
plane_random_id :: Integer, -- Just a random number
plane_planet_name :: B.ByteString } -- Human-readable name of the planet. TODO: switch to Text instead of ByteString. TODO: this is stored redundantly on multiple planes belonging to the same planet?
deriving (Read,Show)
......@@ -28,6 +28,7 @@ module Roguestar.Lib.Perception
Roguestar.Lib.Perception.isBehaviorAvailable)
where
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Random
import Data.Ord
......@@ -38,7 +39,6 @@ import Roguestar.Lib.PlaneVisibility
import Data.Maybe
import Data.List as List
import Data.Map as Map
import Control.Applicative
import Roguestar.Lib.Data.FacingData
import Roguestar.Lib.Position as Position
import Roguestar.Lib.Data.TerrainData
......@@ -124,19 +124,19 @@ isVisibleBuilding _ = False
convertToVisibleObjectRecord :: (DBReadable db) => Reference a -> db VisibleObject
convertToVisibleObjectRecord ref | (Just creature_ref) <- coerceReference ref =
do species <- liftM creature_species $ dbGetMonster creature_ref
traits <- liftM creature_traits $ dbGetMonster creature_ref
do species <- liftM creature_species $ asks $ getMonster creature_ref
traits <- liftM creature_traits $ asks $ getMonster creature_ref
faction <- Monster.getMonsterFaction creature_ref
m_tool_ref <- getWielded creature_ref
position <- liftM detail $ DT.whereIs creature_ref
m_wielded <- case m_tool_ref of
Just tool_ref ->
do tool <- dbGetTool tool_ref
do tool <- asks $ getTool tool_ref
return $ Just $ VisibleTool tool_ref tool position
Nothing -> return Nothing
return $ VisibleMonster creature_ref species traits m_wielded position faction
convertToVisibleObjectRecord ref | (Just tool_ref) <- coerceReference ref =
do tool <- dbGetTool tool_ref
do tool <- asks $ getTool tool_ref
position <- liftM detail $ getPlanarLocation tool_ref
return $ VisibleTool tool_ref tool position
convertToVisibleObjectRecord ref | (Just building_ref :: Maybe BuildingRef) <- coerceReference ref =
......@@ -183,7 +183,7 @@ visibleObjects :: (MonadRandom db, DBReadable db) =>
visibleObjects filterF =
do me <- whoAmI
faction <- myFaction
m_parent_plane <- liftDB $ liftM fromLocation (DB.whereIs me)
m_parent_plane <- liftDB $ liftM fromLocation (asks $ DB.whereIs me)
visible_objects <- case m_parent_plane of
(Just (Paren