Pops irrelevant events.

parent c44ec0c8
......@@ -14,7 +14,7 @@ import Roguestar.Lib.ToolData
import Control.Monad
import Control.Monad.Error
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Roguestar.Lib.Town
import qualified Data.ByteString.Char8 as B ()
import Control.Monad.Random
......
......@@ -14,7 +14,6 @@ import Roguestar.Lib.Position
import Roguestar.Lib.Facing
import Data.Ratio
import Roguestar.Lib.Tool
import Roguestar.Lib.ToolData
import Control.Monad.Error
import Roguestar.Lib.Behavior.Combat
import Roguestar.Lib.Activate
......@@ -25,14 +24,12 @@ import Roguestar.Lib.CreatureData
import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlaneVisibility
import Data.List
import Control.Monad.Maybe
import Roguestar.Lib.TerrainData
import Roguestar.Lib.Behavior.Make
import Roguestar.Lib.Behavior.Construction
import Roguestar.Lib.Building
import Roguestar.Lib.Reference
import Roguestar.Lib.DetailedLocation
import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlaneData
--
......
......@@ -37,7 +37,6 @@ walkCreature face (x',y') creature_ref =
do l <- DetailedTravel.whereIs creature_ref
let (Parent plane_ref) = detail l
Position (x,y) = detail l
(Child creature_ref) = identityDetail l
standing = Standing { standing_plane = plane_ref,
standing_position = Position (x+x',y+y'),
standing_facing = face }
......
......@@ -24,7 +24,7 @@ import Control.Monad.Error
import Roguestar.Lib.PowerUpData
import Roguestar.Lib.CharacterAdvancement
import Roguestar.Lib.DetailedLocation
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
-- | The total occupied surface area of a building.
buildingSize :: (DBReadable db) => BuildingRef -> db Integer
......
......@@ -32,7 +32,7 @@ import Control.Monad.Random as Random
import Data.Maybe
import Data.List
import Roguestar.Lib.Position as Position
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Roguestar.Lib.FactionData
import Roguestar.Lib.DetailedLocation
import qualified Data.ByteString.Char8 as B
......
......@@ -27,7 +27,7 @@ import Control.Monad.Random
import Roguestar.Lib.Facing
import Roguestar.Lib.Position
import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Roguestar.Lib.DetailedLocation
import Roguestar.Lib.Logging
......
......@@ -74,7 +74,7 @@ import Roguestar.Lib.TimeCoordinate
import Data.Ord
import Control.Monad.Random as Random
import Roguestar.Lib.Random
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Roguestar.Lib.DBErrorFlag
import Control.Parallel.Strategies
import System.IO.Unsafe
......
module Roguestar.Lib.Data.PlayerState
(PlayerState(..),
SnapshotEvent(..),
HasParticipants(..),
GameOverReason(..))
where
import Roguestar.Lib.DBData
import Roguestar.Lib.CreatureData
import Roguestar.Lib.TravelData
import Roguestar.Lib.PersistantData
import Data.Maybe
data PlayerState =
SpeciesSelectionState (Maybe Creature)
| PlayerCreatureTurn CreatureRef
| SnapshotEvent SnapshotEvent
| GameOver GameOverReason
deriving (Read,Show,Eq)
data GameOverReason = PlayerIsDead | PlayerIsVictorious
deriving (Read,Show,Eq)
data SnapshotEvent =
AttackEvent {
attack_event_source_creature :: CreatureRef,
attack_event_source_weapon :: Maybe ToolRef,
attack_event_target_creature :: CreatureRef }
| MissEvent {
miss_event_creature :: CreatureRef,
miss_event_weapon :: Maybe ToolRef }
| KilledEvent {
killed_event_creature :: CreatureRef }
| WeaponOverheatsEvent {
weapon_overheats_event_creature :: CreatureRef,
weapon_overheats_event_weapon :: ToolRef }
| WeaponExplodesEvent {
weapon_explodes_event_creature :: CreatureRef,
weapon_explodes_event_weapon :: ToolRef }
| DisarmEvent {
disarm_event_source_creature :: CreatureRef,
disarm_event_target_creature :: CreatureRef,
disarm_event_target_tool :: ToolRef }
| SunderEvent {
sunder_event_source_creature :: CreatureRef,
sunder_event_source_weapon :: ToolRef,
sunder_event_target_creature :: CreatureRef,
sunder_event_target_tool :: ToolRef }
| TeleportEvent {
teleport_event_creature :: CreatureRef }
| SpawnEvent {
spawn_event_creature :: CreatureRef }
| ClimbEvent {
climb_event_direction :: ClimbDirection,
climb_event_creature :: CreatureRef }
| HealEvent {
heal_event_creature :: CreatureRef }
| ExpendToolEvent {
expend_tool_event_tool :: ToolRef }
| BumpEvent {
bump_event_creature :: CreatureRef,
bump_event_new_level :: Maybe Integer,
bump_event_new_class :: Maybe CharacterClass }
deriving (Read,Show,Eq)
class HasParticipants a where
subjectOf :: a -> Maybe CreatureRef
targetOf :: a -> Maybe CreatureRef
participantsOf :: a -> [CreatureRef]
participantsOf a = catMaybes $ [subjectOf a, targetOf a]
instance HasParticipants PlayerState where
subjectOf (SpeciesSelectionState {}) = Nothing
subjectOf (PlayerCreatureTurn x) = Just x
subjectOf (SnapshotEvent x) = subjectOf x
subjectOf (GameOver {}) = Nothing
targetOf (SpeciesSelectionState {}) = Nothing
targetOf (PlayerCreatureTurn x) = Just x
targetOf (SnapshotEvent x) = targetOf x
targetOf (GameOver {}) = Nothing
instance HasParticipants SnapshotEvent where
subjectOf event = case event of
AttackEvent { attack_event_source_creature = attacker_ref } -> Just attacker_ref
MissEvent { miss_event_creature = attacker_ref } -> Just attacker_ref
WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref } -> Just attacker_ref
WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref } -> Just attacker_ref
KilledEvent killed_ref -> Just killed_ref
DisarmEvent { disarm_event_source_creature = attacker_ref } -> Just attacker_ref
SunderEvent { sunder_event_source_creature = attacker_ref } -> Just attacker_ref
TeleportEvent { teleport_event_creature = creature_ref } -> Just creature_ref
SpawnEvent { spawn_event_creature = creature_ref } -> Just creature_ref
HealEvent { heal_event_creature = creature_ref } -> Just creature_ref
ClimbEvent { climb_event_creature = creature_ref } -> Just creature_ref
BumpEvent { bump_event_creature = creature_ref } -> Just creature_ref
ExpendToolEvent {} -> Nothing
targetOf event = case event of
AttackEvent { attack_event_target_creature = target_ref } -> Just target_ref
MissEvent {} -> Nothing
WeaponOverheatsEvent {} -> Nothing
WeaponExplodesEvent {} -> Nothing
KilledEvent {} -> Nothing
DisarmEvent { disarm_event_target_creature = target_ref } -> Just target_ref
SunderEvent { sunder_event_target_creature = target_ref } -> Just target_ref
TeleportEvent {} -> Nothing
SpawnEvent {} -> Nothing
HealEvent {} -> Nothing
ClimbEvent {} -> Nothing
BumpEvent {} -> Nothing
ExpendToolEvent {} -> Nothing
--Data
module Roguestar.Lib.PlayerState
(PlayerState(..),
SnapshotEvent(..),
HasSubject(..),
GameOverReason(..))
where
import Roguestar.Lib.DBData
import Roguestar.Lib.CreatureData
import Roguestar.Lib.TravelData
import Roguestar.Lib.PersistantData
data PlayerState =
SpeciesSelectionState (Maybe Creature)
| PlayerCreatureTurn CreatureRef
| SnapshotEvent SnapshotEvent
| GameOver GameOverReason
deriving (Read,Show,Eq)
data GameOverReason = PlayerIsDead | PlayerIsVictorious
deriving (Read,Show,Eq)
data SnapshotEvent =
AttackEvent {
attack_event_source_creature :: CreatureRef,
attack_event_source_weapon :: Maybe ToolRef,
attack_event_target_creature :: CreatureRef }
| MissEvent {
miss_event_creature :: CreatureRef,
miss_event_weapon :: Maybe ToolRef }
| KilledEvent {
killed_event_creature :: CreatureRef }
| WeaponOverheatsEvent {
weapon_overheats_event_creature :: CreatureRef,
weapon_overheats_event_weapon :: ToolRef }
| WeaponExplodesEvent {
weapon_explodes_event_creature :: CreatureRef,
weapon_explodes_event_weapon :: ToolRef }
| DisarmEvent {
disarm_event_source_creature :: CreatureRef,
disarm_event_target_creature :: CreatureRef,
disarm_event_target_tool :: ToolRef }
| SunderEvent {
sunder_event_source_creature :: CreatureRef,
sunder_event_source_weapon :: ToolRef,
sunder_event_target_creature :: CreatureRef,
sunder_event_target_tool :: ToolRef }
| TeleportEvent {
teleport_event_creature :: CreatureRef }
| SpawnEvent {
spawn_event_creature :: CreatureRef }
| ClimbEvent {
climb_event_direction :: ClimbDirection,
climb_event_creature :: CreatureRef }
| HealEvent {
heal_event_creature :: CreatureRef }
| ExpendToolEvent {
expend_tool_event_tool :: ToolRef }
| BumpEvent {
bump_event_creature :: CreatureRef,
bump_event_new_level :: Maybe Integer,
bump_event_new_class :: Maybe CharacterClass }
deriving (Read,Show,Eq)
class HasSubject a where
subjectOf :: a -> Maybe CreatureRef
instance HasSubject PlayerState where
subjectOf (SpeciesSelectionState {}) = Nothing
subjectOf (PlayerCreatureTurn x) = Just x
subjectOf (SnapshotEvent x) = subjectOf x
subjectOf (GameOver {}) = Nothing
instance HasSubject SnapshotEvent where
subjectOf event = case event of
AttackEvent { attack_event_source_creature = attacker_ref } -> Just attacker_ref
MissEvent { miss_event_creature = attacker_ref } -> Just attacker_ref
WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref } -> Just attacker_ref
WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref } -> Just attacker_ref
KilledEvent killed_ref -> Just killed_ref
DisarmEvent { disarm_event_source_creature = attacker_ref } -> Just attacker_ref
SunderEvent { sunder_event_source_creature = attacker_ref } -> Just attacker_ref
TeleportEvent { teleport_event_creature = creature_ref } -> Just creature_ref
SpawnEvent { spawn_event_creature = creature_ref } -> Just creature_ref
HealEvent { heal_event_creature = creature_ref } -> Just creature_ref
ClimbEvent { climb_event_creature = creature_ref } -> Just creature_ref
BumpEvent { bump_event_creature = creature_ref } -> Just creature_ref
ExpendToolEvent {} -> Nothing
......@@ -31,12 +31,13 @@ module Roguestar.Lib.Roguestar
import System.UUID.V4 as V4
import Data.Map as Map
import Data.List as List
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Roguestar.Lib.DB as DB
import Control.Concurrent.STM
import Control.Monad
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.Creature
import Roguestar.Lib.CreatureData
......@@ -46,9 +47,12 @@ import Roguestar.Lib.TerrainData
import Roguestar.Lib.Facing
import Roguestar.Lib.Behavior as Behavior
import Roguestar.Lib.Turns
import Roguestar.Lib.Core.Plane
import Data.Text as T
import System.Time
import Control.Concurrent
import Roguestar.Lib.FactionData
import Roguestar.Lib.PlaneVisibility
-- Session timeout information.
data GameConfiguration = GameConfiguration {
......@@ -104,7 +108,7 @@ doCleanup config game_state =
do last_touched <- readTVar $ game_last_touched value
when (game_config_current_clock_time_seconds config > last_touched + game_config_timeout_seconds config) $
writeTVar (game_state_gamelist game_state) =<< liftM (Map.delete key) (readTVar $ game_state_gamelist game_state)
createGame :: GameConfiguration -> GameState -> IO BS.ByteString
createGame config game_state =
do cleanupGameState config game_state
......@@ -139,13 +143,34 @@ peek g f =
poke :: Game -> DB a -> IO (Either DBError a)
poke g f =
do game <- atomically $ readTVar (game_db g)
result <- runDB f game
result <- flip runDB game $
do result <- f
cleanupNonPlayerSnapshots
return result
case result of
Left err -> return $ Left err
Right (a,next_db) ->
do atomically $ writeTVar (game_db g) next_db
return $ Right a
cleanupNonPlayerSnapshots :: DB ()
cleanupNonPlayerSnapshots =
do has_snapshot <- DB.hasSnapshot
is_relevant <- DB.peepOldestSnapshot $
do participants <- liftM (List.map genericReference . participantsOf) playerState
m_plane_ref <- getCurrentPlane
case m_plane_ref of
_ | List.null participants -> return False
Nothing -> return True
Just plane_ref ->
liftM (not . List.null) $ dbGetVisibleObjectsForFaction
(return . (`elem` participants))
Player
plane_ref
when (has_snapshot && not is_relevant) $
do DB.popOldestSnapshot
cleanupNonPlayerSnapshots
getPlayerState :: Game -> IO (Either DBError PlayerState)
getPlayerState g = peek g playerState
......@@ -206,7 +231,7 @@ putMessage :: Game -> T.Text -> IO ()
putMessage g t = atomically $
do ts <- readTVar $ game_message_text g
writeTVar (game_message_text g) $ Prelude.take max_messages $ t:ts
getMessages :: Game -> IO [T.Text]
getMessages g = readTVarIO (game_message_text g)
......
......@@ -22,7 +22,7 @@ import Data.Maybe
import Roguestar.Lib.Behavior
import qualified Roguestar.Lib.Perception as P
import Roguestar.Lib.Position
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Roguestar.Lib.Logging
import Roguestar.Lib.DetailedLocation
import Control.Monad.Random
......@@ -105,8 +105,8 @@ dbPerform1CreatureAITurn creature_ref =
do logDB log_turns INFO $ "dbPerform1CreatureAITurn; Performing a creature's AI turn: id=" ++ show (toUID creature_ref)
liftM (const ()) $ atomic (flip dbBehave creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $
do let isPlayer :: forall db. (DBReadable db) => Reference () -> P.DBPerception db Bool
isPlayer ref | (Just creature_ref) <- coerceReference ref =
do f <- P.getCreatureFaction creature_ref
isPlayer ref | (Just might_be_the_player_creature_ref) <- coerceReference ref =
do f <- P.getCreatureFaction might_be_the_player_creature_ref
return $ f == Player
isPlayer _ | otherwise = return False
(visible_player_locations :: [Position]) <- lift $ liftM (map P.visible_object_position) $ P.visibleObjects isPlayer
......
......@@ -9,7 +9,7 @@ import Data.Maybe
import Control.Concurrent
import System.IO
import Roguestar.Lib.DB
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Control.Monad.Reader.Class
import Roguestar.Lib.Core.Plane
import Roguestar.Lib.TerrainData
......
......@@ -31,7 +31,7 @@ import Data.Ord
import qualified Data.List as List
import qualified Data.Map as Map
import Roguestar.Lib.Roguestar
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Data.PlayerState
import Roguestar.Lib.DBErrorFlag
import Roguestar.Lib.Perception
import Roguestar.Lib.SpeciesData
......
......@@ -106,6 +106,7 @@ library
Roguestar.Lib.CharacterAdvancement,
Roguestar.Lib.PersistantData,
Roguestar.Lib.PowerUpData,
Roguestar.Lib.Data.PlayerState,
Roguestar.Lib.HTML.Mustache
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
......
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