roguestar-engine 0.4.0.0 → 0.4.0.1

raw patch · 13 files changed

+713/−1 lines, 13 files

Files

• roguestar-engine.cabal +4/−1
• src/Activate.hs +47/−0
• src/Construction.hs +34/−0
• src/Contact.hs +56/−0
• src/DBErrorFlag.hs +19/−0
• src/DeviceActivation.hs +37/−0
• src/Make.hs +26/−0
• src/MakeData.hs +79/−0
• src/Planet.hs +43/−0
• src/PlanetData.hs +75/−0
• src/PlayerState.hs +108/−0
• src/Random.hs +93/−0
• src/WorkCluster.hs +92/−0

@@ -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 @@                      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

@@ -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+                      

@@ -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

@@ -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+

@@ -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)+

@@ -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

@@ -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 ()

@@ -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) }+

@@ -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+

@@ -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]

@@ -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)+

@@ -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++

@@ -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+