summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopherLaneHinson <>2010-06-18 01:41:44 (GMT)
committerLuite Stegeman <luite@luite.com>2010-06-18 01:41:44 (GMT)
commit0e3a1c3fd4160501d5c937df8c0fb38324296799 (patch)
tree09bd3eb7df959d544e0e7001ed758a16108da862
parentb67cdc0fd964a43ae48d49b113cecb509445e5cd (diff)
version 0.4.0.10.4.0.1
-rw-r--r--roguestar-engine.cabal5
-rw-r--r--src/Activate.hs47
-rw-r--r--src/Construction.hs34
-rw-r--r--src/Contact.hs56
-rw-r--r--src/DBErrorFlag.hs19
-rw-r--r--src/DeviceActivation.hs37
-rw-r--r--src/Make.hs26
-rw-r--r--src/MakeData.hs79
-rw-r--r--src/Planet.hs43
-rw-r--r--src/PlanetData.hs75
-rw-r--r--src/PlayerState.hs108
-rw-r--r--src/Random.hs93
-rw-r--r--src/WorkCluster.hs92
13 files changed, 713 insertions, 1 deletions
diff --git a/roguestar-engine.cabal b/roguestar-engine.cabal
index 0bebdf5..6f076e1 100644
--- a/roguestar-engine.cabal
+++ b/roguestar-engine.cabal
@@ -1,5 +1,5 @@
name: roguestar-engine
-version: 0.4.0.0
+version: 0.4.0.1
license: OtherLicense
license-file: LICENSE
author: Christopher Lane Hinson
@@ -45,6 +45,9 @@ other-modules: VisibilityData, Stats, FactionData, Behavior, Alignment,
Tests, DBData, GridRayCaster, BeginGame,
SpeciesData, TimeCoordinate, DB, AttributeGeneration,
CreatureAttribute, Building, BuildingData, Town
+ Random, PlayerState, MakeData, DBErrorFlag, Construction,
+ Make, Activate, Contact, DeviceActivation, WorkCluster,
+ Planet, PlanetData
ghc-options: -Wall -threaded -fno-warn-type-defaults
ghc-prof-options: -prof -auto-all
diff --git a/src/Activate.hs b/src/Activate.hs
new file mode 100644
index 0000000..447d8c2
--- /dev/null
+++ b/src/Activate.hs
@@ -0,0 +1,47 @@
+module Activate
+ (ActivationOutcome,
+ resolveActivation,
+ executeActivation)
+ where
+
+import Tool
+import ToolData
+import Creature
+import DB
+import Control.Monad.Error
+import Substances
+
+-- | Outcome of activating a tool.
+data ActivationOutcome =
+ Heal CreatureRef Integer
+ | ExpendTool ToolRef ActivationOutcome
+ | NoEffect
+
+resolveActivation :: (DBReadable db) => CreatureRef -> db ActivationOutcome
+resolveActivation creature_ref =
+ do tool_ref <- maybe (throwError $ DBErrorFlag NoToolWielded) return =<< dbGetWielded creature_ref
+ tool <- dbGetTool tool_ref
+ case tool of
+ DeviceTool {} -> throwError $ DBErrorFlag ToolIs_Innapropriate
+ Sphere (ChromaliteSubstance c) ->
+ do x <- linearRoll $ chromalitePotency c
+ return $ if x == 0 then ExpendTool tool_ref $ NoEffect
+ else Heal creature_ref x
+ Sphere (MaterialSubstance m) ->
+ do x <- linearRoll $ material_construction_value $ materialValue m
+ return $ ExpendTool tool_ref $ Heal creature_ref x
+ Sphere (GasSubstance g) ->
+ do x <- linearRoll $ gasValue g
+ return $ if x == 0 then ExpendTool tool_ref $ Heal creature_ref 1
+ else Heal creature_ref 1
+
+executeActivation :: ActivationOutcome -> DB ()
+executeActivation (NoEffect) = return ()
+executeActivation (Heal creature_ref x) =
+ do healCreature x creature_ref
+ dbPushSnapshot $ HealEvent creature_ref
+executeActivation (ExpendTool tool_ref activation_outcome) =
+ do executeActivation activation_outcome
+ dbPushSnapshot $ ExpendToolEvent tool_ref
+ deleteTool tool_ref
+
diff --git a/src/Construction.hs b/src/Construction.hs
new file mode 100644
index 0000000..ee76e6c
--- /dev/null
+++ b/src/Construction.hs
@@ -0,0 +1,34 @@
+-- | All construction (terrain clearing, etc) actions that a creature might take.
+module Construction
+ (modifyFacingTerrain,
+ clearTerrain)
+ where
+
+import DB
+import Plane
+import TerrainData
+import Facing
+import Control.Monad
+import Control.Monad.Maybe
+import Control.Monad.Trans
+import Position
+import Data.Maybe
+
+-- | Modifies terrain in the specified walking direction, returning
+-- True iff any terrain modification actually occured.
+modifyFacingTerrain :: (TerrainPatch -> TerrainPatch) -> Facing -> CreatureRef -> DB Bool
+modifyFacingTerrain f face creature_ref = liftM (fromMaybe False) $ runMaybeT $
+ do (plane_ref,position) <- MaybeT $ liftM extractLocation $ dbWhere creature_ref
+ let target_position = offsetPosition (facingToRelative face) position
+ prev_terrain <- lift $ terrainAt plane_ref target_position
+ let new_terrain = f prev_terrain
+ when (new_terrain == prev_terrain) $ fail ""
+ lift $ setTerrainAt plane_ref target_position new_terrain
+ return True
+
+clearTerrain :: TerrainPatch -> TerrainPatch
+clearTerrain RockFace = Rubble
+clearTerrain Forest = Grass
+clearTerrain DeepForest = Grass
+clearTerrain Lava = Glass
+clearTerrain x = x
diff --git a/src/Contact.hs b/src/Contact.hs
new file mode 100644
index 0000000..c5eac40
--- /dev/null
+++ b/src/Contact.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+
+module Contact
+ (findContacts,
+ ContactMode(..),
+ ContactModeType(..))
+ where
+
+import Position
+import Facing
+import DB
+import CreatureData
+import Control.Monad
+import Plane
+import Data.Ord
+import Data.List as List
+import Data.Maybe
+
+-- | 'Touch' contacts are on the same or facing square as the subject.
+-- 'Line' contacts are on any point starting on the same square and anywhere directly along a line traced in the
+-- facing direction, out to infinity. 'Area' contacts lie inside a circle of radius 7, centered 7 squares in the
+-- facing direction. Use 'Area' 'Here' for a circle centerd on the subject.
+data ContactMode = Touch | Line | Area
+
+class ContactModeType a where
+ contactMode :: a -> ContactMode
+
+instance ContactModeType ContactMode where
+ contactMode = id
+
+instance ContactModeType CreatureInteractionMode where
+ contactMode Unarmed = Touch
+ contactMode Melee = Touch
+ contactMode Ranged = Line
+ contactMode Splash = Area
+
+-- | Find contacts to a reference. The result is sorted by from closest to farthest from the subject, except in the case
+-- of area contacts, which are sorted from the center of the area. The subject is never a contact of itself.
+findContacts :: (DBReadable db,ReferenceType x,GenericReference a S,ContactModeType c) => c -> Reference x -> Facing -> db [a]
+findContacts contact_mode attacker_ref face =
+ do (m_l :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap location) $ getPlanarPosition attacker_ref
+ let testF pos (x :: MultiPosition) = case contactMode contact_mode of
+ Touch -> min (x `distanceBetweenChessboard` (offsetPosition (facingToRelative face) pos))
+ (x `distanceBetweenChessboard` pos) == 0
+ Line -> isFacing (pos,face) x
+ Area -> distanceBetweenSquared (offsetPosition (facingToRelative7 face) pos) x < 49
+ center_pos pos = case contactMode contact_mode of
+ Area -> offsetPosition (facingToRelative7 face) pos
+ _ -> pos
+ flip (maybe $ return []) m_l $ \(plane_ref,pos) ->
+ liftM (mapMaybe fromLocation .
+ sortBy (comparing (distanceBetweenSquared (center_pos pos) . location)) .
+ filter ((/= generalizeReference attacker_ref) . entity) .
+ filter (testF pos . location)) $
+ dbGetContents plane_ref
+
diff --git a/src/DBErrorFlag.hs b/src/DBErrorFlag.hs
new file mode 100644
index 0000000..726ab83
--- /dev/null
+++ b/src/DBErrorFlag.hs
@@ -0,0 +1,19 @@
+module DBErrorFlag
+ (ErrorFlag(..))
+ where
+
+data ErrorFlag =
+ BuildingApproachWrongAngle -- some buildings (like stargates) are sensitive to the angle of approach
+ | NothingAtFeet -- tried to pick something up, but there is nothing at your feet
+ | NothingInInventory -- tried to perform an inventory action, but your inventory is empty
+ | NotStanding -- the player is not standing on anything (e.g. race selection state)
+ | NoStargateAddress -- tried to move through the stargate network, but there was no destination
+ | NoToolWielded -- tried to perform an action that requires a wielded tool
+ | ToolIs_NotAtFeet -- tried to pick something up, but it isn't at your feet
+ | ToolIs_NotInInventory -- tried to perform an inventory action on a tool that isn't in inventory
+ | ToolIs_NotWieldable -- tried to wield a tool that can't be wielded. As of March 2010, there are no such tools, so this is a bug.
+ | ToolIs_Unreachable -- tried to perform an action with a tool that isn't in reach (not in inventory, wielded, or at feet)
+ | ToolIs_Innapropriate -- tried to perform an action with a tool that can be used for that purpose
+ | Unable -- you can't do it
+ deriving (Eq,Ord,Read,Show)
+
diff --git a/src/DeviceActivation.hs b/src/DeviceActivation.hs
new file mode 100644
index 0000000..0f790e0
--- /dev/null
+++ b/src/DeviceActivation.hs
@@ -0,0 +1,37 @@
+module DeviceActivation
+ (DeviceActivationOutcomeType(..),
+ DeviceActivationOutcome(..),
+ resolveDeviceActivation)
+ where
+
+import DB
+import Creature
+import CreatureData
+import ToolData
+import Data.Ratio
+
+data DeviceActivationOutcomeType =
+ DeviceActivated
+ | DeviceFailed
+ | DeviceCriticalFailed
+
+data DeviceActivationOutcome = DeviceActivationOutcome {
+ dao_outcome_type :: DeviceActivationOutcomeType,
+ dao_skill_roll :: Integer,
+ dao_energy :: Integer,
+ dao_activation_time :: Rational }
+
+-- | Given a device, and a primary and secondary roll, determine the outcome of activating the device.
+-- The better the primary roll, the less likely that the device will fail, while the better the secondary
+-- roll, the more energy the device will output.
+resolveDeviceActivation :: (DBReadable db,DeviceType d) => CreatureAbility -> CreatureAbility -> CreatureAbility -> d -> CreatureRef -> db DeviceActivationOutcome
+resolveDeviceActivation primary_ability secondary_ability timing_ability device creature_ref =
+ do primary_roll <- rollCreatureAbilityScore primary_ability (deviceAccuracy device) creature_ref
+ secondary_roll <- rollCreatureAbilityScore secondary_ability (deviceOutput device) creature_ref
+ timing_roll <- rollCreatureAbilityScore timing_ability (deviceSpeed device) creature_ref
+ let timing = roll_ideal secondary_roll % (roll_ideal timing_roll + roll_ideal secondary_roll)
+ daoF = case () of
+ () | roll_actual primary_roll == 0 -> DeviceActivationOutcome DeviceCriticalFailed 0 (deviceOutput device * deviceSize device)
+ () | roll_actual primary_roll <= deviceSize device -> DeviceActivationOutcome DeviceFailed (roll_actual primary_roll) (deviceOutput device)
+ () | otherwise -> DeviceActivationOutcome DeviceActivated (roll_actual primary_roll * deviceSize device) (roll_actual secondary_roll)
+ return $ daoF timing
diff --git a/src/Make.hs b/src/Make.hs
new file mode 100644
index 0000000..11b8dbf
--- /dev/null
+++ b/src/Make.hs
@@ -0,0 +1,26 @@
+module Make
+ (module MakeData,
+ MakeOutcome,
+ resolveMake,
+ executeMake)
+ where
+
+import MakeData
+import DB
+import Tool
+import ToolData
+import Data.List
+
+data MakeOutcome = MakeSuccess CreatureRef Tool [ToolRef] | MakeFailed
+
+resolveMake :: (DBReadable db) => CreatureRef -> PrepareMake -> db MakeOutcome
+resolveMake c (PrepareMake (Just dk) (Just (ch,ch_tool_ref)) (Just (m,m_tool_ref)) (Just (g,g_tool_ref))) =
+ return $ MakeSuccess c (improvised dk ch m g) [ch_tool_ref,m_tool_ref,g_tool_ref]
+resolveMake _ _ = return MakeFailed
+
+executeMake :: MakeOutcome -> DB ()
+executeMake (MakeSuccess c t refs) =
+ do mapM_ deleteTool $ nub refs
+ _ <- dbAddTool t (Wielded c)
+ return ()
+executeMake MakeFailed = return ()
diff --git a/src/MakeData.hs b/src/MakeData.hs
new file mode 100644
index 0000000..c6a3846
--- /dev/null
+++ b/src/MakeData.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE FlexibleInstances #-}
+module MakeData
+ (PrepareMake(..),
+ prepare_make,
+ isFinished,
+ needsKind,
+ needsChromalite,
+ needsMaterial,
+ needsGas,
+ hasChromalite,
+ hasMaterial,
+ hasGas,
+ MakeWith(..))
+ where
+
+import DBData
+import ToolData
+import Substances
+
+-- | Multi-step process for gathering the materials to make something.
+data PrepareMake = PrepareMake {
+ m_device_kind :: (Maybe DeviceKind),
+ m_chromalite :: (Maybe (Chromalite,ToolRef)),
+ m_material :: (Maybe (Material,ToolRef)),
+ m_gas :: (Maybe (Gas,ToolRef)) } deriving (Read,Show)
+
+-- | An empty prepare_make.
+prepare_make :: PrepareMake
+prepare_make = PrepareMake Nothing Nothing Nothing Nothing
+
+isFinished :: PrepareMake -> Bool
+isFinished (PrepareMake (Just _) (Just _) (Just _) (Just _)) = True
+isFinished _ = False
+
+needsKind :: PrepareMake -> Bool
+needsKind (PrepareMake Nothing _ _ _) = True
+needsKind _ = False
+
+needsChromalite :: PrepareMake -> Bool
+needsChromalite (PrepareMake _ Nothing _ _) = True
+needsChromalite _ = False
+
+needsMaterial :: PrepareMake -> Bool
+needsMaterial (PrepareMake _ _ Nothing _) = True
+needsMaterial _ = False
+
+needsGas :: PrepareMake -> Bool
+needsGas (PrepareMake _ _ _ Nothing) = True
+needsGas _ = False
+
+hasChromalite :: Tool -> Maybe Chromalite
+hasChromalite (DeviceTool _ d) = Just $ deviceChromalite d
+hasChromalite (Sphere (ChromaliteSubstance s)) = Just s
+hasChromalite _ = Nothing
+
+hasMaterial :: Tool -> Maybe Material
+hasMaterial (DeviceTool _ d) = Just $ deviceMaterial d
+hasMaterial (Sphere (MaterialSubstance s)) = Just s
+hasMaterial _ = Nothing
+
+hasGas :: Tool -> Maybe Gas
+hasGas (DeviceTool _ d) = Just $ deviceGas d
+hasGas (Sphere (GasSubstance s)) = Just s
+hasGas _ = Nothing
+
+class MakeWith a where
+ makeWith :: PrepareMake -> a -> PrepareMake
+
+instance MakeWith DeviceKind where
+ makeWith make_prep x = make_prep { m_device_kind = Just x }
+
+instance (SubstanceType s) => MakeWith (s,ToolRef) where
+ makeWith make_prep (x,tool_ref) = makeWithSubstance make_prep (toSubstance x,tool_ref)
+
+makeWithSubstance :: PrepareMake -> (Substance,ToolRef) -> PrepareMake
+makeWithSubstance make_prep (ChromaliteSubstance s,tool_ref) = make_prep { m_chromalite = Just (s,tool_ref) }
+makeWithSubstance make_prep (MaterialSubstance s,tool_ref) = make_prep { m_material = Just (s,tool_ref) }
+makeWithSubstance make_prep (GasSubstance s,tool_ref) = make_prep { m_gas = Just (s,tool_ref) }
+
diff --git a/src/Planet.hs b/src/Planet.hs
new file mode 100644
index 0000000..e518a03
--- /dev/null
+++ b/src/Planet.hs
@@ -0,0 +1,43 @@
+module Planet
+ (makePlanets,
+ generatePlanetInfo)
+ where
+
+import PlanetData
+import DB
+import Plane
+import TerrainData
+import Control.Monad
+import Data.Maybe
+import Data.Ord
+import Town
+import Data.List
+
+makePlanet :: (PlaneLocation l) => l -> PlanetInfo -> DB PlaneRef
+makePlanet plane_location planet_info =
+ do seed <- getRandom
+ plane_ref <- dbNewPlane
+ (planet_info_name planet_info)
+ (TerrainGenerationData {
+ tg_smootheness = 3,
+ tg_biome = planet_info_biome planet_info,
+ tg_placements = [recreantFactories seed] })
+ plane_location
+ town <- liftM catMaybes $ forM (planet_info_town planet_info) $ \(r,b) ->
+ do p <- rationalRoll r
+ return $ if p then Just b else Nothing
+ _ <- createTown plane_ref town
+ return plane_ref
+
+makePlanets :: (PlaneLocation l) => l -> [PlanetInfo] -> DB PlaneRef
+makePlanets _ [] = return $ error "makePlanetarySystem: empty list"
+makePlanets l (planet_info:rest) =
+ do plane_ref <- makePlanet l planet_info
+ _ <- makePlanets (Subsequent plane_ref) rest
+ return plane_ref
+
+generatePlanetInfo :: (DBReadable db) => [PlanetInfo] -> db [PlanetInfo]
+generatePlanetInfo planet_infos = liftM (sortBy (comparing planet_info_priority)) $ forM planet_infos $ \planet_info ->
+ do prio_bonus <- getRandomR (0.0,1.0) -- see documentation for 'PlanetData.PlanetInfo'
+ return $ planet_info `addPriority` prio_bonus
+
diff --git a/src/PlanetData.hs b/src/PlanetData.hs
new file mode 100644
index 0000000..f4df3e1
--- /dev/null
+++ b/src/PlanetData.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+module PlanetData
+ (PlanetInfo(..),
+ addTown,
+ addPriority,
+ all_planets,
+ pgto_planets)
+ where
+
+import TerrainData
+import BuildingData
+import Data.Ratio
+import qualified Data.ByteString.Char8 as B
+
+-- | Information used to construct new planets.
+-- Whenever the player goes through a stargate to a new planet,
+-- we pull a new 'PlanetInfo' record off of a stack and a construct
+-- a planet based on that information.
+--
+-- 'PlanetInfo's are sorted by their 'planet_info_priority' fields.
+--
+data PlanetInfo = PlanetInfo {
+ -- | Between 0 and 1 are randomly added to this value, and then all 'PlanetInfo's are sorted by priority.
+ -- This gives the order in which players visit planets.
+ planet_info_priority :: Double,
+ -- | Some planets have names.
+ planet_info_name :: Maybe B.ByteString,
+ planet_info_biome :: Biome,
+ planet_info_town :: [(Rational,BuildingType)] }
+ deriving (Read,Show)
+
+pgto :: B.ByteString -> Biome -> PlanetInfo
+pgto "" biome = PlanetInfo {
+ planet_info_priority = 0.25,
+ planet_info_name = Nothing,
+ planet_info_biome = biome,
+ planet_info_town = [(1,Portal),(1%2,Monolith),(1%2,Monolith)] }
+pgto name biome = PlanetInfo {
+ planet_info_priority = 0.0,
+ planet_info_name = Just name,
+ planet_info_biome = biome,
+ planet_info_town = [(1,Portal)] }
+
+addTown :: PlanetInfo -> [(Rational,BuildingType)] -> PlanetInfo
+addTown planet_info town = planet_info { planet_info_town = planet_info_town planet_info ++ town }
+
+addPriority :: PlanetInfo -> Double -> PlanetInfo
+addPriority planet_info prio = planet_info { planet_info_priority = planet_info_priority planet_info + prio }
+
+all_planets :: [PlanetInfo]
+all_planets = concat [pgto_planets]
+
+pgto_planets :: [PlanetInfo]
+pgto_planets = [
+ pgto "" RockBiome,
+ pgto "" IcyRockBiome,
+ pgto "" TundraBiome,
+ pgto "" DesertBiome,
+ pgto "" MountainBiome,
+ pgto "roanoke" SwampBiome,
+ pgto "pamlico" SwampBiome,
+ pgto "pungo" ForestBiome,
+ pgto "neuse" ForestBiome,
+ pgto "crabtree" SwampBiome,
+ pgto "eno" SwampBiome `addTown` [(1%20,Monolith)],
+ pgto "yadkin" SwampBiome,
+ pgto "catawba" ForestBiome,
+ pgto "pasquotank" ForestBiome,
+ pgto "dogwood" GrasslandBiome `addPriority` 0.75,
+ pgto "emerald" GrasslandBiome `addPriority` 0.75,
+ pgto "cardinal" GrasslandBiome `addPriority` 0.75,
+ pgto "currituck" OceanBiome `addPriority` 1.5,
+ pgto "hatteras" OceanBiome `addPriority` 1.5,
+ pgto "lookout" OceanBiome `addPriority` 1.5,
+ pgto "ocracoke" OceanBiome `addPriority` 1.5]
diff --git a/src/PlayerState.hs b/src/PlayerState.hs
new file mode 100644
index 0000000..3678113
--- /dev/null
+++ b/src/PlayerState.hs
@@ -0,0 +1,108 @@
+module PlayerState
+ (PlayerState(..),
+ CreatureTurnMode(..),
+ SnapshotEvent(..),
+ creatureOf,
+ subjectOf,
+ menuIndex,
+ modifyMenuIndex)
+ where
+
+import DBData
+import CreatureData
+import MakeData
+
+data PlayerState =
+ RaceSelectionState
+ | ClassSelectionState Creature
+ | PlayerCreatureTurn CreatureRef CreatureTurnMode
+ | SnapshotEvent SnapshotEvent
+ | GameOver
+ deriving (Read,Show)
+
+data CreatureTurnMode =
+ NormalMode
+ | MoveMode
+ | PickupMode Integer
+ | DropMode Integer
+ | WieldMode Integer
+ | MakeMode Integer PrepareMake
+ | AttackMode
+ | FireMode
+ | JumpMode
+ | TurnMode
+ | ClearTerrainMode
+ deriving (Read,Show)
+
+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 }
+ | HealEvent {
+ heal_event_creature :: CreatureRef }
+ | ExpendToolEvent {
+ expend_tool_event_tool :: ToolRef }
+ deriving (Read,Show)
+
+-- | Get the 'Creature' acting in the given 'PlayerState'.
+creatureOf :: PlayerState -> Maybe CreatureRef
+creatureOf state = case state of
+ PlayerCreatureTurn creature_ref _ -> Just creature_ref
+ SnapshotEvent event -> subjectOf event
+ GameOver -> Nothing
+ ClassSelectionState {} -> Nothing
+ RaceSelectionState {} -> Nothing
+
+-- | Get the subject creature of a 'SnapshotEvent', that is, the creature taking action.
+subjectOf :: SnapshotEvent -> Maybe CreatureRef
+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
+ HealEvent { heal_event_creature = creature_ref } -> Just creature_ref
+ ExpendToolEvent {} -> Nothing
+
+-- | Current index into the menu, if there is one.
+menuIndex :: PlayerState -> Maybe Integer
+menuIndex state = fst $ modifyMenuIndex_ id state
+
+-- | Modify the current index into the menu, if there is one (otherwise has no effect).
+modifyMenuIndex :: (Integer -> Integer) -> PlayerState -> PlayerState
+modifyMenuIndex f state = snd $ modifyMenuIndex_ f state
+
+modifyMenuIndex_ :: (Integer -> Integer) -> PlayerState -> (Maybe Integer,PlayerState)
+modifyMenuIndex_ f state = case state of
+ PlayerCreatureTurn c (PickupMode n) -> (Just n,PlayerCreatureTurn c $ PickupMode $ f n)
+ PlayerCreatureTurn c (DropMode n) -> (Just n,PlayerCreatureTurn c $ DropMode $ f n)
+ PlayerCreatureTurn c (WieldMode n) -> (Just n,PlayerCreatureTurn c $ WieldMode $ f n)
+ PlayerCreatureTurn c (MakeMode n make_prep) -> (Just n,PlayerCreatureTurn c $ MakeMode (f n) make_prep)
+ x -> (Nothing,x)
+
diff --git a/src/Random.hs b/src/Random.hs
new file mode 100644
index 0000000..45aae9c
--- /dev/null
+++ b/src/Random.hs
@@ -0,0 +1,93 @@
+
+module Random
+ (pick,
+ pickM,
+ weightedPick,
+ weightedPickM,
+ linearRoll,
+ fixedSumRoll,
+ fixedSumLinearRoll,
+ logRoll,
+ opposedLinearPowerRatio,
+ rationalRoll)
+ where
+
+import Data.List
+import Data.Maybe
+import System.Random ()
+import Control.Monad.Random
+import Control.Monad
+import Data.Ratio
+
+-- | Pick an element of a list at random.
+pick :: (RandomGen g) => [a] -> g -> (a,g)
+pick elems = runRand (pickM elems)
+
+-- | Pick an element of a weighted list at random. E.g. in "[(2,x),(3,y)]" "y" will be picked three times out of five while "x" will be picked 2 times out of five.
+weightedPick :: (RandomGen g) => [(Integer,a)] -> g -> (a,g)
+weightedPick elems = runRand (weightedPickM elems)
+
+-- | 'pick' in MinadRandom
+pickM :: (MonadRandom m) => [a] -> m a
+pickM elems = weightedPickM (map (\x -> (1,x)) elems)
+
+-- | 'weightedPick' in MonadRandom
+weightedPickM :: (MonadRandom m) => [(Integer,a)] -> m a
+weightedPickM [] = error "Tried to pick from an empty list."
+weightedPickM elems =
+ do let (weights,values) = unzip elems
+ let (weight_total,weight_totals) = mapAccumL (\x y -> (x+y,x+y)) 0 weights
+ weight_to_find <- getRandomR (1,weight_total)
+ let index = fromJust $ findIndex (\x -> x >= weight_to_find) weight_totals
+ return $ values !! index
+
+-- | Roll an (n+1) sided die numbered zero to n.
+linearRoll :: (MonadRandom m) => Integer -> m Integer
+linearRoll n = getRandomR (0,n)
+
+-- | fixedSumRoll using 'linearRoll', with optimizations.
+-- REVISIT: this can be improved significantly, but performance doesn't seem to be a material problem so far.
+fixedSumLinearRoll :: (MonadRandom m) => [Integer] -> Integer -> m [Integer]
+fixedSumLinearRoll xs a = fixedSumRoll (map (linearRoll . min a) xs) a
+
+-- | Roll a sequence of random variables, such that the sum of the result is a fixed value.
+fixedSumRoll :: (MonadRandom m) => [m Integer] -> Integer -> m [Integer]
+fixedSumRoll rs a =
+ do xs <- sequence rs
+ case sum xs == a of
+ True -> return xs
+ False -> fixedSumRoll rs a
+
+-- | Roll a die where the typical outcome is the base-2 logarithm of the input.
+-- This function has exactly the same probability of rolling exactly 0 as 'linearDiceRoll'.
+--
+logRoll :: (MonadRandom m) => Integer -> m Integer
+logRoll n = liftM (min n) $ accumRoll 0 n
+ where accumRoll c x =
+ do x' <- linearRoll x
+ case x' of
+ 0 -> return c
+ _ -> accumRoll (c+1) x'
+
+-- | Roll on a rational number that is a probability between zero and one, to generate a boolean.
+rationalRoll :: (MonadRandom m) => Rational -> m Bool
+rationalRoll r =
+ do p <- linearRoll (denominator r - 1)
+ return $ p < numerator r
+
+-- | 'opposedLinearPowerRatio' is used when a constant (non-random) power relationship needs to be
+-- determined between two parties. (For example, this is used in the Spot/Hide contest when determining
+-- line of sight.)
+--
+-- It accepts negative values for either parameter, and is invertable, i.e.,
+-- @opposedLinearPowerRatio a b@ = @1 - opposedLinearPowerRatio b a@
+--
+-- One use is: @2 * (a%1) * opposedLinearPowerRatio a b@, whichs gives you roughly @a@ if @a@ and @b@ are equal,
+-- or less or more than @a@ otherwise.
+opposedLinearPowerRatio :: Integer -> Integer -> Rational
+opposedLinearPowerRatio a b | a < 1 = opposedLinearPowerRatio 1 (b-a+1)
+opposedLinearPowerRatio a b | b < 1 = opposedLinearPowerRatio (a-b+1) 1
+opposedLinearPowerRatio a b | a >= b = ((a-b) % a) + (b % a)/2
+opposedLinearPowerRatio a b | otherwise = 1 - opposedLinearPowerRatio b a
+
+
diff --git a/src/WorkCluster.hs b/src/WorkCluster.hs
new file mode 100644
index 0000000..01cc31f
--- /dev/null
+++ b/src/WorkCluster.hs
@@ -0,0 +1,92 @@
+module WorkCluster
+ (WorkCluster,
+ WorkRequestType(..),
+ WorkRequest,
+ WorkResult,
+ newWorkCluster,
+ workRequest,
+ replaceWorkOperation)
+ where
+
+import PrioritySync.PrioritySync
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.Applicative
+import Data.IORef
+import qualified Data.ByteString as B
+import qualified Data.PSQueue as PSQ
+import qualified Data.Map as Map
+import DB
+
+-- | Measure the number of 'Query's between 'Action's, and add this number to get the maximum size of the most-recent-request queue.
+queue_size_bonus :: Int
+queue_size_bonus = 10
+
+data WorkRequestType = Query | Action deriving (Eq,Ord,Show)
+type WorkRequest = (WorkRequestType,[B.ByteString])
+type WorkResult = Either DBError (B.ByteString,DB_BaseType)
+
+data WorkPrio = Now | Eventually deriving (Eq,Ord)
+
+data WorkClusterData = WorkClusterData {
+ wc_queue_max_size :: IORef Int, -- how large the most-recent-requests queue should be allowed to grow
+ wc_recent_request_count :: IORef Int, -- number of manual requests since the last 'replaceWorkOperation'
+ wc_abort_counter :: IORef Integer, -- increments on every 'replaceWorkOperation'
+ wc_request_counter :: IORef Integer, -- increments on every manual request
+ wc_recent_requests :: IORef (PSQ.PSQ WorkRequest Integer),
+ wc_task_pool :: IORef (TaskPool WorkPrio ()),
+ wc_request_operation :: IORef (WorkRequest -> IO WorkResult),
+ wc_task_handles :: IORef (Map.Map WorkRequest (TaskHandle WorkPrio WorkResult)) }
+
+data WorkCluster = WorkCluster (MVar WorkClusterData)
+
+newWorkCluster :: IO WorkCluster
+newWorkCluster = liftM WorkCluster . newMVar =<< (WorkClusterData <$>
+ newIORef 0 <*> newIORef 0 <*> newIORef 0 <*> newIORef 0 <*> newIORef PSQ.empty <*> (newIORef =<< simpleTaskPool) <*>
+ newIORef (error "newWorkCluster: please call 'replaceWorkOperation' at least once") <*>
+ newIORef Map.empty)
+
+startWork :: WorkCluster -> WorkRequest -> WorkPrio -> IO (TaskHandle WorkPrio WorkResult)
+startWork (WorkCluster wc_data_var) work_request prio = liftM snd $ withMVar wc_data_var $ \wc_data ->
+ do when (prio == Now) $
+ do modifyIORef (wc_recent_request_count wc_data) succ
+ modifyIORef (wc_request_counter wc_data) succ
+ c <- readIORef $ wc_request_counter wc_data
+ modifyIORef (wc_recent_requests wc_data) $ PSQ.insertWith max work_request c
+ queue_max_size <- readIORef $ wc_queue_max_size wc_data
+ modifyIORef (wc_recent_requests wc_data) $ \psq -> if PSQ.size psq >= queue_max_size then PSQ.deleteMin psq else psq
+ handles <- readIORef (wc_task_handles wc_data)
+ case (Map.lookup work_request handles) of
+ Just handle ->
+ do reprioritize handle $ min prio
+ return (wc_data, handle)
+ Nothing ->
+ do pool <- readIORef $ wc_task_pool wc_data
+ op <- readIORef $ wc_request_operation wc_data
+ result <- dispatch (schedule pool prio) $ op work_request
+ modifyIORef (wc_task_handles wc_data) $ Map.insert work_request result
+ return (wc_data, result)
+
+workRequest :: WorkCluster -> WorkRequest -> IO WorkResult
+workRequest work_cluster work_request = getResult =<< startWork work_cluster work_request Now
+
+replaceWorkOperation :: WorkCluster -> (WorkRequest -> IO WorkResult) -> IO ()
+replaceWorkOperation (WorkCluster wc_data_var) op =
+ do recent_requests <- liftM snd $ withMVar wc_data_var $ \wc_data ->
+ do pool <- readIORef $ wc_task_pool wc_data
+ startQueue pool
+ modifyIORef (wc_task_handles wc_data) $ const Map.empty
+ modifyIORef (wc_abort_counter wc_data) succ
+ id $ do queue_max_size <- readIORef $ wc_queue_max_size wc_data -- grow/shrink the most-recently-used request queue according to actual usage
+ recent_request_count <- readIORef $ wc_recent_request_count wc_data
+ writeIORef (wc_recent_request_count wc_data) 0
+ writeIORef (wc_queue_max_size wc_data) $ max (queue_max_size - 1 :: Int) ((recent_request_count :: Int) + queue_size_bonus)
+ key_abort_index <- readIORef $ wc_abort_counter wc_data
+ writeIORef (wc_request_operation wc_data) $ \wo ->
+ do current_abort_index <- readIORef $ wc_abort_counter wc_data
+ case key_abort_index == current_abort_index of
+ False -> return $ error "replaceWorkOperation: operation aborted"
+ True -> op wo
+ liftM ((,) wc_data . PSQ.keys) $ readIORef $ wc_recent_requests wc_data
+ forM_ recent_requests $ \work_request -> startWork (WorkCluster wc_data_var) work_request Eventually
+