diff --git a/roguestar-engine.cabal b/roguestar-engine.cabal --- 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 @@ 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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 +