Permalink
Browse files

Add simple graph model.

  • Loading branch information...
clanehin committed Oct 7, 2013
1 parent 8efa521 commit 2fba10db668420858e1e785cd5cebdf79b40567d
View
@@ -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,15 +139,15 @@ 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 ()
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)
View
@@ -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 $
@@ -0,0 +1,36 @@
+{-# 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
+
@@ -0,0 +1,51 @@
+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
+
+
+
@@ -0,0 +1,16 @@
+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
+
@@ -0,0 +1,52 @@
+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)
+
Oops, something went wrong.

0 comments on commit 2fba10d

Please sign in to comment.