Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Use the Reader monad more heavily, starting to move some functions ou…

…t of the DB monad.
  • Loading branch information...
commit 02641ea4a89915d44fc8d5d96e3c2e24f0c52dd0 1 parent 2fba10d
@clanehin authored
View
25 Makefile
@@ -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
View
3  Roguestar/Lib/Behavior.hs
@@ -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
View
3  Roguestar/Lib/Behavior/Activate.hs
@@ -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) ->
View
3  Roguestar/Lib/Behavior/Combat.hs
@@ -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
View
4 Roguestar/Lib/Behavior/Construction.hs
@@ -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
View
26 Roguestar/Lib/Behavior/Travel.hs
@@ -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 $
View
5 Roguestar/Lib/Behavior/Turns.hs
@@ -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) $
View
15 Roguestar/Lib/Core/Building.hs
@@ -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
View
12 Roguestar/Lib/Core/Entities.hs
@@ -0,0 +1,12 @@
+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
View
15 Roguestar/Lib/Core/Monster.hs
@@ -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 =
View
21 Roguestar/Lib/Core/Plane.hs
@@ -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.
View
38 Roguestar/Lib/Core/Tests.hs
@@ -0,0 +1,38 @@
+{-# 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
+
View
69 Roguestar/Lib/DB.hs
@@ -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.
View
6 Roguestar/Lib/Data/MonsterData.hs
@@ -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",
View
8 Roguestar/Lib/Data/PlaneData.hs
@@ -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)
View
18 Roguestar/Lib/Perception.hs
@@ -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 (Parent plane_ref)) -> liftDB $ dbGetVisibleObjectsForFaction
(\a -> runPerception me $ filterF a)
@@ -195,7 +195,7 @@ visibleObjects filterF =
myInventory :: (MonadRandom db, DBReadable db) => DBPerception db [VisibleObject]
myInventory =
do me <- whoAmI
- (result :: [DetailedLocation Inventory]) <- liftDB $ liftM mapLocations $ DB.getContents me
+ (result :: [DetailedLocation Inventory]) <- liftDB $ liftM mapLocations $ asks $ DB.getContents me
liftDB $ mapRO convertToVisibleObjectRecord $ sortBy (comparing toUID) $ (asChildren result :: [ToolRef])
myFaction :: (MonadRandom db, DBReadable db) => DBPerception db Faction
@@ -212,7 +212,7 @@ whatPlaneAmIOn = liftM (planar_parent . identityDetail) $ (\x -> liftDB $ getPla
whereIs :: (MonadRandom db, DBReadable db, ReferenceType a) =>
Reference a -> DBPerception db (DetailedLocation (Child a))
-whereIs ref = liftM (fromMaybe (error "Perception.whereIs: not a child of its own location record") . fromLocation) $ liftDB $ DB.whereIs ref
+whereIs ref = liftM (fromMaybe (error "Perception.whereIs: not a child of its own location record") . fromLocation) $ liftDB $ asks $ DB.whereIs ref
-- Let's look into re-writing this with A*:
-- http://hackage.haskell.org/packages/archive/astar/0.2.1/doc/html/Data-Graph-AStar.html
@@ -221,7 +221,7 @@ compass =
do (_,pos) <- whereAmI
plane <- whatPlaneAmIOn
liftDB $
- do (all_buildings :: [DetailedLocation (Child Building)]) <- liftM mapLocations $ DB.getContents plane
+ do (all_buildings :: [DetailedLocation (Child Building)]) <- liftM mapLocations $ asks $ DB.getContents plane
all_signallers <- filterRO (liftM (== Just Magnetic) . buildingSignal . asChild . detail) all_buildings
let multipositionOf :: DetailedLocation (Child Building) -> MultiPosition
multipositionOf = detail
View
17 Roguestar/Lib/PlaneVisibility.hs
@@ -14,6 +14,7 @@ import Roguestar.Lib.Core.Plane
import Roguestar.Lib.Data.PlaneData
import Control.Monad
import Control.Monad.Random
+import Control.Monad.Reader
import Roguestar.Lib.Data.MonsterData
import Data.List as List
import Roguestar.Lib.Utility.Grids
@@ -28,7 +29,7 @@ import Roguestar.Lib.Utility.DetailedLocation
dbGetSeersForFaction :: (DBReadable db) => Faction -> PlaneRef -> db [MonsterRef]
dbGetSeersForFaction faction plane_ref =
- filterM (filterByFaction faction) =<< liftM asChildren (getContents plane_ref)
+ filterM (filterByFaction faction) =<< liftM asChildren (asks $ getContents plane_ref)
-- |
-- Returns a list of all terrain patches that are visible to any creature belonging
@@ -46,7 +47,7 @@ dbGetVisibleTerrainForMonster :: (DBReadable db) => MonsterRef -> db [(Position,
dbGetVisibleTerrainForMonster creature_ref =
do loc <- liftM identityDetail $ getPlanarLocation creature_ref
spot_check <- dbGetSpotCheck creature_ref
- liftM (visibleTerrain (planar_position loc) spot_check . plane_terrain) $ dbGetPlane (planar_parent loc)
+ liftM (visibleTerrain (planar_position loc) spot_check . plane_terrain) $ asks $ getPlane (planar_parent loc)
-- |
-- Returns a list of all objects that are visible to any creature belonging
@@ -65,7 +66,7 @@ dbGetVisibleObjectsForFaction filterF faction plane_ref =
dbGetVisibleObjectsForMonster :: (DBReadable db) => (forall m. DBReadable m => Reference () -> m Bool) -> MonsterRef -> db [Reference ()]
dbGetVisibleObjectsForMonster filterF creature_ref =
do plane_ref <- liftM (planar_parent . identityDetail) $ getPlanarLocation creature_ref
- possibles <- liftM asChildren $ getContents plane_ref
+ possibles <- liftM asChildren $ asks $ getContents plane_ref
filterRO (\a -> (&&) <$> filterF a <*> dbIsPlanarVisible creature_ref a) possibles
-- |
-- dbIsPlanarVisible (a creature) (some object) is true if the creature can see the object.
@@ -74,7 +75,7 @@ dbIsPlanarVisible :: (DBReadable db,ReferenceType a) => MonsterRef -> Reference
dbIsPlanarVisible creature_ref obj_ref | creature_ref =:= obj_ref = return True
dbIsPlanarVisible creature_ref obj_ref =
do c <- liftM identityDetail $ getPlanarLocation creature_ref
- (m_o :: Maybe Planar) <- liftM fromLocation $ whereIs obj_ref
+ (m_o :: Maybe Planar) <- liftM fromLocation $ asks $ whereIs obj_ref
spot_check <- dbGetOpposedSpotCheck creature_ref obj_ref
case m_o of
Nothing -> return False
@@ -84,7 +85,7 @@ dbIsPlanarVisible creature_ref obj_ref =
Just o -> liftM or $ forM (positionPairs (planar_position c) (planar_multiposition o)) $
\(Position (cx,cy),Position (ox,oy)) ->
do let delta_at = (ox-cx,oy-cy)
- terrain <- liftM plane_terrain $ dbGetPlane (planar_parent c) -- falling through all other tests, cast a ray for visibility
+ terrain <- liftM plane_terrain $ asks $ getPlane (planar_parent c) -- falling through all other tests, cast a ray for visibility
return $ castRay (cx,cy) (ox,oy) (spot_check - distanceCostForSight Here delta_at) (terrainOpacity . (\(Terrain t) -> t) . gridAt terrain)
dbGetOpposedSpotCheck :: (DBReadable db) => MonsterRef -> Reference a -> db Integer
@@ -100,11 +101,11 @@ dbGetSpotCheck :: (DBReadable db) => MonsterRef -> db Integer
dbGetSpotCheck creature_ref =
do plane_ref <- liftM (planar_parent . identityDetail) $ getPlanarLocation creature_ref
bonus <- planarLightingBonus $ plane_ref
- ability_score <- liftM (creatureAbilityScore SpotSkill) $ dbGetMonster creature_ref
+ ability_score <- liftM (creatureAbilityScore SpotSkill) $ asks $ getMonster creature_ref
return $ ability_score + bonus
dbGetHideCheck :: (DBReadable db) => Reference a -> db Integer
-dbGetHideCheck ref | Just (creature_ref :: MonsterRef) <- coerceReference ref = liftM (creatureAbilityScore HideSkill) $ dbGetMonster creature_ref
+dbGetHideCheck ref | Just (creature_ref :: MonsterRef) <- coerceReference ref = liftM (creatureAbilityScore HideSkill) $ asks $ getMonster creature_ref
dbGetHideCheck ref | Just (building_ref :: BuildingRef) <- coerceReference ref = liftM negate $ buildingSize building_ref
dbGetHideCheck _ | otherwise = return 1
@@ -136,4 +137,4 @@ terrainPatchBrightnessForm creature_at spot_check patch_at =
-- Returns true if the specified MonsterRef belongs to the specified Faction.
--
filterByFaction :: (DBReadable db) => Faction -> MonsterRef -> db Bool
-filterByFaction faction = liftM ((== faction) . creature_faction) . dbGetMonster
+filterByFaction faction = liftM ((== faction) . creature_faction) . asks . getMonster
View
3  Roguestar/Lib/Time.hs
@@ -8,10 +8,11 @@ import Roguestar.Lib.Data.MonsterData
import Roguestar.Lib.Position
import Data.Ratio
import Control.Monad
+import Control.Monad.Reader
getBaseSpeed :: (DBReadable db) => MonsterRef -> db Integer
getBaseSpeed creature_ref =
- do c <- dbGetMonster creature_ref
+ do c <- asks $ getMonster creature_ref
let raw_speed = rawScore Speed c
when (raw_speed <= 0) $ error $ "getBaseSpeed: Non-positive raw speed (" ++ show c ++ ")"
return raw_speed
View
17 Roguestar/Lib/Tool.hs
@@ -15,6 +15,7 @@ import Prelude hiding (getContents)
import Roguestar.Lib.DB
import Roguestar.Lib.Utility.DetailedLocation
import Control.Monad.Error
+import Control.Monad.Reader
import Data.Maybe
import Data.List as List
import Roguestar.Lib.Data.ToolData
@@ -27,8 +28,8 @@ pickupTool :: (DBReadable db) =>
ToolRef ->
db (Inventory)
pickupTool creature_ref tool_ref =
- do creature_loc <- whereIs creature_ref
- tool_loc <- whereIs tool_ref
+ do creature_loc <- asks $ whereIs creature_ref
+ tool_loc <- asks $ whereIs tool_ref
distance_between <- distanceBetweenSquared creature_ref tool_ref
when (parentReference tool_loc =/= parentReference creature_loc || distance_between /= Just 0) $
throwError (DBErrorFlag ToolIs_NotAtFeet)
@@ -37,11 +38,11 @@ pickupTool creature_ref tool_ref =
-- | Move a tool into wielded position for whatever creature is carrying or standing over it.
wieldTool :: (DBReadable db) => ToolRef -> db Wielded
wieldTool tool_ref =
- do l <- whereIs tool_ref
+ do l <- asks $ whereIs tool_ref
case () of
() | Just l' <- fromLocation l -> return l' -- if it coerces into our return type, then it's already wielded
() | Just (Dropped plane_ref position) <- fromLocation l ->
- do pickupers <- liftM (mapLocations . filterLocations (== position)) $ getContents plane_ref
+ do pickupers <- liftM (mapLocations . filterLocations (== position)) $ asks $ getContents plane_ref
case pickupers of -- the creature that is standing over the tool -- there can be only one
[Child single_pickuper] -> return $ Wielded single_pickuper
[] -> throwError $ DBErrorFlag ToolIs_Unreachable
@@ -57,19 +58,19 @@ dropTool tool_ref =
availablePickups :: (DBReadable db) => MonsterRef -> db [ToolRef]
availablePickups creature_ref =
do (Parent plane_ref :: Parent Plane, creature_position :: Position) <- liftM detail $ getPlanarLocation creature_ref
- pickups <- liftM (mapLocations . filterLocations (==creature_position)) $ getContents plane_ref
+ pickups <- liftM (mapLocations . filterLocations (==creature_position)) $ asks $ getContents plane_ref
return $ List.map (asChild . identityDetail) pickups
-- | 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.
availableWields :: (DBReadable db) => MonsterRef -> db [ToolRef]
availableWields creature_ref =
- do carried_tools :: [ToolRef] <- liftM (List.map (asChild . identityDetail) . mapLocations) $ getContents creature_ref
+ do carried_tools :: [ToolRef] <- liftM (List.map (asChild . identityDetail) . mapLocations) $ asks $ getContents creature_ref
pickups <- availablePickups creature_ref
return $ List.union carried_tools pickups
getWielded :: (DBReadable db) => MonsterRef -> db (Maybe ToolRef)
-getWielded = liftM (listToMaybe . List.map (asChild . detail) . filterLocations (\(Wielded {}) -> True)) . getContents
+getWielded = liftM (listToMaybe . List.map (asChild . detail) . filterLocations (\(Wielded {}) -> True)) . asks . getContents
-- | Safely delete tools.
deleteTool :: ToolRef -> DB ()
@@ -78,7 +79,7 @@ deleteTool tool_ref = dbUnsafeDeleteObject tool_ref $
toolValue :: (DBReadable db) => ToolRef -> db Integer
toolValue tool_ref =
- do t <- dbGetTool tool_ref
+ do t <- asks $ getTool tool_ref
return $ case t of
DeviceTool _ d -> deviceValue d
Sphere substance -> substanceValue substance
View
4 Roguestar/Lib/UnitTests.hs
@@ -19,6 +19,7 @@ import Roguestar.Lib.Random as Random
import qualified Test.HUnit.Base as HUnit
import qualified Test.HUnit.Text as HUnitText
import qualified Roguestar.Lib.Model.Tests as ModelTests
+import qualified Roguestar.Lib.Core.Tests as CoreTests
type UnitTest = WriterT (T.Text,All) IO ()
@@ -54,7 +55,8 @@ testcases :: HUnit.Test
testcases = HUnit.TestList [
HUnit.TestLabel "session" $ HUnit.TestList $ [testSessionAliveBeforeTimeout, testSessionExpiredAfterTimeout],
HUnit.TestLabel "database" $ HUnit.TestList $ [testSetPlayerState, testLocal],
- HUnit.TestLabel "Roguestar.Lib.Model" $ ModelTests.testcases]
+ HUnit.TestLabel "Roguestar.Lib.Model" $ ModelTests.testcases,
+ HUnit.TestLabel "Roguestar.Lib.Core" $ CoreTests.testcases]
testSessionAliveBeforeTimeout :: HUnit.Test
testSessionAliveBeforeTimeout = HUnit.TestCase $
View
15 Roguestar/Lib/Utility/Contact.hs
@@ -7,14 +7,15 @@ module Roguestar.Lib.Utility.Contact
where
import Prelude hiding (getContents)
-import Roguestar.Lib.Position as Position
+import Control.Monad
+import Control.Monad.Reader
+import Data.List as List
+import Data.Ord
import Roguestar.Lib.Data.FacingData
-import Roguestar.Lib.DB
import Roguestar.Lib.Data.MonsterData
-import Control.Monad
import Roguestar.Lib.Data.PlaneData
-import Data.Ord
-import Data.List as List
+import Roguestar.Lib.DB
+import Roguestar.Lib.Position as Position
import Roguestar.Lib.Utility.DetailedLocation
-- | 'Touch' contacts are on the same or facing square as the subject.
@@ -42,7 +43,7 @@ instance ContactModeType MonsterInteractionMode where
findContacts :: (DBReadable db,ContactModeType c) =>
c -> Reference x -> Facing -> db [DetailedLocation Planar]
findContacts contact_mode attacker_ref face =
- do (m_l :: Maybe (Parent Plane,MultiPosition)) <- liftM fromLocation $ whereIs attacker_ref
+ do (m_l :: Maybe (Parent Plane,MultiPosition)) <- liftM fromLocation $ asks $ whereIs attacker_ref
let testF pos (x :: MultiPosition) = case contactMode contact_mode of
Touch -> min (x `distanceBetweenChessboard` (offsetPosition (facingToRelative face) pos))
(x `distanceBetweenChessboard` pos) == 0
@@ -55,6 +56,6 @@ findContacts contact_mode attacker_ref face =
liftM (sortBy (comparing (Position.distanceBetweenSquared (center_pos pos) . (detail :: DetailedLocation Planar -> MultiPosition))) .
filter ((/= genericReference attacker_ref) . asChild . detail) .
filter (testF pos . detail)) $
- (liftM mapLocations $ getContents plane_ref)
+ (liftM mapLocations $ asks $ getContents plane_ref)
View
9 Roguestar/Lib/Utility/DetailedTravel.hs
@@ -5,14 +5,15 @@ module Roguestar.Lib.Utility.DetailedTravel
where
import Prelude hiding (getContents)
-import Roguestar.Lib.DB as DB
-import Roguestar.Lib.Utility.DetailedLocation
import Control.Monad
+import Control.Monad.Reader
import Data.Maybe
+import Roguestar.Lib.DB as DB
+import Roguestar.Lib.Utility.DetailedLocation
whereIs :: (DBReadable db,ReferenceType a) => Reference a -> db (DetailedLocation (Child a))
-whereIs = liftM (fromMaybe (error "DetailedTravel.whereIs: Reference is not a child of it's own location.") . fromLocation) . DB.whereIs
+whereIs = liftM (fromMaybe (error "DetailedTravel.whereIs: Reference is not a child of it's own location.") . fromLocation) . asks . DB.whereIs
getContents :: (DBReadable db,ReferenceType a) => Reference a -> db [DetailedLocation (Parent a)]
-getContents = liftM mapLocations . DB.getContents
+getContents = liftM mapLocations . asks . DB.getContents
View
2  roguestar.cabal
@@ -27,7 +27,7 @@ executable roguestar-server
system-uuid >= 1.2.7,
binary >= 0.5.1,
transformers >= 0.3.0.0,
- cipher-aes == 0.1.8,
+ cipher-aes,
HUnit >= 1.2
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
Please sign in to comment.
Something went wrong with that request. Please try again.