Add simple graph model.

parent 8efa5219
......@@ -91,17 +91,17 @@ dbBehave_ (FacingBehavior HolographicTrailStep face) creature_ref =
increaseTime creature_ref =<< getDuration holo_outcome
dbBehave_ StepDown creature_ref =
do _ <- atomic executeClimb $ resolveClimb creature_ref ClimbDown
do _ <- executeClimb =<< resolveClimb creature_ref ClimbDown
-- FIXME: should be conditional
increaseTime creature_ref =<< actionTime creature_ref
dbBehave_ StepUp creature_ref =
do _ <- atomic executeClimb $ resolveClimb creature_ref ClimbUp
do _ <- executeClimb =<< resolveClimb creature_ref ClimbUp
-- FIXME: should be conditional
increaseTime creature_ref =<< actionTime creature_ref
dbBehave_ (FacingBehavior Jump face) creature_ref =
do _ <- atomic executeTeleportJump $ resolveTeleportJump creature_ref face
do _ <- executeTeleportJump =<< resolveTeleportJump creature_ref face
increaseTime creature_ref =<< actionTime creature_ref -- FIXME: this should use moveActionTime
dbBehave_ (FacingBehavior TurnInPlace face) monster_ref =
......@@ -139,7 +139,7 @@ dbBehave_ (FacingBehavior Fire face) creature_ref =
do turn_outcome <- turnMonster face creature_ref
applyEffect turn_outcome
ranged_attack_model <- rangedAttackModel creature_ref
_ <- atomic executeAttackChain $ resolveAttackChain ranged_attack_model (Left face)
_ <- executeAttackChain =<< resolveAttackChain ranged_attack_model (Left face)
increaseTime creature_ref =<< actionTime creature_ref
return ()
......@@ -147,7 +147,7 @@ dbBehave_ (FacingBehavior Attack face) creature_ref =
do turn_outcome <- turnMonster face creature_ref
applyEffect turn_outcome
melee_attack_model <- meleeAttackModel creature_ref
_ <- atomic executeAttackChain $ resolveAttackChain melee_attack_model (Left face)
_ <- executeAttackChain =<< resolveAttackChain melee_attack_model (Left face)
increaseTime creature_ref =<< actionTime creature_ref
return ()
......@@ -164,7 +164,7 @@ dbBehave_ Vanish creature_ref =
return ()
dbBehave_ Activate creature_ref =
do _ <- atomic executeActivation $ resolveActivation creature_ref
do _ <- executeActivation =<< resolveActivation creature_ref
increaseTime creature_ref =<< actionTime creature_ref
return ()
......
......@@ -9,6 +9,7 @@ import Roguestar.Lib.Data.ToolData
import Roguestar.Lib.Core.Monster
import Roguestar.Lib.DB
import Control.Monad.Error
import Control.Monad.Random
import Roguestar.Lib.Data.Substances
-- | Outcome of activating a tool.
......@@ -17,7 +18,7 @@ data ActivationOutcome =
| ExpendTool ToolRef ActivationOutcome
| NoEffect
resolveActivation :: (DBReadable db) => MonsterRef -> db 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
......
......@@ -14,6 +14,7 @@ import Roguestar.Lib.Data.MonsterData
import Roguestar.Lib.Tool
import Roguestar.Lib.Data.ToolData
import Control.Monad.Error
import Control.Monad.Random
import Roguestar.Lib.Data.FacingData
import Data.Maybe
import Roguestar.Lib.Utility.Contact
......@@ -149,7 +150,7 @@ data AttackChainOutcome = AttackChainOutcome {
_chain_attack_outcome :: AttackOutcome,
_chain_damage_outcome :: [DamageOutcome] }
resolveAttackChain :: forall db. (DBReadable db) => AttackModel -> Either Facing MonsterRef -> db AttackChainOutcome
resolveAttackChain :: forall db. (MonadRandom db, DBReadable db) => AttackModel -> Either Facing MonsterRef -> db AttackChainOutcome
resolveAttackChain attack_model e_face_defender =
do m_defender_ref <- case e_face_defender of
Right defender_ref -> return $ Just defender_ref
......
......@@ -21,6 +21,7 @@ import Data.Maybe
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Random
import Data.Ord
import Roguestar.Lib.Position as Position
import Roguestar.Lib.Data.TerrainData
......@@ -95,9 +96,9 @@ data ClimbOutcome =
-- |
-- Climb up or down between Planes.
--
resolveClimb :: (DBReadable db) => MonsterRef ->
ClimbDirection ->
db ClimbOutcome
resolveClimb :: (MonadRandom db, DBReadable db) => MonsterRef ->
ClimbDirection ->
db ClimbOutcome
resolveClimb creature_ref direction = liftM (fromMaybe ClimbFailed) $ runMaybeT $
do l <- lift $ DetailedTravel.whereIs creature_ref
let plane_ref :: PlaneRef = asParent $ detail l
......@@ -138,7 +139,7 @@ executeClimb (ClimbGood direction creature_ref standing_location) =
-- 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.
--
randomTeleportLanding :: (DBReadable db) => Integer -> PlaneRef -> Position -> Position -> db Position
randomTeleportLanding :: (MonadRandom db, DBReadable db) => Integer -> PlaneRef -> Position -> Position -> db Position
randomTeleportLanding retries plane_ref source_destination goal_destination =
do landings <- replicateM (fromInteger $ max 1 retries) $ (pickRandomClearSite 3) 0 0 goal_destination (not . (`elem` impassable_terrains)) plane_ref
return $ minimumBy (comparing $ \p -> Position.distanceBetweenSquared goal_destination p ^ 2 * Position.distanceBetweenSquared source_destination p) landings
......@@ -150,7 +151,7 @@ data TeleportJumpOutcome =
-- |
-- Teleport jump a creature about 5-7 units in the specified direction.
--
resolveTeleportJump :: (DBReadable db) => MonsterRef -> Facing -> db TeleportJumpOutcome
resolveTeleportJump :: (MonadRandom db, DBReadable db) => MonsterRef -> Facing -> db TeleportJumpOutcome
resolveTeleportJump creature_ref face = liftM (fromMaybe TeleportJumpFailed) $ runMaybeT $
do start_location <- lift $ DetailedTravel.whereIs creature_ref
jump_roll <- lift $ getMonsterAbilityScore JumpSkill creature_ref
......@@ -225,7 +226,7 @@ resolveStepWithHolographicTrail facing monster_ref =
-- TemporalWeb
--------------------------------------------------------------------------------
resolveStepWithTemporalWeb :: (DBReadable db) => Facing -> MonsterRef -> db (OutcomeWithEffect MoveOutcome (MoveOutcome,[SlowMonsterEffect]))
resolveStepWithTemporalWeb :: (MonadRandom db, DBReadable db) => Facing -> MonsterRef -> db (OutcomeWithEffect MoveOutcome (MoveOutcome,[SlowMonsterEffect]))
resolveStepWithTemporalWeb facing monster_ref =
do move_outcome <- stepMonster facing monster_ref
let (plane_ref :: PlaneRef, position :: Position) = (standing_plane $ move_from move_outcome, standing_position $ move_from move_outcome)
......
......@@ -104,7 +104,7 @@ dbPerform1MonsterAITurn :: MonsterRef -> DB ()
dbPerform1MonsterAITurn creature_ref =
do logDB gameplay_log INFO $ "dbPerform1MonsterAITurn; Performing a creature's AI turn: id=" ++ show (toUID creature_ref)
liftM (const ()) $ atomic (flip executeBehavior creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $
do let isPlayer :: forall db. (DBReadable db) => Reference () -> P.DBPerception db Bool
do let isPlayer :: forall db. (MonadRandom db, DBReadable db) => Reference () -> P.DBPerception db Bool
isPlayer ref | (Just might_be_the_player_creature_ref) <- coerceReference ref =
do f <- P.getMonsterFaction might_be_the_player_creature_ref
return $ f == Player
......
......@@ -51,7 +51,7 @@ dbNewPlane name tg_data l =
planetName :: (DBReadable db) => PlaneRef -> db B.ByteString
planetName = liftM plane_planet_name . dbGetPlane
randomPlanetName :: (DBReadable db) => Faction -> db B.ByteString
randomPlanetName :: (MonadRandom db, DBReadable db) => Faction -> db B.ByteString
randomPlanetName faction =
do planet_number <- getRandomR (1000 :: Integer,9999)
return $ factionPrefix faction `B.append` "-" `B.append` B.pack (show planet_number)
......@@ -140,7 +140,7 @@ getCurrentPlane = runMaybeT $
--
-- 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) =>
pickRandomClearSite :: (MonadRandom db, DBReadable db) =>
Integer -> Integer -> Integer ->
Position -> (Terrain -> Bool) -> PlaneRef ->
db Position
......@@ -159,7 +159,7 @@ pickRandomClearSite search_radius
terrainPredicate
plane_ref
pickRandomClearSite_withTimeout :: (DBReadable db) =>
pickRandomClearSite_withTimeout :: (MonadRandom db, DBReadable db) =>
Maybe Integer -> Integer -> Integer -> Integer ->
Position -> (Terrain -> Bool) -> PlaneRef ->
db (Maybe Position)
......
......@@ -175,11 +175,9 @@ dbRandom rgen = DB $ \context ->
writeSTRef (db_rng context) g1
return $ Right x
class (Monad db,MonadError DBError db,MonadReader DB_BaseType db,MonadRandom db,Applicative db) => DBReadable db where
class (Monad db,MonadError DBError db,MonadReader DB_BaseType db,Applicative db,MonadRandom db) => DBReadable db where
dbSimulate :: DB a -> db a
dbPeepSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db (Maybe a)
-- uniform :: (Int,Int) -> db Int
-- uniformVector :: Int -> (Int,Int) -> db (Vector.Vector Int)
instance DBReadable DB where
dbSimulate = local id
......@@ -189,19 +187,13 @@ instance DBReadable DB where
Just snapshot ->
do liftM Just $ local (const snapshot) $ dbSimulate actionM
Nothing -> return Nothing
{- uniform range = DB $ \context ->
do gen <- readSTRef (db_mwc_rng context)
liftM Right $ MWC.uniformR range gen
uniformVector n (a,b) = DB $ \ context ->
do gen <- readSTRef (db_mwc_rng context)
liftM (Right . Vector.map ((+a) . (`mod` (b-a)))) $ MWC.uniformVector gen n -}
logDB :: (DBReadable db) => String -> Priority -> String -> db ()
logDB l p s = unsafePerformIO $
do logM l p $ l ++ ": " ++ s
return $ return ()
ro :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
ro :: (DBReadable db) => (forall m. (MonadRandom m, DBReadable m) => m a) -> db a
ro db = dbSimulate db
filterRO :: (DBReadable db) => (forall m. DBReadable m => a -> m Bool) -> [a] -> db [a]
......@@ -220,7 +212,7 @@ sortByRO f xs =
-- I don't remember why I wrote this function, and suspect that it is not needed.
-- It might have had something to do with reverting the state of the database if
-- an error were thrown.
atomic :: (x -> DB ()) -> (forall m. DBReadable m => m x) -> DB x
atomic :: (x -> DB ()) -> (forall m. (MonadRandom m, DBReadable m) => m x) -> DB x
atomic action ro_action =
do x <- ro ro_action
s <- dbSimulate $
......
{-# LANGUAGE FlexibleContexts #-}
module Roguestar.Lib.Model.Classes
(HasPlane(..),
HasMonsters(..),
comonsters)
where
import Control.Arrow
import Roguestar.Lib.Model.Graph
import qualified Data.Set as Set
class HasPlane a where
plane :: a x -> Plane x
class HasMonsters a where
monsters :: a x -> Set.Set (Monster x)
instance HasPlane Plane where
plane = id
instance HasPlane Square where
plane = square_to_plane
instance HasPlane Monster where
plane = monster_to_square >>> square_to_plane
instance HasMonsters Plane where
monsters = plane_to_monsters
instance HasMonsters Monster where
monsters m = Set.singleton m
-- | Monsters, other than this monster, on the same plane as this monster.
comonsters :: (Eq (Monster x)) => Monster x -> Set.Set (Monster x)
comonsters m = Set.filter (/= m) $ monsters $ plane m
module Roguestar.Lib.Model.Graph
(Monster(..),
Plane(..),
Square(..))
where
import qualified Data.Set as Set
data Monster a = Monster {
monster_to_uid :: a,
monster_to_square :: Square a }
deriving (Show)
data Square a = Square {
square_to_plane :: Plane a }
deriving (Show)
data Plane a = Plane {
plane_to_uid :: a,
plane_to_monsters :: Set.Set (Monster a) }
deriving (Show)
class HasGraphUID a where
toUID :: a x -> x
instance HasGraphUID Monster where
toUID = monster_to_uid
instance HasGraphUID Plane where
toUID = plane_to_uid
eqByUID :: (HasGraphUID a, Eq x) => a x -> a x -> Bool
eqByUID a b = toUID a == toUID b
instance (Eq a) => Eq (Monster a) where
(==) = eqByUID
instance (Eq a) => Eq (Plane a) where
(==) = eqByUID
ordByUID :: (HasGraphUID a, Ord x) => a x -> a x -> Ordering
ordByUID a b = compare (toUID a) (toUID b)
instance (Ord a) => Ord (Monster a) where
compare = ordByUID
instance (Ord a) => Ord (Plane a) where
compare = ordByUID
module Roguestar.Lib.Model.GraphUIDs
()
where
class HasGraphUID a where
toUID :: a x -> x
instance HasGraphUID Monster where
toUID = monster_to_uid
instance HasGraphUID Plane where
toUID = plane_to_uid
eqByUID :: (HasGraphUID a, Eq x) => a x -> a x -> Bool
eqByUID a b = toUID a == toUID b
module Roguestar.Lib.Model.Tests
(testcases)
where
import Roguestar.Lib.Model.Graph
import Roguestar.Lib.Model.Classes
import qualified Data.Set as Set
import Test.HUnit
testcases :: Test
testcases = TestLabel "Roguestar.Lib.Model.Tests" $ TestList [
testPlaneToSelf,
testMonsterToPlane,
testCoMonsters]
data ID =
Equestria
| Nirn
| Twilight
| Ysolda
| Zathras
deriving (Eq, Ord, Show)
equestria :: Plane ID
equestria = Plane {
plane_to_uid = Equestria,
plane_to_monsters = Set.fromList [twilight, ysolda, zathras] }
twilight :: Monster ID
twilight = Monster {
monster_to_uid = Twilight,
monster_to_square = Square equestria }
ysolda :: Monster ID
ysolda = Monster {
monster_to_uid = Ysolda,
monster_to_square = Square equestria }
zathras :: Monster ID
zathras = Monster {
monster_to_uid = Zathras,
monster_to_square = Square equestria }
testPlaneToSelf :: Test
testPlaneToSelf = TestCase $ assertEqual "testPlaneToSelf" equestria (plane equestria)
testMonsterToPlane :: Test
testMonsterToPlane = TestCase $ assertEqual "testMonsterToPlane" equestria (plane ysolda)
testCoMonsters :: Test
testCoMonsters = TestCase $ assertEqual "testCoMonsters" (Set.fromList [twilight, ysolda]) (comonsters zathras)
......@@ -70,7 +70,7 @@ instance (DBReadable db,MonadRandom db) => MonadRandom (DBPerception db) where
-- 'liftDB' takes an action in DBReadable and lifts it to DBPerception. Obviously not exported,
-- or DBPerception wouldn't be limited.
--
liftDB :: (DBReadable db) => (forall m. DBReadable m => m a) -> DBPerception db a
liftDB :: (MonadRandom db, DBReadable db) => (forall m. (MonadRandom m, DBReadable m) => m a) -> DBPerception db a
liftDB actionM = DBPerception $ lift actionM
-- |
......@@ -83,10 +83,10 @@ whoAmI = DBPerception $ ask
-- |
-- Run a DBPerception from the point-of-view of the given creature.
--
runPerception :: (DBReadable db) => MonsterRef -> (forall m. DBReadable m => DBPerception m a) -> db a
runPerception :: (MonadRandom db, DBReadable db) => MonsterRef -> (forall m. DBReadable m => DBPerception m a) -> db a
runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref
visibleTerrain :: (DBReadable db) => DBPerception db [(Position,Terrain)]
visibleTerrain :: (MonadRandom db, DBReadable db) => DBPerception db [(Position,Terrain)]
visibleTerrain =
do plane_ref <- whatPlaneAmIOn
faction <- myFaction
......@@ -177,8 +177,8 @@ visibleObjectSize :: VisibleObject -> Integer
visibleObjectSize (VisibleTool {} ) = 0
visibleObjectSize _ = 1000000
visibleObjects :: (DBReadable db) =>
(forall m. DBReadable m => Reference () -> DBPerception m Bool) ->
visibleObjects :: (MonadRandom db, DBReadable db) =>
(forall m. (MonadRandom m, DBReadable m) => Reference () -> DBPerception m Bool) ->
DBPerception db [VisibleObject]
visibleObjects filterF =
do me <- whoAmI
......@@ -192,31 +192,31 @@ visibleObjects filterF =
Nothing -> return []
liftDB $ mapRO convertToVisibleObjectRecord visible_objects
myInventory :: (DBReadable db) => DBPerception db [VisibleObject]
myInventory :: (MonadRandom db, DBReadable db) => DBPerception db [VisibleObject]
myInventory =
do me <- whoAmI
(result :: [DetailedLocation Inventory]) <- liftDB $ liftM mapLocations $ DB.getContents me
liftDB $ mapRO convertToVisibleObjectRecord $ sortBy (comparing toUID) $ (asChildren result :: [ToolRef])
myFaction :: (DBReadable db) => DBPerception db Faction
myFaction :: (MonadRandom db, DBReadable db) => DBPerception db Faction
myFaction = Roguestar.Lib.Perception.getMonsterFaction =<< whoAmI
getMonsterFaction :: (DBReadable db) => MonsterRef -> DBPerception db Faction
getMonsterFaction :: (MonadRandom db, DBReadable db) => MonsterRef -> DBPerception db Faction
getMonsterFaction creature_ref = liftDB $ Monster.getMonsterFaction creature_ref
whereAmI :: (DBReadable db) => DBPerception db (Facing,Position)
whereAmI :: (MonadRandom db, DBReadable db) => DBPerception db (Facing,Position)
whereAmI = liftM detail $ Roguestar.Lib.Perception.whereIs =<< whoAmI
whatPlaneAmIOn :: (DBReadable db) => DBPerception db PlaneRef
whatPlaneAmIOn :: (MonadRandom db, DBReadable db) => DBPerception db PlaneRef
whatPlaneAmIOn = liftM (planar_parent . identityDetail) $ (\x -> liftDB $ getPlanarLocation x) =<< whoAmI
whereIs :: (DBReadable db, ReferenceType a) =>
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
-- 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
compass :: (DBReadable db) => DBPerception db Facing
compass :: (MonadRandom db, DBReadable db) => DBPerception db Facing
compass =
do (_,pos) <- whereAmI
plane <- whatPlaneAmIOn
......@@ -231,17 +231,17 @@ compass =
-- |
-- Depth of the current plane below the surface.
--
depth :: (DBReadable db) => DBPerception db Integer
depth :: (MonadRandom db, DBReadable db) => DBPerception db Integer
depth =
do plane <- whatPlaneAmIOn
liftDB $ planeDepth plane
myHealth :: (DBReadable db) => DBPerception db MonsterHealth
myHealth :: (MonadRandom db, DBReadable db) => DBPerception db MonsterHealth
myHealth =
do creature_ref <- whoAmI
liftDB $ getMonsterHealth creature_ref
isBehaviorAvailable :: (DBReadable db) => Behavior -> DBPerception db Bool
isBehaviorAvailable :: (MonadRandom db, DBReadable db) => Behavior -> DBPerception db Bool
isBehaviorAvailable b =
do creature_ref <- whoAmI
liftDB $ Behavior.isBehaviorAvailable b creature_ref
......
......@@ -13,6 +13,7 @@ import Roguestar.Lib.Data.TerrainData
import Roguestar.Lib.Core.Plane
import Roguestar.Lib.Data.PlaneData
import Control.Monad
import Control.Monad.Random
import Roguestar.Lib.Data.MonsterData
import Data.List as List
import Roguestar.Lib.Utility.Grids
......@@ -52,10 +53,10 @@ dbGetVisibleTerrainForMonster creature_ref =
-- to the specified faction on the specified plane. Accepts a filter to
-- determine what kinds of objects will be tested.
--
dbGetVisibleObjectsForFaction :: (DBReadable db) => (forall m. DBReadable m => Reference () -> m Bool) -> Faction -> PlaneRef -> db [Reference ()]
dbGetVisibleObjectsForFaction :: (MonadRandom db, DBReadable db) => (forall m. (MonadRandom m, DBReadable m) => Reference () -> m Bool) -> Faction -> PlaneRef -> db [Reference ()]
dbGetVisibleObjectsForFaction filterF faction plane_ref =
do critters <- dbGetSeersForFaction faction plane_ref
liftM (nubBy (=:=) . concat) $ mapRO (dbGetVisibleObjectsForMonster filterF) critters
liftM (nubBy (=:=) . concat) $ mapM (dbGetVisibleObjectsForMonster (\x -> ro $ filterF x)) critters
-- |
-- Returns a list of all objects that are visible to the specified creature.
......
--Deprecated
module Roguestar.Lib.Tests
(TestResult(..),
TestCase,
test,
runAllTests,
(TestResult(..),
TestCase,
test,
runAllTests,
sampleTestCase)
where
......
......@@ -16,19 +16,20 @@ import Roguestar.Lib.Data.TerrainData
import Roguestar.Lib.Utility.SiteCriteria
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
type UnitTest = WriterT (T.Text,All) IO ()
runTests :: IO (T.Text,Bool)
runTests =
do ((),(t,All b)) <- runWriterT $ sequence_ unit_tests
return (t,b)
counts <- HUnitText.runTestTT testcases
return (t,b && HUnit.errors counts > 0 || HUnit.failures counts > 0)
unit_tests :: [UnitTest]
unit_tests = [testSessionAliveBeforeTimeout,
testSessionExpiredAfterTimeout,
testSetPlayerState,
testLocal,
testPickRandomClearSite]
unit_tests = [testPickRandomClearSite]
assert :: Bool -> T.Text -> UnitTest
assert ok test_name =
......@@ -36,17 +37,6 @@ assert ok test_name =
tell (message, All ok)
liftIO $ hPutStr stderr $ T.unpack message
assertEqual :: (Show a,Eq a) => a -> a -> T.Text -> UnitTest
assertEqual actual expected test_name =
do let ok = actual == expected
message = test_name `T.append` (if ok then ": ok." else ": FAILED." `T.append` "\n"
`T.append`
("Actual: " `T.append` T.pack (show actual) `T.append` "\n")
`T.append`
("Expected: " `T.append` T.pack (show expected))) `T.append` "\n"
tell (message, All ok)
liftIO $ hPutStr stderr $ T.unpack message
-- Generate N random planes and run tests against them.
runWithRandomPlanes :: Int -> T.Text -> (PlaneRef -> DB Bool) -> UnitTest
runWithRandomPlanes n test_name db_action = forM_ [1..n] $ \x ->
......@@ -60,40 +50,51 @@ runWithRandomPlane_ dbAction =
dbAction plane_ref
{-- UNIT TESTS BEGIN HERE --}
testSessionAliveBeforeTimeout :: UnitTest
testSessionAliveBeforeTimeout =
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]
testSessionAliveBeforeTimeout :: HUnit.Test
testSessionAliveBeforeTimeout = HUnit.TestCase $
do game_state <- liftIO $ createGameState (GameConfiguration 10 0)
game_uuid <- liftIO $ createGame (GameConfiguration 10 1) game_state
m_g <- liftIO $ retrieveGame game_uuid (GameConfiguration 10 9) game_state
liftIO $ threadDelay 100
assert ( isJust m_g ) "testSessionAliveBeforeTimeout"
HUnit.assertBool "testSessionAliveBeforeTimeout" ( isJust m_g )
testSessionExpiredAfterTimeout :: UnitTest
testSessionExpiredAfterTimeout =
testSessionExpiredAfterTimeout :: HUnit.Test
testSessionExpiredAfterTimeout = HUnit.TestCase $
do game_state <- liftIO $ createGameState (GameConfiguration 10 0)
game_uuid <- liftIO $ createGame (GameConfiguration 10 1) game_state
_ <- liftIO $ createGame (GameConfiguration 10 12) game_state
liftIO $ threadDelay 100
m_g2 <- liftIO $ retrieveGame game_uuid (GameConfiguration 10 12) game_state
assert ( isNothing m_g2 ) "testSessionExpiredAfterTimeout"
HUnit.assertBool "testSessionExpiredAfterTimeout" ( isNothing m_g2 )
testSetPlayerState :: UnitTest
testSetPlayerState =
-- |
-- Test that we can store and retrieve some simple piece of information in the database.
--
testSetPlayerState :: HUnit.Test
testSetPlayerState = HUnit.TestCase $
do m_pstate <- liftIO $ flip runDB initial_db $
do setPlayerState (GameOver PlayerIsVictorious)
playerState
case m_pstate of
Left _ -> assert False "testSetPlayerState (failed in monad)"
Right (pstate,_) -> assertEqual pstate (GameOver PlayerIsVictorious) "testSetPlayerState"
Left _ -> HUnit.assertFailure "testSetPlayerState (failed in monad)"
Right (pstate,_) -> HUnit.assertEqual "testSetPlayState" pstate (GameOver PlayerIsVictorious)
testLocal :: UnitTest
testLocal =
-- |
-- Test that we can execute read-only branches. Changes should not linger after the read-only branch exits.
testLocal :: HUnit.Test
testLocal = HUnit.TestCase $
do m_pstate <- liftIO $ flip runDB initial_db $
do local id $ setPlayerState (GameOver PlayerIsVictorious)
playerState
case m_pstate of
Left _ -> assert False "testLocal (failed in monad)"
Right (pstate,_) -> assertEqual pstate (SpeciesSelectionState Nothing) "testLocal"
Left _ -> HUnit.assertFailure "testLocal (failed in monad)"
Right (pstate,_) -> HUnit.assertEqual "testLocal" pstate (SpeciesSelectionState Nothing)
testPickRandomClearSite :: UnitTest
testPickRandomClearSite = runWithRandomPlanes 10 "testPickRandomClearSite" $ \plane_ref ->
......
......@@ -74,12 +74,12 @@ atDistanceFrom p d = AtDistanceFrom p d
instance SiteCriteria a => SiteCriteria [a] where
testSiteCriteria plane_ref p xs = liftM sum $ mapM (testSiteCriteria plane_ref p) xs
pickRandomSite :: (DBReadable db, SiteCriteria a) => (Integer,Integer) -> (Integer,Integer) -> Integer -> a -> PlaneRef -> db Position
pickRandomSite :: (MonadRandom db, DBReadable db, SiteCriteria a) => (Integer,Integer) -> (Integer,Integer) -> Integer -> a -> PlaneRef -> db Position
pickRandomSite east_west north_south tryhard site_criteria plane_ref =
do liftM pickBest $ forM [1.. fromInteger tryhard] $ const generateOption
where pickBest :: [(Double,Position)] -> Position
pickBest = snd . maximumBy (comparing fst)
generateOption :: (DBReadable db) => db (Double,Position)
generateOption :: (MonadRandom db, DBReadable db) => db (Double,Position)
generateOption =
do x <- getRandomR east_west
y <- getRandomR north_south
......
......@@ -27,7 +27,8 @@ executable roguestar-server
system-uuid >= 1.2.7,
binary >= 0.5.1,
transformers >= 0.3.0.0,
cipher-aes == 0.1.8
cipher-aes == 0.1.8,
HUnit >= 1.2
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
if impl(ghc >= 7.0)
......@@ -60,9 +61,20 @@ library
streams >= 0.8.2
other-modules: Roguestar.Lib.Perception,
Roguestar.Lib.PlaneVisibility,
Roguestar.Lib.Behavior,
Roguestar.Lib.Behavior.Activate,
Roguestar.Lib.Behavior.CharacterAdvancement,
Roguestar.Lib.Behavior.Combat,
Roguestar.Lib.Behavior.Construction,
Roguestar.Lib.Behavior.Make,
Roguestar.Lib.Behavior.Travel,
Roguestar.Lib.Behavior.Turns,
Roguestar.Lib.Core.Building,
Roguestar.Lib.Core.Monster,
Roguestar.Lib.Core.Plane,
Roguestar.Lib.Model.Graph,
Roguestar.Lib.Model.Classes,
Roguestar.Lib.Model.Tests,
Roguestar.Lib.Utility.Contact,
Roguestar.Lib.Utility.Grids,
Roguestar.Lib.Utility.HierarchicalDatabase,
......@@ -78,14 +90,6 @@ library
Roguestar.Lib.DB,
Roguestar.Lib.Town,
Roguestar.Lib.Random,
Roguestar.Lib.Behavior,
Roguestar.Lib.Behavior.Activate,
Roguestar.Lib.Behavior.CharacterAdvancement,
Roguestar.Lib.Behavior.Combat,
Roguestar.Lib.Behavior.Construction,
Roguestar.Lib.Behavior.Make,
Roguestar.Lib.Behavior.Travel,
Roguestar.Lib.Behavior.Turns,
Roguestar.Lib.Logging,
Roguestar.Lib.Data.BuildingData,
Roguestar.Lib.Data.CharacterData,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment