roguestar-engine 0.2.2 → 0.4.0.0
raw patch · 48 files changed
+2525/−1767 lines, 48 filesdep +MonadRandomdep +PSQueuedep +bytestringdep ~MaybeTdep ~arraydep ~base
Dependencies added: MonadRandom, PSQueue, bytestring, data-memocombinators, parallel, priority-sync, stm
Dependency ranges changed: MaybeT, array, base, containers, mtl, old-time, random
Files
- roguestar-engine.cabal +25/−16
- src/Alignment.hs +2/−2
- src/Attribute.hs +0/−31
- src/AttributeData.hs +0/−34
- src/AttributeGeneration.hs +66/−0
- src/BeginGame.hs +61/−23
- src/Behavior.hs +144/−27
- src/Building.hs +78/−0
- src/BuildingData.hs +25/−0
- src/Character.hs +37/−53
- src/CharacterData.hs +2/−1
- src/Combat.hs +138/−99
- src/Creature.hs +90/−43
- src/CreatureAttribute.hs +52/−0
- src/CreatureData.hs +138/−143
- src/DB.hs +147/−95
- src/DBData.hs +67/−1
- src/DBPrivate.hs +40/−10
- src/Dice.hs +0/−10
- src/Facing.hs +5/−4
- src/FactionData.hs +19/−4
- src/GridRayCaster.hs +0/−1
- src/Grids.hs +73/−56
- src/HierarchicalDatabase.hs +11/−5
- src/HopList.hs +0/−109
- src/ListUtils.hs +0/−96
- src/Main.hs +1/−7
- src/Perception.hs +52/−16
- src/Plane.hs +100/−45
- src/PlaneData.hs +5/−1
- src/PlaneVisibility.hs +35/−29
- src/Position.hs +54/−7
- src/Protocol.hs +508/−205
- src/RNG.hs +22/−40
- src/Races.hs +0/−261
- src/RandomUtils.hs +0/−18
- src/SegHopList.hs +0/−20
- src/SegmentList.hs +0/−36
- src/Species.hs +126/−12
- src/SpeciesData.hs +33/−41
- src/Substances.hs +92/−52
- src/Terrain.hs +0/−29
- src/TerrainData.hs +21/−13
- src/Tool.hs +37/−17
- src/ToolData.hs +126/−37
- src/Town.hs +18/−0
- src/Travel.hs +50/−3
- src/Turns.hs +25/−15
roguestar-engine.cabal view
@@ -1,8 +1,8 @@ name: roguestar-engine-version: 0.2.2+version: 0.4.0.0 license: OtherLicense license-file: LICENSE-author: Christopher Lane Hinson <lane@downstairspeople.org>+author: Christopher Lane Hinson maintainer: Christopher Lane Hinson <lane@downstairspeople.org> category: Game@@ -12,30 +12,39 @@ provides the core game engine; you'll probably want to also install the OpenGL client. .- This initial release allows you to play one of six alien races. You begin- the game stranded on an alien planet, fighting off an endless hoard of- hostile robots.- . The git repository is available at <http://www.downstairspeople.org/git/roguestar-engine.git>. homepage: http://roguestar.downstairspeople.org/ -build-depends: base>3, containers, array, old-time, random, mtl, MaybeT+build-depends: base>=4 && <5,+ containers>=0.3.0.0 && < 0.3.1,+ array>=0.3.0.0 && < 0.3.1,+ old-time>=1.0.0.3 && < 1.1,+ random>=1.0.0.2 && < 1.1,+ mtl>=1.1.0.2 && < 1.2,+ MaybeT>=0.1.2 && < 0.2,+ MonadRandom>=0.1.4 && < 0.2,+ data-memocombinators>=0.4.0 && < 0.5,+ stm>=2.1.1.2 && < 2.2,+ parallel>=2.2.0.1 && < 2.3,+ bytestring>=0.9.1.5 && < 0.10,+ PSQueue>=1.1 && < 1.2,+ priority-sync>=0.2.1.0 && < 0.3 build-type: Simple-tested-with: GHC==6.8.2+tested-with: GHC==6.12.1 executable: roguestar-engine main-is: Main.hs hs-source-dirs: src other-modules: VisibilityData, Stats, FactionData, Behavior, Alignment,- PlaneData, Grids, Perception, SegHopList, PlaneVisibility,- Terrain, SegmentList, Turns, Plane, CreatureData,- AttributeData, StatsData, Protocol, Character, Tool,- ListUtils, Substances, HierarchicalDatabase, Travel, ToolData,- CharacterData, Creature, Facing, DBPrivate, Dice,+ PlaneData, Grids, Perception, PlaneVisibility,+ Turns, Plane, CreatureData,+ StatsData, Protocol, Character, Tool,+ Substances, HierarchicalDatabase, Travel, ToolData,+ CharacterData, Creature, Facing, DBPrivate, RNG, Species, Position, TerrainData, Combat,- RandomUtils, Tests, DBData, GridRayCaster, BeginGame,- SpeciesData, TimeCoordinate, Attribute, DB, HopList,- Races+ Tests, DBData, GridRayCaster, BeginGame,+ SpeciesData, TimeCoordinate, DB, AttributeGeneration,+ CreatureAttribute, Building, BuildingData, Town ghc-options: -Wall -threaded -fno-warn-type-defaults ghc-prof-options: -prof -auto-all
src/Alignment.hs view
@@ -8,8 +8,8 @@ alignmentPotency) where -data MoralAlignment = Lawful | Neutral | Chaotic | Evil deriving (Eq,Read,Show)-data EthicalAlignment = Strategic | Tactical | Diplomatic | Indifferent deriving (Eq,Read,Show)+data MoralAlignment = Lawful | Neutral | Chaotic | Evil deriving (Eq,Read,Show,Ord)+data EthicalAlignment = Strategic | Tactical | Diplomatic | Indifferent deriving (Eq,Read,Show,Ord) type Alignment = (MoralAlignment,EthicalAlignment) alignments :: [Alignment]
− src/Attribute.hs
@@ -1,31 +0,0 @@--module Attribute- (generateAttributes)- where--import AttributeData-import DB-import Dice-import Data.Maybe-import Data.Ratio---- |--- Randomly generate 1 attribute from an attribute generator.----generate1Attribute :: AttributeGenerator a -> DB (Maybe a)-generate1Attribute (AttributeAlways someAttrib) = do return (Just someAttrib)-generate1Attribute (AttributeSometimes someAttrib chance maybeNextGen) = - do good <- roll $ map (<= numerator chance) [1..denominator chance]- if good- then return (Just someAttrib)- else case maybeNextGen of- Just nextGen -> generate1Attribute nextGen- Nothing -> return Nothing---- |--- Randomly generate attributes from a list of AttributeGenerators.----generateAttributes :: [AttributeGenerator a] -> DB [a]-generateAttributes attribGens = - do maybeAttribs <- mapM generate1Attribute attribGens- return $ map fromJust $ filter isJust maybeAttribs
− src/AttributeData.hs
@@ -1,34 +0,0 @@-module AttributeData- (AttributeGenerator(..),- percentAttribute,- multipleAttribute)- where--import Data.List---- |--- Used to randomly generate attributes for an entity.--- AttributeAlways is a generator that always creates the specified attribute.--- (AttributeSometimes attrib x $ otherwise) is a generator that generates--- the the attribute "attrib" x-fraction of the time, and invokes the attribute--- generator "otherwise" otherwise.-----data AttributeGenerator a = AttributeAlways a- | AttributeSometimes a Rational (Maybe (AttributeGenerator a))- deriving (Show, Read)---- |--- Grants the entity the specified attribute x percent of the time, otherwise nothing----percentAttribute :: a -> Rational -> AttributeGenerator a-percentAttribute attr x = AttributeSometimes attr x $ Nothing---- |--- Grants the entity the specified attribute between minimum and maximum instances of the--- attribute, on average the average of the two (as a binomial distribution).----multipleAttribute :: a -> (Integer,Integer) -> [AttributeGenerator a]-multipleAttribute attr (mini,maxi) | mini >= 0 && maxi >= mini = - (genericReplicate mini $ AttributeAlways attr) ++ (genericReplicate (maxi-mini) $ percentAttribute attr 50)-multipleAttribute _ _ = error "multipleAttribute: maximum < minimum badness"
+ src/AttributeGeneration.hs view
@@ -0,0 +1,66 @@+-- | Generates random lists of specific data points "attributes" of any data type.+-- The attributes themselves aren't random, only their arrangement and frequency within the list.+--+module AttributeGeneration+ where++import Data.Ratio+import Data.List+import Control.Monad.Random+import Data.Monoid+import Control.Monad++-- | Description of the random data to be generated.+data AttributeGenerator a = + AttributeAlways {+ attribute_actual :: a,+ attribute_min_max :: (Integer,Integer) }+ | AttributeChoice {+ attribute_frequency :: Rational,+ attribute_yes :: [AttributeGenerator a],+ attribute_no :: [AttributeGenerator a] }++instance Monoid (AttributeGenerator a) where+ mempty = AttributeChoice {+ attribute_frequency = 0,+ attribute_yes = [],+ attribute_no = [] }+ mappend a b = mconcat [a,b]+ mconcat as = AttributeChoice {+ attribute_frequency = 1,+ attribute_yes = as,+ attribute_no = [] }++-- | Generate exactly n copies of an attribute.+attributeStatic :: Integer -> a -> AttributeGenerator a+attributeStatic n a =attributeMinMax (n,n) a++-- | Generates between a random number of copies of an attribute between a lower and upper bound.+attributeMinMax :: (Integer,Integer) -> a -> AttributeGenerator a+attributeMinMax min_max a = AttributeAlways {+ attribute_actual = a,+ attribute_min_max = min_max }++-- | Generates the first class of attributes some fraction of the time, and the other list the remainder of the time.+-- For example 'attributeChoice (1%3) [attributeStatic 1 True] [attributeStatic 1 False]' would generate 'True' 33% of the time.+attributeChoice :: Rational -> [AttributeGenerator a] -> [AttributeGenerator a] -> AttributeGenerator a+attributeChoice freq yes no = AttributeChoice {+ attribute_frequency = freq,+ attribute_yes = yes,+ attribute_no = no }++-- | A set of mutually-exclusive choices, with Integer probability weights.+attributeChoices :: [(Integer,[AttributeGenerator a])] -> AttributeGenerator a+attributeChoices [] = mempty+attributeChoices (x:xs) = attributeChoice (fst x % (sum $ map fst $ x:xs)) (snd x) [attributeChoices xs]++-- | Run the 'AttributeGenerator'.+generateAttributes :: (MonadRandom m) => AttributeGenerator a -> m [a]+generateAttributes (AttributeAlways { attribute_actual = a, attribute_min_max = min_max }) =+ do n <- getRandomR min_max+ return $ genericReplicate n a+generateAttributes (AttributeChoice { attribute_frequency = l, attribute_yes = yes, attribute_no = no }) =+ do n <- getRandomR (1,denominator l)+ case () of+ () | n <= numerator l -> liftM concat $ mapM generateAttributes yes+ () | otherwise -> liftM concat $ mapM generateAttributes no
src/BeginGame.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE OverloadedStrings #-} module BeginGame (dbBeginGame) where@@ -7,35 +7,67 @@ import CreatureData import Character import CharacterData+import BuildingData import DB-import DBData import Facing import TerrainData-import Data.Maybe import ToolData+import Control.Monad+import SpeciesData+import Substances+import PlayerState+import Town+import PlanetData+import Planet+import qualified Data.ByteString.Char8 as B () -player_race_to_biome :: [(String,Biome)]-player_race_to_biome =- [("anachronid",DesertBiome),- ("androsynth",RockBiome),- ("ascendant",MountainBiome),- ("canduceator",SwampBiome),- ("encephalon",GrasslandBiome{-SwampBiome-}),- ("goliath",DesertBiome),- ("hellion",GrasslandBiome),- ("kraken",OceanBiome),- ("myrmidon",DesertBiome),- ("perennial",ForestBiome),- ("recreant",DesertBiome),- ("reptilian",SwampBiome)]+homeBiome :: Species -> Biome+homeBiome Anachronid = ForestBiome+homeBiome Ascendant = MountainBiome+homeBiome Androsynth = IcyRockBiome+homeBiome Caduceator = GrasslandBiome+homeBiome Encephalon = SwampBiome+homeBiome Goliath = DesertBiome+homeBiome Hellion = SwampBiome+homeBiome Kraken = OceanBiome+homeBiome Myrmidon = DesertBiome+homeBiome Perennial = GrasslandBiome+homeBiome Recreant = TundraBiome+homeBiome Reptilian = ForestBiome +startingEquipmentByClass :: CharacterClass -> [Tool]+startingEquipmentByClass Barbarian = [kinetic_fleuret]+startingEquipmentByClass Consular = [sphere Silver]+startingEquipmentByClass Engineer = [sphere Crudnium,sphere Molybdenum,sphere Uranium]+startingEquipmentByClass ForceAdept = [kinetic_sabre]+startingEquipmentByClass Marine = [phase_pistol,phase_rifle]+startingEquipmentByClass Ninja = []+startingEquipmentByClass Pirate = [phaser]+startingEquipmentByClass Scout = [phase_pistol]+startingEquipmentByClass Shepherd = [sphere Wood]+startingEquipmentByClass Thief = [sphere Platinum]+startingEquipmentByClass Warrior = [phaser,kinetic_fleuret]++startingEquipmentBySpecies :: Species -> [Tool]+startingEquipmentBySpecies Anachronid = [sphere Radon]+startingEquipmentBySpecies Ascendant = [sphere Neon]+startingEquipmentBySpecies Androsynth = [sphere Silicon]+startingEquipmentBySpecies Caduceator = [sphere Silver]+startingEquipmentBySpecies Encephalon = [sphere Ammonia]+startingEquipmentBySpecies Goliath = [sphere Iron]+startingEquipmentBySpecies Hellion = [sphere Methane]+startingEquipmentBySpecies Kraken = [sphere Substances.Water]+startingEquipmentBySpecies Myrmidon = [sphere Krypton]+startingEquipmentBySpecies Perennial = [sphere Wood]+startingEquipmentBySpecies Recreant = [sphere Malignite]+startingEquipmentBySpecies Reptilian = [sphere Oxygen]+ dbCreateStartingPlane :: Creature -> DB PlaneRef dbCreateStartingPlane creature =- do seed <- dbNextRandomInteger- dbNewPlane $ TerrainGenerationData {+ do dbNewPlane (Just "belhaven") (TerrainGenerationData { tg_smootheness = 3,- tg_biome = fromMaybe GrasslandBiome $ lookup (creature_species_name creature) player_race_to_biome,- tg_placements = [recreantFactories seed] }+ tg_biome = homeBiome $ creature_species creature,+ tg_placements = [] }) TheUniverse -- | -- Begins the game with the specified starting player creature and the specified starting character class.@@ -47,6 +79,12 @@ plane_ref <- dbCreateStartingPlane creature landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref creature_ref <- dbAddCreature first_level_creature (Standing plane_ref landing_site Here)- phaser_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref- dbAddTool phase_pistol (Dropped plane_ref phaser_position)+ _ <- createTown plane_ref [Portal,Monolith]+ let starting_equip = startingEquipmentBySpecies (creature_species creature) ++ startingEquipmentByClass character_class+ forM_ starting_equip $ \tool -> dbAddTool tool (Inventory creature_ref)+ forM_ [0..10] $ \_ -> do tool_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref+ tool_type <- weightedPickM [(8,phase_pistol),(5,phaser),(3,phase_rifle),(8,kinetic_fleuret),(3,kinetic_sabre),+ (5,Sphere $ toSubstance Nitrogen),(5,Sphere $ toSubstance Ionidium),(5,Sphere $ toSubstance Aluminum)]+ dbAddTool tool_type (Dropped plane_ref tool_position)+ _ <- makePlanets (Subsequent plane_ref) =<< generatePlanetInfo all_planets setPlayerState $ PlayerCreatureTurn creature_ref NormalMode
src/Behavior.hs view
@@ -1,21 +1,30 @@+{-# LANGUAGE ExistentialQuantification, Rank2Types, ScopedTypeVariables #-}+ module Behavior (Behavior(..),+ facingBehavior, dbBehave) where import DB-import DBData+import Position import Facing import Data.Ratio import Tool import Control.Monad.Error import Combat+import Activate import Travel import Creature+import CreatureData import Plane import PlaneVisibility import Data.List import Control.Monad.Maybe+import TerrainData+import Make+import Construction+import Building -- -- Every possible behavior that a creature might take, AI or Human.@@ -23,6 +32,7 @@ data Behavior = Step Facing | TurnInPlace Facing+ | Jump Facing | Pickup ToolRef | Wield ToolRef | Unwield@@ -31,57 +41,164 @@ | Attack Facing | Wait | Vanish+ | Activate+ | Make PrepareMake+ | ClearTerrain Facing+ | ActivateBuilding Facing +-- | Get an appropriate behavior facing in the given direction.+-- If the adjacent facing square is empty, this is 'Step', but+-- if occupied by a creature this is 'Attack'.+facingBehavior :: (DBReadable db) => CreatureRef -> Facing -> db Behavior+facingBehavior creature_ref face =+ do (m_standing :: Maybe (PlaneRef,Position)) <- liftM (fmap location) $ getPlanarPosition creature_ref+ case m_standing of+ Nothing -> return Wait+ Just (plane_ref,pos) ->+ do let facing_pos = offsetPosition (facingToRelative face) pos+ t <- terrainAt plane_ref facing_pos+ who :: [CreatureRef] <- whatIsOccupying plane_ref facing_pos+ what :: [BuildingRef] <- whatIsOccupying plane_ref facing_pos+ case t of+ _ | not (null who) -> return $ Attack face+ _ | not (null what) -> return $ ActivateBuilding face+ Forest -> return $ TurnInPlace face+ DeepForest -> return $ TurnInPlace face+ RockFace -> return $ TurnInPlace face+ _ -> return $ Step face+ dbBehave :: Behavior -> CreatureRef -> DB () dbBehave (Step face) creature_ref =- do dbMove (stepCreature face) creature_ref- dbAdvanceTime (1%20) creature_ref+ do (move_from,move_to) <- dbMove (stepCreature face) creature_ref+ dbAdvanceTime creature_ref =<< case () of+ () | (move_from == move_to) -> return 0+ () | face == Here -> quickActionTime creature_ref -- counts as turning in place+ () | face `elem` [North,South,East,West] -> move1ActionTime creature_ref+ () | otherwise -> move2ActionTime creature_ref +dbBehave (Jump face) creature_ref =+ do atomic $ liftM executeTeleportJump $ resolveTeleportJump creature_ref face+ dbAdvanceTime creature_ref =<< fullActionTime creature_ref+ dbBehave (TurnInPlace face) creature_ref =- do dbMove (turnCreature face) creature_ref- dbAdvanceTime (1%40) creature_ref+ do _ <- dbMove (turnCreature face) creature_ref+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave (Pickup tool_ref) creature_ref =- do dbMove (dbPickupTool creature_ref) tool_ref- dbAdvanceTime (1%20) creature_ref+ do _ <- dbMove (dbPickupTool creature_ref) tool_ref+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave (Wield tool_ref) creature_ref =- do tool_parent <- liftM extractLocation $ dbWhere tool_ref- when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag "not-in-inventory"- dbMove dbWieldTool tool_ref- dbAdvanceTime (1%10) creature_ref+ do available <- availableWields creature_ref+ already_wielded <- dbGetWielded creature_ref+ when (not $ tool_ref `elem` available) $ throwError $ DBErrorFlag ToolIs_Unreachable+ _ <- dbMove dbWieldTool tool_ref+ dbAdvanceTime creature_ref =<< case () of+ () | Just tool_ref == already_wielded -> return 0 -- already wielded, so this was an empty action+ () | otherwise -> quickActionTime creature_ref dbBehave (Unwield) creature_ref = do dbUnwieldCreature creature_ref- dbAdvanceTime (1%40) creature_ref+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave (Drop tool_ref) creature_ref = do tool_parent <- liftM extractLocation $ dbWhere tool_ref- when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag "not-in-inventory"- dbMove dbDropTool tool_ref- return ()+ already_wielded <- dbGetWielded creature_ref+ when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag ToolIs_NotInInventory+ _ <- dbMove dbDropTool tool_ref+ dbAdvanceTime creature_ref =<< case () of+ () | Just tool_ref == already_wielded -> return 0 -- instantly drop a tool if it's already held in the hand+ () | otherwise -> quickActionTime creature_ref dbBehave (Fire face) creature_ref =- do dbMove (turnCreature face) creature_ref- atomic $ liftM dbExecuteRangedAttack $ dbResolveRangedAttack creature_ref face- dbAdvanceTime (1%20) creature_ref+ do _ <- dbMove (turnCreature face) creature_ref+ ranged_attack_model <- rangedAttackModel creature_ref+ atomic $ liftM executeAttack $ resolveAttack ranged_attack_model face+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref return () dbBehave (Attack face) creature_ref =- do dbMove (turnCreature face) creature_ref- atomic $ liftM dbExecuteMeleeAttack $ dbResolveMeleeAttack creature_ref face- dbAdvanceTime (1%20) creature_ref+ do _ <- dbMove (turnCreature face) creature_ref+ melee_attack_model <- meleeAttackModel creature_ref+ atomic $ liftM executeAttack $ resolveAttack melee_attack_model face+ dbAdvanceTime creature_ref =<< move1ActionTime creature_ref return () -dbBehave Wait creature_ref =- do dbAdvanceTime (1%40) creature_ref+dbBehave Wait creature_ref = dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave Vanish creature_ref = - do runMaybeT $- do plane_ref <- MaybeT $ liftM (fmap $ fst . location) $ getPlanarLocation creature_ref+ do dbAdvanceTime creature_ref =<< quickActionTime creature_ref+ _ <- runMaybeT $+ do (plane_ref :: PlaneRef) <- MaybeT $ liftM (fmap location) $ getPlanarPosition creature_ref lift $ do faction <- getCreatureFaction creature_ref is_visible_to_anyone_else <- liftM (any (creature_ref `elem`)) $ - mapM (flip dbGetVisibleObjectsForFaction plane_ref) (delete faction [minBound..maxBound])+ mapM (\fact -> dbGetVisibleObjectsForFaction (return . const True) fact plane_ref) + ({- all factions except this one: -} delete faction [minBound..maxBound]) when (not is_visible_to_anyone_else) $ deleteCreature creature_ref- dbAdvanceTime (1%100) creature_ref+ return ()++dbBehave Activate creature_ref =+ do atomic $ liftM executeActivation $ resolveActivation creature_ref+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref+ return ()++dbBehave (Make make_prep) creature_ref =+ do atomic $ liftM executeMake $ resolveMake creature_ref make_prep+ dbAdvanceTime creature_ref =<< fullActionTime creature_ref+ return ()++dbBehave (ClearTerrain face) creature_ref =+ do _ <- dbMove (turnCreature face) creature_ref+ ok <- modifyFacingTerrain clearTerrain face creature_ref+ when (not ok) $ throwError $ DBErrorFlag Unable+ dbAdvanceTime creature_ref =<< fullActionTime creature_ref+ return ()++dbBehave (ActivateBuilding face) creature_ref =+ do _ <- dbMove (turnCreature face) creature_ref+ ok <- activateFacingBuilding face creature_ref+ when (not ok) $ throwError $ DBErrorFlag Unable+ dbAdvanceTime creature_ref =<< fullActionTime creature_ref++{---------------------------------------------------------------------------------------------------+-- These are functions related to determing how long it takes for a creature to execute an action.+----------------------------------------------------------------------------------------------------}++-- | A value indicating the degree of difficulty a creature suffers on account of the inventory it is carrying.+inventoryBurden :: (DBReadable db) => CreatureRef -> db Rational+inventoryBurden creature_ref =+ do inventory_size <- liftM (genericLength . map (asReferenceTyped _tool)) $ dbGetContents creature_ref+ inventory_skill <- liftM roll_ideal $ rollCreatureAbilityScore InventorySkill 0 creature_ref+ return $ (inventory_size ^ 2) % inventory_skill++-- | Multiplier penalty if a creature is overweighted.+overweightPenalty :: (DBReadable db) => CreatureRef -> db Rational+overweightPenalty = liftM (max 1.0) . inventoryBurden++-- | Multiplier penalty if a creature is injured.+healthPenalty :: (DBReadable db) => CreatureRef -> db Rational+healthPenalty creature_ref =+ do current_health <- getCreatureHealth creature_ref+ raw_speed <- liftM (rawScore Speed) $ dbGetCreature creature_ref+ return $ (max 1.0 $ recip $ max (1%raw_speed) current_health) -- maximum health penalty determined by speed++-- | Multiplier penalties for doing anything that requires physical movement, e.g. walking.+physicalActionPenalties :: (DBReadable db) => CreatureRef -> db Rational+physicalActionPenalties creature_ref = liftM2 (*) (overweightPenalty creature_ref) (healthPenalty creature_ref)++-- | Time required to do a simple physical task.+quickActionTime :: (DBReadable db) => CreatureRef -> db Rational+quickActionTime creature_ref = liftM2 (*) (physicalActionPenalties creature_ref) (liftM ((3%) . rawScore Speed) $ dbGetCreature creature_ref)++-- | Time required to move one step.+move1ActionTime :: (DBReadable db) => CreatureRef -> db Rational+move1ActionTime creature_ref = liftM2 (*) (physicalActionPenalties creature_ref) (liftM ((5%) . rawScore Speed) $ dbGetCreature creature_ref)++-- | Time required to move diagonally one step.+move2ActionTime :: (DBReadable db) => CreatureRef -> db Rational+move2ActionTime = liftM (*1.4142) . move1ActionTime++-- | Time required to complete a complex physical action.+fullActionTime :: (DBReadable db) => CreatureRef -> db Rational+fullActionTime = liftM (*2) . move1ActionTime
+ src/Building.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Building+ (buildingSize,+ buildingType,+ activateFacingBuilding)+ where++import DB+import BuildingData+import Data.List+import Facing+import Data.Maybe+import Control.Monad.Maybe+import Plane+import Position+import TerrainData+import Control.Monad.Error++-- | The total occupied surface area of a building.+buildingSize :: (DBReadable db) => BuildingRef -> db Integer+buildingSize = liftM (genericLength . buildingOccupies) . buildingType++buildingType :: (DBReadable db) => BuildingRef -> db BuildingType+buildingType building_ref =+ do constructed <- liftM extractLocation $ dbWhere building_ref+ case constructed of+ Just (Constructed _ _ building_type) -> return building_type+ _ -> error "buildingSize: impossible case"++-- | Activate the facing building, returns True iff any building was actually activated.+activateFacingBuilding :: Facing -> CreatureRef -> DB Bool+activateFacingBuilding face creature_ref = liftM (fromMaybe False) $ runMaybeT $+ do (plane_ref,position) <- MaybeT $ liftM extractLocation $ dbWhere creature_ref+ buildings <- lift $ whatIsOccupying plane_ref $ offsetPosition (facingToRelative face) position+ liftM or $ lift $ forM buildings $ \building_ref ->+ do building_type <- buildingType building_ref+ activateBuilding building_type creature_ref building_ref++activateBuilding :: BuildingType -> CreatureRef -> BuildingRef -> DB Bool+activateBuilding Monolith _ _ = return False+activateBuilding Portal creature_ref building_ref =+ do m_creature_position :: Maybe (PlaneRef,Position) <- liftM extractLocation $ dbWhere creature_ref+ m_portal_position :: Maybe (PlaneRef,Position) <- liftM extractLocation $ dbWhere building_ref+ when (fmap fst m_creature_position /= fmap fst m_portal_position) $ throwError $ DBError "activateBuilding: creature and portal on different planes"+ case (m_creature_position,m_portal_position) of+ (Just (plane_ref,Position (_,cy)),Just (_,Position (_,py))) ->+ case () of+ () | cy < py ->+ do m_subsequent_loc :: Maybe (Location S PlaneRef Subsequent) <- liftM listToMaybe $ dbGetContents plane_ref+ case m_subsequent_loc of+ Just loc -> (portalCreatureTo 1 creature_ref $ entity loc) >> return True+ _ -> throwError $ DBErrorFlag NoStargateAddress+ () | cy > py ->+ do m_previous_loc :: Maybe Subsequent <- liftM extractLocation $ dbWhere plane_ref+ case m_previous_loc of+ Just loc -> (portalCreatureTo (-1) creature_ref $ subsequent_to loc) >> return True+ _ -> throwError $ DBErrorFlag NoStargateAddress+ () | otherwise -> throwError $ DBErrorFlag BuildingApproachWrongAngle+ _ -> throwError $ DBError "activateBuilding: can't decode building-creature relative positions"+++-- | Deposit a creature in front of (-1) or behind (+1) a random portal on the specified plane. Returns+-- the dbMove result from the action.+portalCreatureTo :: Integer -> CreatureRef -> PlaneRef -> DB (Location S CreatureRef (),Location S CreatureRef Standing)+portalCreatureTo offset creature_ref plane_ref =+ do portals <- filterM (liftM (== Portal) . buildingType) =<< dbGetContents plane_ref+ ideal_position <- if null portals+ then liftM2 (\x y -> Position (x,y)) (getRandomR (-100,100)) (getRandomR (-100,100))+ else do portal <- pickM portals+ m_position <- liftM (fmap (offsetPosition (0,offset)) . extractLocation) $ dbWhere portal+ return $ fromMaybe (Position (0,0)) m_position+ position <- pickRandomClearSite 1 0 0 ideal_position (not . (`elem` impassable_terrains)) plane_ref+ dbPushSnapshot $ TeleportEvent creature_ref+ dbMove (return . toStanding (Standing plane_ref position Here)) creature_ref+ + +
+ src/BuildingData.hs view
@@ -0,0 +1,25 @@++module BuildingData+ (Building(..),+ BuildingType(..),+ buildingOccupies)+ where++data Building = Building+ deriving (Read,Show)++data BuildingType = Monolith | Portal+ deriving (Eq,Ord,Read,Show)++-- | Get a list of squares, relative to the center of the building (0,0),+-- that a building occupies. These squares must be free of unfriendly terrain+-- (mountains, trees, water, lava, etc.) and no other objects can co-occupy these squares.+--+-- A goal is that every building type has a unique occupation signature,+-- so that it can be identified by it's shape alone.+buildingOccupies :: BuildingType -> [(Integer,Integer)]+-- Monolith: X+buildingOccupies Monolith = [(0,0)]+-- Portal: XXX+buildingOccupies Portal = [(0,0),(-1,0),(1,0)]+
src/Character.hs view
@@ -5,19 +5,21 @@ applyCharacterClass) where -import Data.List as List import Alignment import CharacterData+import CreatureAttribute import CreatureData-import StatsData+import TerrainData type Prerequisite = Creature -> Bool -type CharacterClassData = (Prerequisite,[CreatureAttribute])+data CharacterClassData = CharacterClassData {+ character_class_prerequisite :: Prerequisite,+ character_class_attributes :: CreatureAttribute } getEligableCharacterClassesComposable :: [CharacterClass] -> Creature -> [CharacterClass] getEligableCharacterClassesComposable allowed_classes creature = - filter (\x -> (fst $ classInfo x) creature) allowed_classes+ filter (\x -> character_class_prerequisite (classInfo x) creature || isFavoredClass x creature) allowed_classes getEligableCharacterClasses :: Creature -> [CharacterClass] getEligableCharacterClasses = getEligableCharacterClassesComposable all_character_classes@@ -28,29 +30,23 @@ prerequisites :: [Prerequisite] -> Prerequisite prerequisites prereqs creature = all ($ creature) prereqs -mustHave :: Statistic -> Integer -> Prerequisite-mustHave statistic min_score creature = (getStatistic statistic $ creature_stats creature) >= min_score+mustHave :: (CreatureScore a) => a -> Integer -> Prerequisite+mustHave score min_score creature = (rawScore score creature) >= min_score -- | -- Constructor function for CharacterClassData objects. ----- First parameter should be the CharacterClass.------ The second parameter should be the prerequisite (or more than one prerequisite using the prerequisites --- function). The prerequisite(s) restrict what Creatures can advance in the CharacterClass.+-- The first parameter should be the prerequisite (or more than one prerequisite using the 'prerequisites'+-- function). The prerequisite(s) restrict what 'Creatures' can advance in the 'CharacterClass'. ----- The third parameter is the list CreatureAttributes that a Creature gains when it levels in the --- CharacterClass. +-- The second parameter is the list of 'CreatureAttribute's that a Creature gains when it levels in the +-- 'CharacterClass'. ---characterClass :: CharacterClass -> Prerequisite -> [CreatureAttribute] -> CharacterClassData-characterClass character_class prereqs level_xforms = - ((\x -> prereqs x || isFavoredClass character_class x),CharacterLevel character_class : level_xforms)+characterClass :: Prerequisite -> CreatureAttribute -> CharacterClassData+characterClass prereqs attribs = CharacterClassData prereqs attribs applyCharacterClass :: CharacterClass -> Creature -> Creature-applyCharacterClass character_class creature =- if (fst $ classInfo character_class) creature- then foldr applyCreatureAttribute creature (snd $ classInfo character_class)- else error "tried to applyCharacterClass with a creature that didn't meet prerequisites"+applyCharacterClass character_class creature = applyToCreature (character_class & character_class_attributes (classInfo character_class)) creature classInfo :: CharacterClass -> CharacterClassData @@ -65,48 +61,36 @@ -- ------------------------------------------------------------------------------- -classInfo Barbarian = characterClass Barbarian (prerequisites [mustHave Strength 15,mustHave Constitution 15])- [ToughnessTrait,DamageReductionTrait,SpeedTrait,StatBonus Constitution,StatBonus Strength,AlignmentBonus Indifferent]+classInfo Barbarian = characterClass (prerequisites [mustHave Strength 15,mustHave Constitution 15]) $+ DamageReductionTrait Melee & DamageReductionTrait Ranged & DamageReductionTrait Unarmed & ToughnessTrait & Speed & Constitution & Strength & Indifferent -classInfo Consular = characterClass Consular (mustHave Charisma 20)- [StatBonus Charisma,AlignmentBonus Diplomatic]+classInfo Consular = characterClass (mustHave Charisma 20) $+ Charisma & Diplomatic -classInfo Engineer = characterClass Engineer (mustHave Intelligence 20)- [StatBonus Intelligence,AlignmentBonus Strategic]+classInfo Engineer = characterClass (mustHave Intellect 20) $+ Intellect & Strategic -classInfo ForceAdept = characterClass ForceAdept (prerequisites [mustHave Intelligence 15, mustHave Perception 15, mustHave Charisma 15, mustHave Mindfulness 15])- [RangedDefenseSkill,MeleeDefenseSkill,MeleeAttackSkill,StatBonus Perception,StatBonus Mindfulness,AlignmentBonus Indifferent]+classInfo ForceAdept = characterClass (prerequisites [mustHave Intellect 15, mustHave Perception 15, mustHave Charisma 15, mustHave Mindfulness 15]) $+ DefenseSkill Ranged & DefenseSkill Melee & AttackSkill Melee & Speed & Perception & Mindfulness & Indifferent -classInfo Marine = characterClass Marine (prerequisites [mustHave Perception 15,mustHave Constitution 15])- [RangedAttackSkill,- RangedDefenseSkill,- StatBonus Constitution,- StatBonus Dexterity,- StatBonus Perception,- StatBonus Mindfulness,- AlignmentBonus Tactical]+classInfo Marine = characterClass (prerequisites [mustHave Perception 15,mustHave Constitution 15]) $+ AttackSkill Ranged & DefenseSkill Ranged & Constitution & Speed & Perception & Mindfulness & Tactical -classInfo Ninja = characterClass Ninja (prerequisites [mustHave Dexterity 15,mustHave Perception 15])- [HideSkill,MeleeDefenseSkill,RangedDefenseSkill,StatBonus Dexterity,AlignmentBonus Indifferent]+classInfo Ninja = characterClass (prerequisites [mustHave Speed 15,mustHave Perception 15]) $+ HideSkill & DefenseSkill Melee & DefenseSkill Ranged & Speed & Indifferent -classInfo Pirate = characterClass Pirate (prerequisites [mustHave Strength 10,mustHave Perception 10, mustHave Dexterity 10, mustHave Charisma 10])- [RangedAttackSkill,ToughnessTrait,StatBonus Strength,StatBonus Dexterity]+classInfo Pirate = characterClass (prerequisites [mustHave Strength 10,mustHave Perception 10, mustHave Speed 10, mustHave Charisma 10]) $+ AttackSkill Ranged & ToughnessTrait & Strength & Speed -classInfo Scout = characterClass Scout (prerequisites [mustHave Perception 20])- [SpotSkill,StatBonus Dexterity,StatBonus Perception,AlignmentBonus Tactical]+classInfo Scout = characterClass (prerequisites [mustHave Perception 20]) $+ SpotSkill & Speed & Perception & Tactical -classInfo Shepherd = characterClass Shepherd (prerequisites [mustHave Charisma 15,mustHave Mindfulness 15])- [SpotSkill,StatBonus Perception,StatBonus Mindfulness,AlignmentBonus Indifferent]+classInfo Shepherd = characterClass (prerequisites [mustHave Charisma 15,mustHave Mindfulness 15]) $+ SpotSkill & TerrainAffinity Grass & Perception & Mindfulness & Indifferent -classInfo Thief = characterClass Thief (mustHave Perception 20)- [HideSkill,StatBonus Dexterity,StatBonus Charisma,StatBonus Perception,AlignmentBonus Tactical]+classInfo Thief = characterClass (mustHave Perception 20) $+ HideSkill & Speed & Charisma & Perception & Tactical -classInfo Warrior = characterClass Warrior (prerequisites [mustHave Strength 15,mustHave Dexterity 15])- [MeleeAttackSkill,- MeleeDefenseSkill,- StatBonus Constitution,- StatBonus Strength,- StatBonus Dexterity,- StatBonus Mindfulness,- AlignmentBonus Tactical]+classInfo Warrior = characterClass (prerequisites [mustHave Strength 15,mustHave Speed 15]) $+ AttackSkill Melee & DefenseSkill Melee & Constitution & Strength & Speed & Mindfulness & Tactical
src/CharacterData.hs view
@@ -16,7 +16,7 @@ | Shepherd | Thief | Warrior- deriving (Eq,Enum,Bounded,Read,Show)+ deriving (Eq,Enum,Bounded,Read,Show,Ord) all_character_classes :: [CharacterClass] all_character_classes = [minBound..maxBound]@@ -33,3 +33,4 @@ Shepherd, Thief, Warrior]+
src/Combat.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE PatternGuards, FlexibleContexts #-} module Combat- (dbResolveRangedAttack,- dbResolveMeleeAttack,- dbExecuteRangedAttack,- dbExecuteMeleeAttack)+ (AttackModel,+ meleeAttackModel,+ rangedAttackModel,+ resolveAttack,+ executeAttack) where import DB-import DBData import Creature import CreatureData import Tool@@ -16,111 +16,150 @@ import Control.Monad.Error import Facing import Data.Maybe+import DeviceActivation+import Contact import Plane-import Dice-import Data.List-import Data.Ord-import Position -data RangedAttackOutcome =- RangedAttackMiss CreatureRef ToolRef- | RangedAttackHitCreature CreatureRef ToolRef CreatureRef Integer+data AttackModel =+ RangedAttackModel CreatureRef ToolRef Device+ | MeleeAttackModel CreatureRef ToolRef Device+ | UnarmedAttackModel CreatureRef -dbResolveRangedAttack :: (DBReadable db) => CreatureRef -> Facing -> db RangedAttackOutcome-dbResolveRangedAttack attacker_ref face =- do m_defender_ref <- liftM listToMaybe $ dbFindRangedTargets attacker_ref face- tool_ref <- maybe (throwError $ DBErrorFlag "no-weapon-wielded") return =<< dbGetWielded attacker_ref- attack_roll <- dbRollRangedAttack attacker_ref- damage_roll <- dbRollRangedDamage attacker_ref tool_ref- case m_defender_ref of- Nothing -> return $ RangedAttackMiss attacker_ref tool_ref- Just defender_ref ->- do defense_roll <- dbRollRangedDefense attacker_ref defender_ref- injury_roll <- dbRollInjury defender_ref damage_roll- return $ case () of- () | attack_roll > defense_roll -> RangedAttackHitCreature attacker_ref tool_ref defender_ref injury_roll- () | otherwise -> RangedAttackMiss attacker_ref tool_ref+attacker :: AttackModel -> CreatureRef+attacker (RangedAttackModel attacker_ref _ _) = attacker_ref+attacker (MeleeAttackModel attacker_ref _ _) = attacker_ref+attacker (UnarmedAttackModel attacker_ref) = attacker_ref -data MeleeAttackOutcome =- UnarmedAttackHitCreature CreatureRef CreatureRef Integer- | UnarmedAttackMiss CreatureRef+weapon :: AttackModel -> Maybe ToolRef+weapon (RangedAttackModel _ weapon_ref _) = Just weapon_ref+weapon (MeleeAttackModel _ weapon_ref _) = Just weapon_ref+weapon (UnarmedAttackModel {}) = Nothing -dbResolveMeleeAttack :: (DBReadable db) => CreatureRef -> Facing -> db MeleeAttackOutcome-dbResolveMeleeAttack attacker_ref face =- do m_defender_ref <- liftM listToMaybe $ dbFindMeleeTargets attacker_ref face- attack_roll <- dbRollMeleeAttack attacker_ref- damage_roll <- dbRollMeleeDamage attacker_ref- case m_defender_ref of- Nothing -> return $ UnarmedAttackMiss attacker_ref- Just defender_ref ->- do defense_roll <- dbRollMeleeDefense attacker_ref defender_ref- injury_roll <- dbRollInjury defender_ref damage_roll- return $ case () of- () | attack_roll > defense_roll -> UnarmedAttackHitCreature attacker_ref defender_ref injury_roll- () | otherwise -> UnarmedAttackMiss attacker_ref +instance DeviceType AttackModel where+ toPseudoDevice (RangedAttackModel _ _ d) = toPseudoDevice d+ toPseudoDevice (MeleeAttackModel _ _ d) = toPseudoDevice d+ toPseudoDevice (UnarmedAttackModel {}) = PseudoDevice 0 0 0 1 -dbExecuteRangedAttack :: RangedAttackOutcome -> DB ()-dbExecuteRangedAttack (RangedAttackMiss attacker_ref tool_ref) = - do dbPushSnapshot (MissEvent attacker_ref (Just tool_ref))-dbExecuteRangedAttack (RangedAttackHitCreature attacker_ref tool_ref defender_ref damage) =- do dbPushSnapshot (AttackEvent attacker_ref (Just tool_ref) defender_ref)- dbInjureCreature damage defender_ref- sweepDead =<< liftM getLocation (dbWhere attacker_ref)+interactionMode :: AttackModel -> CreatureInteractionMode+interactionMode (RangedAttackModel {}) = Ranged+interactionMode (MeleeAttackModel {}) = Melee+interactionMode (UnarmedAttackModel {}) = Unarmed -dbExecuteMeleeAttack :: MeleeAttackOutcome -> DB ()-dbExecuteMeleeAttack (UnarmedAttackMiss attacker_ref) =- do dbPushSnapshot (MissEvent attacker_ref Nothing)-dbExecuteMeleeAttack (UnarmedAttackHitCreature attacker_ref defender_ref damage) =- do dbPushSnapshot (AttackEvent attacker_ref Nothing defender_ref)- dbInjureCreature damage defender_ref- sweepDead =<< liftM getLocation (dbWhere attacker_ref)+-- | Get the attack model for a creature, based on whatever tool the creature is holding.+-- This will fail if the creature is holding anything other than a weapon.+attackModel :: (DBReadable db) => CreatureRef -> db AttackModel+attackModel attacker_ref =+ do m_tool_ref <- dbGetWielded attacker_ref+ case m_tool_ref of+ Nothing -> return $ UnarmedAttackModel attacker_ref+ Just tool_ref ->+ do tool <- dbGetTool tool_ref+ case tool of+ DeviceTool Gun device -> return $ RangedAttackModel attacker_ref tool_ref device+ DeviceTool Sword device -> return $ MeleeAttackModel attacker_ref tool_ref device+ _ -> throwError $ DBErrorFlag ToolIs_Innapropriate -dbRollRangedDamage :: (DBReadable db) => CreatureRef -> ToolRef -> db Integer-dbRollRangedDamage _ weapon_ref =- do tool <- dbGetTool weapon_ref- case tool of- GunTool g ->- do energy_released <- roll [0..gunEnergyOutput g]- energy_throughput <- roll [0..gunThroughput g] -- todo: overheats if energy_released > energy_throughput- return $ min energy_released energy_throughput+-- | Get an appropriate melee attack model for a creature, based on whatever tool the creature is holding.+-- This will fail if the creature is holding anything other than a suitable melee weapon (allows unarmed strike).+meleeAttackModel :: (DBReadable db) => CreatureRef -> db AttackModel+meleeAttackModel attacker_ref =+ do attack_model <- attackModel attacker_ref+ case interactionMode attack_model `elem` [Melee,Unarmed] of+ True -> return attack_model+ _ -> throwError $ DBErrorFlag ToolIs_Innapropriate -dbRollMeleeDamage :: (DBReadable db) => CreatureRef -> db Integer-dbRollMeleeDamage attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeDamage 0 attacker_ref+-- | Get an appropriate ranged attack model for a creature, based on whatever tool the creature is holding.+-- This will fail if the creature is holding anything other than a suitable ranged or splash weapon.+rangedAttackModel :: (DBReadable db) => CreatureRef -> db AttackModel+rangedAttackModel attacker_ref =+ do attack_model <- attackModel attacker_ref+ case interactionMode attack_model `elem` [Ranged,Splash] of+ True -> return attack_model+ _ -> throwError $ DBErrorFlag ToolIs_Innapropriate -dbRollRangedAttack :: (DBReadable db) => CreatureRef -> db Integer-dbRollRangedAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore RangedAttack 0 attacker_ref+data AttackOutcome =+ AttackMiss CreatureRef (Maybe ToolRef)+ | AttackMalfunction CreatureRef ToolRef Integer+ | AttackExplodes CreatureRef ToolRef Integer+ | AttackHit CreatureRef (Maybe ToolRef) CreatureRef Integer+ | AttackDisarm CreatureRef CreatureRef ToolRef+ | AttackSunder CreatureRef ToolRef CreatureRef ToolRef -dbRollMeleeAttack :: (DBReadable db) => CreatureRef -> db Integer-dbRollMeleeAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeAttack 0 attacker_ref+resolveAttack :: (DBReadable db) => AttackModel -> Facing -> db AttackOutcome+resolveAttack attack_model face =+ do device_activation <- resolveDeviceActivation (AttackSkill $ interactionMode attack_model) + (DamageSkill $ interactionMode attack_model)+ (ReloadSkill $ interactionMode attack_model)+ (toPseudoDevice attack_model)+ (attacker attack_model)+ m_defender_ref <- liftM listToMaybe $ findContacts (contactMode $ interactionMode attack_model) (attacker attack_model) face+ case (dao_outcome_type device_activation,m_defender_ref) of+ (DeviceFailed, _) | Just tool_ref <- weapon attack_model -> + return $ AttackMalfunction (attacker attack_model) tool_ref (dao_energy device_activation)+ (DeviceCriticalFailed, _) | Just tool_ref <- weapon attack_model ->+ return $ AttackExplodes (attacker attack_model) tool_ref (dao_energy device_activation)+ (DeviceActivated, Just defender_ref) ->+ do defense_outcome <- resolveDefense (interactionMode attack_model) defender_ref+ distance_squared <- liftM (fromMaybe 0) $ dbDistanceBetweenSquared (attacker attack_model) defender_ref+ let isDisarmingBlow = dao_skill_roll device_activation > do_skill_roll defense_outcome + distance_squared &&+ dao_energy device_activation > do_damage_reduction defense_outcome + do_disarm_bonus defense_outcome+ case () of+ () | dao_skill_roll device_activation <= do_skill_roll defense_outcome + distance_squared ->+ return $ AttackMiss (attacker attack_model) (weapon attack_model)+ () | isDisarmingBlow && interactionMode attack_model == Unarmed,+ Just defender_wield_ref <- do_defender_wield defense_outcome ->+ return $ AttackDisarm (attacker attack_model) defender_ref defender_wield_ref+ () | isDisarmingBlow && interactionMode attack_model == Melee,+ Just weapon_ref <- weapon attack_model,+ Just defender_wield_ref <- do_defender_wield defense_outcome ->+ return $ AttackSunder (attacker attack_model) weapon_ref defender_ref defender_wield_ref+ () -> return $ AttackHit (attacker attack_model) (weapon attack_model) defender_ref (max 0 $ dao_energy device_activation - do_damage_reduction defense_outcome)+ _ -> return $ AttackMiss (attacker attack_model) (weapon attack_model) -dbRollRangedDefense :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Integer-dbRollRangedDefense attacker_ref x_defender_ref =- do distance <- liftM (fromMaybe (error "dbGetOpposedAttackRoll: defender and attacker are on different planes")) $ dbDistanceBetweenSquared attacker_ref x_defender_ref - case () of- () | Just defender_ref <- coerceReferenceTyped _creature x_defender_ref -> liftM actual_roll $ dbRollCreatureScore RangedDefense distance defender_ref- () | otherwise -> return distance- -dbRollMeleeDefense :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Integer-dbRollMeleeDefense _ x_defender_ref = - case () of- () | Just defender_ref <- coerceReferenceTyped _creature x_defender_ref -> liftM actual_roll $ dbRollCreatureScore MeleeDefense 0 defender_ref- () | otherwise -> return 1+data DefenseOutcome = DefenseOutcome {+ do_defender_wield :: Maybe ToolRef,+ do_skill_roll :: Integer,+ do_damage_reduction :: Integer,+ do_disarm_bonus :: Integer } -dbFindRangedTargets :: (DBReadable db,ReferenceType x,GenericReference a S) => Reference x -> Facing -> db [a]-dbFindRangedTargets attacker_ref face =- do m_l <- liftM (fmap location) $ getPlanarLocation attacker_ref- flip (maybe $ return []) m_l $ \(plane_ref,pos) ->- liftM (mapMaybe fromLocation .- sortBy (comparing (distanceBetweenSquared pos . location)) .- filter ((/= generalizeReference attacker_ref) . entity) . - filter (isFacing (pos,face) . location)) $ - dbGetContents plane_ref+resolveDefense :: (DBReadable db) => CreatureInteractionMode -> CreatureRef -> db DefenseOutcome +resolveDefense interaction_mode defender_ref =+ do m_tool_ref <- dbGetWielded defender_ref+ m_tool <- maybe (return Nothing) (liftM Just . dbGetTool) m_tool_ref+ disarm_bonus <- maybe (return 0) toolDurability m_tool_ref+ let pdevice = case m_tool of+ Just (DeviceTool Sword d) | interaction_mode `elem` [Melee,Unarmed] -> toPseudoDevice d+ _ -> PseudoDevice 0 0 0 1+ device_activation <- resolveDeviceActivation (DefenseSkill interaction_mode)+ (DamageReductionTrait interaction_mode)+ InventorySkill+ pdevice+ defender_ref+ return $ case dao_outcome_type device_activation of+ DeviceActivated -> DefenseOutcome m_tool_ref (dao_skill_roll device_activation) (dao_energy device_activation) disarm_bonus+ DeviceFailed -> DefenseOutcome m_tool_ref 0 0 disarm_bonus+ DeviceCriticalFailed -> DefenseOutcome m_tool_ref 0 0 0 -dbFindMeleeTargets :: (DBReadable db,ReferenceType x,GenericReference a S) => Reference x -> Facing -> db [a]-dbFindMeleeTargets attacker_ref face =- do m_l <- liftM (fmap location) $ getPlanarLocation attacker_ref- flip (maybe $ return []) m_l $ \(plane_ref,pos) ->- liftM (mapMaybe fromLocation .- filter (\x -> (location x == (offsetPosition (facingToRelative face) pos) || location x == pos) &&- generalizeReference attacker_ref /= entity x)) $- dbGetContents plane_ref+executeAttack :: AttackOutcome -> DB ()+executeAttack (AttackMiss attacker_ref m_tool_ref) =+ do dbPushSnapshot $ MissEvent attacker_ref m_tool_ref+executeAttack (AttackHit attacker_ref m_tool_ref defender_ref damage) =+ do injureCreature damage defender_ref+ dbPushSnapshot $ AttackEvent attacker_ref m_tool_ref defender_ref+executeAttack (AttackMalfunction attacker_ref tool_ref damage) =+ do injureCreature damage attacker_ref+ _ <- dbMove dbDropTool tool_ref+ dbPushSnapshot $ WeaponOverheatsEvent attacker_ref tool_ref+ return ()+executeAttack (AttackExplodes attacker_ref tool_ref damage) =+ do injureCreature damage attacker_ref+ dbPushSnapshot $ WeaponExplodesEvent attacker_ref tool_ref+ deleteTool tool_ref+executeAttack (AttackDisarm attacker_ref defender_ref dropped_tool) =+ do dbPushSnapshot $ DisarmEvent attacker_ref defender_ref dropped_tool+ _ <- dbMove dbDropTool dropped_tool+ return ()+executeAttack (AttackSunder attacker_ref weapon_ref defender_ref sundered_tool) =+ do dbPushSnapshot $ SunderEvent attacker_ref weapon_ref defender_ref sundered_tool+ deleteTool sundered_tool+
src/Creature.hs view
@@ -1,86 +1,132 @@ {-# LANGUAGE PatternGuards #-} module Creature - (dbGenerateInitialPlayerCreature,- dbNewCreature,+ (generateInitialPlayerCreature,+ newCreature, Roll(..),- dbRollCreatureScore,+ RollComponents(..),+ rollCreatureAbilityScore,+ getCurrentCreature, getCreatureFaction,- dbRollInjury,- dbInjureCreature,- dbGetDead,+ injureCreature,+ healCreature,+ getCreatureHealth,+ getCreatureMaxHealth,+ getCreatureAbsoluteHealth,+ getDead, deleteCreature, sweepDead) where -import Data.Maybe import CreatureData import DB import SpeciesData import Species-import DBData import FactionData import Control.Monad.Error-import Dice import Tool+import CreatureAttribute+import Data.Monoid+import Data.Ratio+import Facing+import Position+import Plane+import PlayerState -- | -- Generates a new Creature from the specified species. ---dbGenerateCreature :: Faction -> Species -> DB Creature-dbGenerateCreature faction species = - do (stats,attribs,name) <- generateCreatureData species- random_id <- dbNextRandomInteger- return (Creature { creature_stats=stats,- creature_attribs=attribs,- creature_species_name=name,- creature_random_id=random_id,- creature_damage=0,- creature_faction=faction})+generateCreature :: Faction -> Species -> DB Creature+generateCreature faction species = generateAttributes faction species $ mconcat $ species_starting_attributes $ speciesInfo species -- | -- During DBRaceSelectionState, generates a new Creature for the player character and sets it into the -- database's DBClassSelectionState. ---dbGenerateInitialPlayerCreature :: Species -> DB ()-dbGenerateInitialPlayerCreature species = - do newc <- dbGenerateCreature Player species+generateInitialPlayerCreature :: Species -> DB ()+generateInitialPlayerCreature species = + do newc <- generateCreature Player species dbSetStartingRace species setPlayerState (ClassSelectionState newc) -- | -- Generates a new Creature from the specified Species and adds it to the database. ---dbNewCreature :: (CreatureLocation l) => Faction -> Species -> l -> DB CreatureRef-dbNewCreature faction species loc = - do creature <- dbGenerateCreature faction species+newCreature :: (CreatureLocation l) => Faction -> Species -> l -> DB CreatureRef+newCreature faction species loc = + do creature <- generateCreature faction species dbAddCreature creature loc +data RollComponents = RollComponents {+ component_base :: Integer,+ component_other_situation_bonus :: Integer,+ component_terrain_affinity_bonus :: Integer }+ data Roll = Roll { - ideal_score :: Integer,- other_situation_bonus :: Integer,- actual_roll :: Integer }+ roll_ideal :: Integer,+ roll_actual :: Integer,+ roll_ideal_components :: RollComponents,+ roll_actual_components :: RollComponents,+ roll_log :: Integer } -dbRollCreatureScore :: (DBReadable db) => Score -> Integer -> CreatureRef -> db Roll-dbRollCreatureScore score bonus creature_ref =- do ideal <- liftM ((+ bonus) . creatureScore score) $ dbGetCreature creature_ref- actual <- roll [0..ideal]- return $ Roll ideal bonus actual+rollCreatureAbilityScore :: (DBReadable db) => CreatureAbility -> Integer -> CreatureRef -> db Roll+rollCreatureAbilityScore score other_ideal creature_ref =+ do raw_ideal <- liftM (creatureAbilityScore score) $ dbGetCreature creature_ref+ terrain_ideal <- getTerrainAffinity creature_ref+ let ideal = raw_ideal + other_ideal + terrain_ideal+ actual <- linearRoll ideal+ [raw_actual, other_actual, terrain_actual] <- fixedSumLinearRoll [raw_ideal, other_ideal, terrain_ideal] actual+ logarithmic <- logRoll ideal+ --trace (show $ (score,raw_ideal,other_ideal,terrain_ideal,raw_actual,other_actual,terrain_actual)) $ return ()+ return $ Roll ideal (if raw_actual == 0 then 0 else actual)+ (RollComponents raw_ideal other_ideal terrain_ideal)+ (RollComponents raw_actual other_actual terrain_actual) logarithmic +-- | Ability bonus based on being good at working on specific types of terrain.+getTerrainAffinity :: (DBReadable db) => CreatureRef -> db Integer+getTerrainAffinity creature_ref =+ do l <- liftM (fmap location) $ getPlanarPosition creature_ref+ terrain_affinity_points <- case l of+ Nothing -> return 0+ Just (plane_ref,pos) -> liftM sum $ forM [minBound..maxBound] $ \face ->+ do t <- terrainAt plane_ref $ offsetPosition (facingToRelative face) pos+ liftM (creatureAbilityScore $ TerrainAffinity t) $ dbGetCreature creature_ref+ return $ terrain_affinity_points `div` 4++-- | Get the current creature, if it belongs to the specified faction, based on the current playerState.+getCurrentCreature :: (DBReadable db) => Faction -> db (Maybe CreatureRef)+getCurrentCreature faction =+ do m_who <- liftM creatureOf $ playerState+ is_one_of_us <- maybe (return False) (liftM (== faction) . getCreatureFaction) m_who+ return $ if is_one_of_us then m_who else Nothing+ getCreatureFaction :: (DBReadable db) => CreatureRef -> db Faction getCreatureFaction = liftM creature_faction . dbGetCreature -dbRollInjury :: (DBReadable db) => CreatureRef -> Integer -> db Integer-dbRollInjury creature_ref damage_roll = - do damage_reduction <- liftM actual_roll $ dbRollCreatureScore DamageReduction 0 creature_ref- return $ max 0 $ damage_roll - damage_reduction- -dbInjureCreature :: Integer -> CreatureRef -> DB ()-dbInjureCreature x = dbModCreature $ \c -> c { creature_damage = creature_damage c + x }+injureCreature :: Integer -> CreatureRef -> DB ()+injureCreature x = dbModCreature $ \c -> c { creature_damage = max 0 $ creature_damage c + x } -dbGetDead :: (DBReadable db) => Reference a -> db [CreatureRef]-dbGetDead parent_ref = filterRO (liftM (\c -> creatureScore HitPoints c <= 0) . dbGetCreature) =<< dbGetContents parent_ref+healCreature :: Integer -> CreatureRef -> DB ()+healCreature = injureCreature . negate +getCreatureMaxHealth :: (DBReadable db) => CreatureRef -> db Integer+getCreatureMaxHealth = liftM (creatureAbilityScore ToughnessTrait) . dbGetCreature++-- | Injury difference from maximum health as an integer count of hit points.+getCreatureInjury :: (DBReadable db) => CreatureRef -> db Integer+getCreatureInjury = liftM creature_damage . dbGetCreature++-- | Health as an integer count of hit points.+getCreatureAbsoluteHealth :: (DBReadable db) => CreatureRef -> db Integer+getCreatureAbsoluteHealth creature_ref = liftM (max 0) $ liftM2 (-) (getCreatureMaxHealth creature_ref) (getCreatureInjury creature_ref)++-- | Health as a fraction of 1.+getCreatureHealth :: (DBReadable db) => CreatureRef -> db Rational+getCreatureHealth creature_ref = liftM2 (%) (getCreatureAbsoluteHealth creature_ref) (getCreatureMaxHealth creature_ref)++getDead :: (DBReadable db) => Reference a -> db [CreatureRef]+getDead parent_ref = filterRO (liftM (<= 0) . getCreatureHealth) =<< dbGetContents parent_ref+ deleteCreature :: CreatureRef -> DB () deleteCreature = dbUnsafeDeleteObject $ \l -> do m_dropped_loc <- maybe (return Nothing) (liftM Just . dbDropTool) $ coerceEntityTyped _tool l@@ -88,9 +134,10 @@ Just dropped_loc -> generalizeLocationRecord dropped_loc Nothing -> error "dbDeleteCreature: no case for this type of entity" +-- | Delete all dead creatures from the database. sweepDead :: Reference a -> DB () sweepDead ref =- do worst_to_best_critters <- sortByRO (liftM ideal_score . dbRollCreatureScore HitPoints 0) =<< dbGetDead ref+ do worst_to_best_critters <- sortByRO getCreatureHealth =<< getDead ref flip mapM_ worst_to_best_critters $ \creature_ref -> do dbPushSnapshot (KilledEvent creature_ref) deleteCreature creature_ref
+ src/CreatureAttribute.hs view
@@ -0,0 +1,52 @@+module CreatureAttribute+ (CreatureAttribute,+ CreatureAttributeGenerator,+ gender,+ CreatureAttribute.attributeStatic,+ CreatureAttribute.attributeMinMax,+ AG.attributeChoice,+ AG.attributeChoices,+ CreatureAttribute.generateAttributes,+ (&))+ where++import Data.Monoid+import AttributeGeneration as AG+import CreatureData+import Control.Monad.Random+import FactionData+import SpeciesData++newtype CreatureAttribute = CreatureAttribute { fromCreatureAttribute :: Endo Creature }++instance CreatureEndo CreatureAttribute where+ applyToCreature (CreatureAttribute f) = appEndo f++(&) :: (CreatureEndo x,CreatureEndo y) => x -> y -> CreatureAttribute+x & y = CreatureAttribute $ Endo $ applyToCreature x . applyToCreature y++type CreatureAttributeGenerator = AttributeGenerator CreatureAttribute++-- |+-- Generate a ratio of males to females with any gender dimorphism.+-- 'gender (1%3) [attributeStatic 5 Speed] [attributeStatic 5 Mindfulness]' generates a+-- creature with a 1:2 male:female ratio, faster males, and more mindful females.+--+gender :: Rational -> [CreatureAttributeGenerator] -> [CreatureAttributeGenerator] -> CreatureAttributeGenerator+gender r male_dimorphism female_dimorphism = AG.attributeChoice r (CreatureAttribute.attributeStatic 1 Male:male_dimorphism) (CreatureAttribute.attributeStatic 1 Female:female_dimorphism)++attributeStatic :: (CreatureEndo a) => Integer -> a -> CreatureAttributeGenerator+attributeStatic n a = AG.attributeStatic n (CreatureAttribute $ Endo $ applyToCreature a)++attributeMinMax :: (CreatureEndo a) => (Integer,Integer) -> a -> CreatureAttributeGenerator+attributeMinMax min_max a = AG.attributeMinMax min_max (CreatureAttribute $ Endo $ applyToCreature a)++generateAttributes :: (MonadRandom m) => Faction -> Species -> CreatureAttributeGenerator -> m Creature+generateAttributes faction species_name attrib_generator =+ do attribs <- AG.generateAttributes attrib_generator+ random_id <- getRandomR (0,30000)+ let c = empty_creature {+ creature_species = species_name,+ creature_random_id = random_id,+ creature_faction = faction } + return $ (appEndo $ mconcat $ map fromCreatureAttribute attribs) c
src/CreatureData.hs view
@@ -2,184 +2,179 @@ module CreatureData (Creature(..), CreatureGender(..),- CreatureAttribute(..),- creatureScore,- Score(..),- applyCreatureAttribute,- exampleCreature1,+ CreatureAptitude(..),+ CreatureInteractionMode(..),+ CreatureAbility(..),+ CreatureEndo(..),+ CreatureScore(..),+ FavoredClass(..), creatureGender,- characterClassLevels,- isFavoredClass)+ creatureAbilityScore,+ isFavoredClass,+ empty_creature) where import CharacterData import Alignment-import StatsData-import ListUtils (count) import Data.Maybe import FactionData+import Data.Monoid+import qualified Data.Map as Map+import qualified Data.Set as Set+import SpeciesData+import TerrainData -data Creature = Creature { creature_stats :: Stats, - creature_attribs :: [CreatureAttribute],- creature_species_name :: String,+data Creature = Creature { creature_aptitude :: Map.Map CreatureAptitude Integer,+ creature_ability :: Map.Map CreatureAbility Integer,+ creature_ethical :: Map.Map EthicalAlignment Integer,+ creature_levels :: Map.Map CharacterClass Integer,+ creature_favored_classes :: Set.Set CharacterClass,+ creature_gender :: CreatureGender,+ creature_species :: Species, creature_random_id :: Integer, -- random number attached to the creature, not unique creature_damage :: Integer, creature_faction :: Faction } deriving (Read,Show) -instance StatisticsBlock Creature where- str creature = strength $ creature_stats creature- dex creature = dexterity $ creature_stats creature- con creature = constitution $ creature_stats creature- int creature = intelligence $ creature_stats creature- per creature = perception $ creature_stats creature- cha creature = charisma $ creature_stats creature- mind creature = mindfulness $ creature_stats creature+-- | Creature having no attributes and undefined 'creature_species', 'creature_random_id', and 'creature_faction'+--+empty_creature :: Creature+empty_creature = Creature {+ creature_aptitude = Map.empty,+ creature_ability = Map.empty,+ creature_ethical = Map.empty,+ creature_levels = Map.empty,+ creature_favored_classes = Set.empty,+ creature_gender = Neuter,+ creature_species = error "empty_creature: undefined creature_species",+ creature_random_id = error "empty_creature: undefined creature_random_id",+ creature_damage = 0,+ creature_faction = error "empty_creature: undefined creature_faction" } data CreatureGender = Male | Female | Neuter deriving (Eq,Read,Show) --- |--- A creature's attributes.----data CreatureAttribute = Gender CreatureGender- | ToughnessTrait -- extra hit points- | DamageReductionTrait -- subtracts from any damage inflicted- | MeleeAttackSkill -- increased melee accuracy- | MeleeDefenseSkill -- increase melee defense- | RangedAttackSkill -- increased ranged accuracy- | RangedDefenseSkill -- increase ranged defense- | SpeedTrait -- more turns per round- | HideSkill -- unit is harder to see- | SpotSkill -- unit can see farther away- | StatBonus Statistic -- +1 to any statistic- | AlignmentBonus EthicalAlignment -- represents the creature's tendency toward strategic, tactical, diplomatic, or indifferent thinking styles- | CharacterLevel CharacterClass -- record of a character class being applied to the creature, has no game effect- | FavoredClass CharacterClass -- creature is able to take the specified class without any prerequisites- deriving (Eq, Show, Read)+-- | Endomorphisms over a 'Creature'. These are types that contribute some feature to a 'Creature', so that 'Creature's can be defined concisely by those properties.+class CreatureEndo a where+ applyToCreature :: a -> Creature -> Creature -data Score = MaxHitPoints- | HitPoints- | DamageReduction- | MeleeAttack- | MeleeDefense- | MeleeDamage- | RangedAttack- | RangedDefense- | Speed Statistic- | EffectiveLevel- | Spot- | Hide+-- | Primitive numeric properties of a Creature.+class CreatureScore s where+ rawScore :: s -> Creature -> Integer --- |--- An example creature used for test cases.----exampleCreature1 :: Creature-exampleCreature1 = Creature - { creature_stats = Stats { strength=2, constitution=5, dexterity=1, intelligence=(-2), perception=4, charisma=(-1), mindfulness=(-1) },- creature_attribs = [Gender Male,- ToughnessTrait,- ToughnessTrait,- ToughnessTrait,- MeleeAttackSkill,- MeleeDefenseSkill,- RangedDefenseSkill],- creature_species_name = "Example-Creature-1",- creature_random_id=0,- creature_damage = 0,- creature_faction = Monsters }+instance (CreatureEndo a,Integral i) => CreatureEndo (a,i) where+ applyToCreature (_,i) | i <= 0 = id+ applyToCreature (a,i) = applyToCreature (a,toInteger i - 1) . applyToCreature a -creatureScore :: Score -> Creature -> Integer-creatureScore MaxHitPoints = \c -> max 6 (str c + con c + dex c + mind c) + 2 * attributeCount ToughnessTrait c-creatureScore HitPoints = \c -> creatureScore MaxHitPoints c - creature_damage c-creatureScore DamageReduction = statPlusDouble Constitution DamageReductionTrait-creatureScore MeleeAttack = statPlusDouble Dexterity MeleeAttackSkill-creatureScore MeleeDefense = statPlusDouble Dexterity MeleeDefenseSkill-creatureScore MeleeDamage = getStatistic Strength-creatureScore RangedAttack = statPlusDouble Dexterity RangedAttackSkill-creatureScore RangedDefense = statPlusDouble Perception RangedDefenseSkill -creatureScore (Speed by_statistic) = \c -> max 1 $ getStatistic by_statistic c + attributeCount SpeedTrait c-creatureScore Spot = statPlusDouble Perception SpotSkill-creatureScore Hide = \c -> max 0 $ per c + attributeCount HideSkill c+instance (CreatureEndo a) => CreatureEndo [a] where+ applyToCreature = appEndo . mconcat . map (Endo . applyToCreature) --- |--- The creature's effective level.------ This sums all of the ability scores and attributes that a creature has and determines----creatureScore EffectiveLevel = \c -> sum (map ($ c) [str,dex,con,int,per,cha,mind] ++- map levelAdjustment (creature_attribs c))+instance CreatureEndo CreatureGender where+ applyToCreature g c = c { creature_gender = g } -attributeCount :: CreatureAttribute -> Creature -> Integer-attributeCount attrib creature = count attrib $ creature_attribs creature+-- | The seven aptitudes.+data CreatureAptitude = + Strength+ | Speed+ | Constitution+ | Intellect+ | Perception+ | Charisma+ | Mindfulness+ deriving (Eq,Read,Show,Ord,Enum,Bounded) --- |--- The standard way to calculate any score is to add the relevant Statistic to twice the number of--- ranks in the relevant skill.----statPlusDouble :: Statistic -> CreatureAttribute -> Creature -> Integer-statPlusDouble statistic attrib creature = max 0 $ getStatistic statistic creature + 2 * attributeCount attrib creature+instance CreatureEndo CreatureAptitude where+ applyToCreature aptitude c = c { creature_aptitude = Map.insertWith (+) aptitude 1 $ creature_aptitude c } --- |--- Answers the number of levels a Creature has taken in a particular CharacterClass.--- These might not be proportional to the value of creatureEffectiveLevel, taking a level--- in a CharacterClass sometimes increases it's effective level by more than one.----characterClassLevels :: CharacterClass -> Creature -> Integer-characterClassLevels character_class creature = count (CharacterLevel character_class) (creature_attribs creature)+instance CreatureScore CreatureAptitude where+ rawScore aptitude c = fromMaybe 0 $ Map.lookup aptitude (creature_aptitude c) --- |--- The amount by which a creature's effective level should be adjusted--- based on a single occurance of the given CreatureAttribute.----levelAdjustment :: CreatureAttribute -> Integer-levelAdjustment ToughnessTrait = 1-levelAdjustment MeleeAttackSkill = 1-levelAdjustment MeleeDefenseSkill = 1-levelAdjustment RangedAttackSkill = 1-levelAdjustment RangedDefenseSkill = 1-levelAdjustment SpeedTrait = 2-levelAdjustment (StatBonus _) = 1-levelAdjustment (Gender {}) = 0-levelAdjustment DamageReductionTrait = 1-levelAdjustment AlignmentBonus {} = 0-levelAdjustment HideSkill = 1-levelAdjustment SpotSkill = 1-levelAdjustment FavoredClass {} = 0-levelAdjustment CharacterLevel {} = 0+-- | Combat modes:+-- Melee is armed close-quarters combat with bladed or blunt weapons+-- Ranged is combat with projectile weapons+-- Unarmed is close-quarters hand-to-hand+-- Splash represts diffuse damage caused by things like explosions or falling into lava.+data CreatureInteractionMode = Melee | Ranged | Unarmed | Splash+ deriving (Eq,Read,Show,Ord) --- |--- Adds a CreatureAttribute to a Creature. The CreatureAttribute stacks with or replaces any other--- related attributes already applied to the creature, depending on the type of attribute.--- Includes some special handling for some CreatureAttributes.----applyCreatureAttribute :: CreatureAttribute -> Creature -> Creature-applyCreatureAttribute (StatBonus statistic) = incCreatureStat statistic -applyCreatureAttribute attrib = putCreatureAttribute attrib+data CreatureAbility =+ ToughnessTrait+ | AttackSkill CreatureInteractionMode+ | DefenseSkill CreatureInteractionMode+ | DamageSkill CreatureInteractionMode+ | DamageReductionTrait CreatureInteractionMode+ | ReloadSkill CreatureInteractionMode+ | TerrainAffinity TerrainPatch+ | HideSkill+ | SpotSkill+ | JumpSkill+ | InventorySkill+ deriving (Eq,Read,Show,Ord) --- |--- applyCreatureAttribute with no special handling.----putCreatureAttribute :: CreatureAttribute -> Creature -> Creature-putCreatureAttribute attrib creature = creature { creature_attribs = (attrib : (creature_attribs creature))}+instance CreatureEndo CreatureAbility where+ applyToCreature ability c = c { creature_ability = Map.insertWith (+) ability 1 $ creature_ability c } -incCreatureStat :: Statistic -> Creature -> Creature-incCreatureStat statistic creature = - let sts = creature_stats creature- in creature { creature_stats = setStatistic statistic (succ $ getStatistic statistic sts) sts }+instance CreatureScore CreatureAbility where+ rawScore ability c = fromMaybe 0 $ Map.lookup ability $ creature_ability c -genderOf :: CreatureAttribute -> Maybe CreatureGender-genderOf attrib = case attrib of- Gender gender -> Just gender- _ -> Nothing+instance CreatureEndo EthicalAlignment where+ applyToCreature ethical c = c { creature_ethical = Map.insertWith (+) ethical 1 $ creature_ethical c } +instance CreatureScore EthicalAlignment where+ rawScore ethical c = fromMaybe 0 $ Map.lookup ethical $ creature_ethical c++instance CreatureEndo CharacterClass where+ applyToCreature character_class c = c { creature_levels = Map.insertWith (+) character_class 1 $ creature_levels c }++instance CreatureScore CharacterClass where+ rawScore character_class c = fromMaybe 0 $ Map.lookup character_class $ creature_levels c++newtype FavoredClass = FavoredClass CharacterClass++instance CreatureEndo FavoredClass where+ applyToCreature (FavoredClass favored_class) c = c { creature_favored_classes = Set.insert favored_class $ creature_favored_classes c }++-- | Calculator to determine how many ranks a creature has in an ability.+-- Number of aptitude points plus n times number of ability points+figureAbility :: [CreatureAptitude] -> (CreatureAbility,Integer) -> Creature -> Integer+figureAbility aptitude (ability,n) c = sum (map (flip rawScore c) aptitude) + rawScore ability c * n++creatureAbilityScore :: CreatureAbility -> Creature -> Integer+creatureAbilityScore ToughnessTrait = figureAbility [Strength,Speed,Constitution,Mindfulness] (ToughnessTrait,3)+creatureAbilityScore (AttackSkill Melee) = figureAbility [Strength] (AttackSkill Melee,2)+creatureAbilityScore (DefenseSkill Melee) = figureAbility [Strength] (DefenseSkill Melee,2)+creatureAbilityScore (DamageSkill Melee) = figureAbility [Strength] (DamageSkill Melee,2)+creatureAbilityScore (DamageReductionTrait Melee) = figureAbility [Constitution] (DamageReductionTrait Melee,1)+creatureAbilityScore (ReloadSkill Melee) = figureAbility [Speed] (ReloadSkill Melee,1)+creatureAbilityScore (AttackSkill Ranged) = figureAbility [Perception] (AttackSkill Ranged,2)+creatureAbilityScore (DefenseSkill Ranged) = figureAbility [Perception] (DefenseSkill Ranged,2)+creatureAbilityScore (DamageSkill Ranged) = figureAbility [Perception] (DamageSkill Ranged,2)+creatureAbilityScore (DamageReductionTrait Ranged) = figureAbility [Constitution] (DamageReductionTrait Ranged,1)+creatureAbilityScore (ReloadSkill Ranged) = figureAbility [Speed] (ReloadSkill Ranged,1)+creatureAbilityScore (AttackSkill Unarmed) = figureAbility [Speed] (AttackSkill Unarmed,2)+creatureAbilityScore (DefenseSkill Unarmed) = figureAbility [Speed] (DefenseSkill Unarmed,2)+creatureAbilityScore (DamageSkill Unarmed) = figureAbility [Speed] (DamageSkill Unarmed,2)+creatureAbilityScore (DamageReductionTrait Unarmed) = figureAbility [Constitution] (DamageReductionTrait Unarmed,1)+creatureAbilityScore (ReloadSkill Unarmed) = figureAbility [Speed] (ReloadSkill Unarmed,1)+creatureAbilityScore (AttackSkill Splash) = figureAbility [Intellect] (AttackSkill Splash,2)+creatureAbilityScore (DefenseSkill Splash) = figureAbility [Intellect] (DefenseSkill Splash,2)+creatureAbilityScore (DamageSkill Splash) = figureAbility [Intellect] (DamageSkill Splash,2)+creatureAbilityScore (DamageReductionTrait Splash) = figureAbility [Constitution] (DamageReductionTrait Splash,1)+creatureAbilityScore (ReloadSkill Splash) = figureAbility [Speed] (ReloadSkill Splash,1)+creatureAbilityScore (TerrainAffinity terrain_type) = figureAbility [] (TerrainAffinity terrain_type,1)+creatureAbilityScore HideSkill = figureAbility [Perception] (HideSkill,2)+creatureAbilityScore SpotSkill = figureAbility [Perception] (SpotSkill,2)+creatureAbilityScore JumpSkill = figureAbility [Strength] (JumpSkill,2)+creatureAbilityScore InventorySkill = figureAbility [Strength,Speed,Constitution] (InventorySkill,2)+ -- | -- Answers the gender of this creature. -- creatureGender :: Creature -> CreatureGender-creatureGender creature = fromMaybe Neuter $ listToMaybe $ mapMaybe genderOf $ creature_attribs creature+creatureGender = creature_gender -- | -- Answers true if the specified class is a favored class for this creature. -- isFavoredClass :: CharacterClass -> Creature -> Bool-isFavoredClass character_class creature = (FavoredClass character_class) `elem` (creature_attribs creature)+isFavoredClass character_class creature = character_class `Set.member` (creature_favored_classes creature)+
src/DB.hs view
@@ -1,29 +1,33 @@ {-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, FlexibleContexts, Rank2Types, RelaxedPolyRec #-} module DB- (DB,+ (DBResult,+ DB, runDB, DBReadable(..), playerState, setPlayerState,- PlayerState(..),- CreatureTurnMode(..), SnapshotEvent(..), DBError(..), CreatureLocation(..), ToolLocation(..),+ PlaneLocation(..), initial_db, DB_BaseType(db_error_flag),+ dbActionCount, dbAddCreature, dbAddPlane, dbAddTool,+ dbAddBuilding, dbUnsafeDeleteObject, dbGetCreature, dbGetPlane, dbGetTool,+ dbGetBuilding, dbModCreature, dbModPlane, dbModTool,+ dbModBuilding, dbMove, dbUnwieldCreature, dbVerify,@@ -41,14 +45,17 @@ dbPeepOldestSnapshot, dbPopOldestSnapshot, dbHasSnapshot,- module DBData)+ module DBData,+ module DBErrorFlag,+ module Random,+ dbTrace) where import DBPrivate import DBData import CreatureData import PlaneData-import System.Time+import BuildingData import RNG import Data.Map as Map import Data.List as List@@ -59,40 +66,20 @@ import Control.Monad.State import Control.Monad.Error import Control.Monad.Reader+import Control.Applicative import TimeCoordinate import Data.Ord-import Control.Arrow (first)--data PlayerState = - RaceSelectionState- | ClassSelectionState Creature- | PlayerCreatureTurn CreatureRef CreatureTurnMode- | SnapshotEvent SnapshotEvent- | GameOver- deriving (Read,Show)--data CreatureTurnMode =- NormalMode- | PickupMode- | DropMode- | WieldMode- 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 }- deriving (Read,Show)+import Control.Arrow (first,second)+import Control.Monad.Random as Random+import Random+import Debug.Trace+import PlayerState+import DBErrorFlag+import Control.Parallel.Strategies data DB_History = DB_History { db_here :: DB_BaseType,- db_random :: [[Integer]] }+ db_random :: RNG } data DB_BaseType = DB_BaseType { db_player_state :: PlayerState, db_next_object_ref :: Integer,@@ -100,79 +87,88 @@ db_creatures :: Map CreatureRef Creature, db_planes :: Map PlaneRef Plane, db_tools :: Map ToolRef Tool,+ db_buildings :: Map BuildingRef Building, db_hierarchy :: HierarchicalDatabase (Location S (Reference ()) ()), db_time_coordinates :: Map (Reference ()) TimeCoordinate, db_error_flag :: String,- db_prior_snapshot :: Maybe DB_BaseType}+ db_prior_snapshot :: Maybe DB_BaseType,+ db_action_count :: Integer } deriving (Read,Show) data DBError = DBError String- | DBErrorFlag String+ | DBErrorFlag ErrorFlag deriving (Read,Show) instance Error DBError where strMsg = DBError -newtype DB a = DB (ErrorT DBError (State DB_History) a)+type DBResult r = Either DBError (r,DB_History)+data DB a = DB { cycleDB :: forall r. DB_History -> (a -> DB_History -> DBResult r) -> DBResult r } runDB :: DB a -> DB_BaseType -> IO (Either DBError (a,DB_BaseType))-runDB (DB actionM) db = - do hist <- setupDBHistory db- return $ case runState (runErrorT actionM) hist of- (Right a,DB_History { db_here = db' }) -> Right (a,db')- (Left e,_) -> Left e+runDB dbAction database = + do hist <- setupDBHistory database+ return $ (either Left (Right . second db_here)) $ cycleDB dbAction hist $ \a h -> Right (a,h) instance Monad DB where- (DB k) >>= m = DB $ k >>= (\x -> let DB n = m x in n)- return = DB . return- fail s = DB $ throwError $ DBError $ "engine-error: " ++ s+ return a = DB $ \h f -> f a h+ k >>= m = DB $ \h f -> cycleDB k h $ \a h' -> cycleDB (m a) h' f+ fail = error +instance Functor DB where+ fmap = liftM++instance Applicative DB where+ pure = return+ (<*>) = ap+ instance MonadState DB_BaseType DB where- get = liftM db_here $ DB get- put s = DB $ modify (\x -> x { db_here = s })+ get = DB $ \h f -> f (db_here h) h+ put s = DB $ \h f -> f () $ modification h+ where modification = \db -> db { db_here = s { db_action_count = succ $ db_action_count $ db_here db } } instance MonadReader DB_BaseType DB where- ask = liftM db_here $ DB get- local f actionM = - do s <- get- modify f+ ask = get+ local modification actionM = + do split_rng <- dbRandomSplit+ s <- get+ modify modification a <- catchError (liftM Right actionM) (return . Left)- put s+ DB $ \h f -> f () $ h { db_here = s, db_random = split_rng } either throwError return a instance MonadError DBError DB where- throwError = DB . throwError- catchError (DB actionM) handlerM = DB $ catchError actionM (\e -> let DB n = handlerM e in n)+ throwError e = DB $ \_ _ -> Left e+ catchError actionM handlerM = DB $ \h f -> either (\err -> cycleDB (handlerM err) h f) Right $ cycleDB actionM h f -class (Monad db,MonadError DBError db,MonadReader DB_BaseType db) => DBReadable db where- dbNextRandomInteger :: db Integer- dbNextRandomIntegerStream :: db [Integer]+instance MonadRandom DB where+ getRandom = dbRandom random+ getRandoms = liftM randoms $ dbRandom Random.split+ getRandomR min_max = dbRandom $ randomR min_max+ getRandomRs min_max = liftM (randomRs min_max) $ dbRandom Random.split++dbRandom :: (RNG -> (a,RNG)) -> DB a+dbRandom rgen = DB $ \h f -> let (x,g) = rgen (db_random h) in f x (h { db_random = g })++dbRandomSplit :: DB RNG+dbRandomSplit = DB $ \h f -> let (a,b) = Random.split (db_random h) in f a (h { db_random = b })++class (Monad db,MonadError DBError db,MonadReader DB_BaseType db,MonadRandom db,Applicative db) => DBReadable db where dbSimulate :: DB a -> db a dbPeepSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db (Maybe a) instance DBReadable DB where- dbNextRandomInteger = - do db <- DB get- let rngss0 = db_random db - (rngs0,rngss1) = (head rngss0, tail rngss0)- (result,rngs1) = (head rngs0, tail rngs0)- DB $ put db { db_random=(rngs1:rngss1) }- return (result)- dbNextRandomIntegerStream = - do db <- DB get- let rngss = db_random db- DB $ put db { db_random=(tail rngss) }- return (head rngss) dbSimulate = local id dbPeepSnapshot actionM =- do s <- DB $ gets db_here+ do s <- DB $ \h f -> f (db_here h) h m_snapshot <- gets db_prior_snapshot case m_snapshot of Just snapshot ->- do DB $ modify $ \hist -> hist { db_here = snapshot }+ do split_rng <- dbRandomSplit+ DB $ \h f -> f () $ h { db_here = snapshot } a <- dbSimulate actionM- DB $ modify $ \hist -> hist { db_here = s }+ DB $ \h f -> f () $ h { db_here = s, db_random = split_rng } return $ Just a Nothing -> return Nothing @@ -181,10 +177,10 @@ ro db = dbSimulate db filterRO :: (DBReadable db) => (forall m. DBReadable m => a -> m Bool) -> [a] -> db [a]-filterRO f xs = ro $ filterM f xs+filterRO f xs = liftM (`using` parList rwhnf) $ filterM (dbSimulate . f) xs mapRO :: (DBReadable db) => (forall m. DBReadable m => a -> m b) -> [a] -> db [b]-mapRO f xs = ro $ mapM f xs+mapRO f xs = liftM (`using` parList rwhnf) $ mapM (dbSimulate . f) xs sortByRO :: (DBReadable db,Ord b) => (forall m. DBReadable m => a -> m b) -> [a] -> db [a] sortByRO f xs =@@ -213,17 +209,19 @@ db_creatures = Map.fromList [], db_planes = Map.fromList [], db_tools = Map.fromList [],+ db_buildings = Map.fromList [], db_hierarchy = HierarchicalDatabase.fromList [], db_error_flag = [], db_time_coordinates = Map.fromList [(generalizeReference the_universe, zero_time)],- db_prior_snapshot = Nothing }+ db_prior_snapshot = Nothing,+ db_action_count = 0 } setupDBHistory :: DB_BaseType -> IO DB_History setupDBHistory db =- do (TOD seconds picos) <- getClockTime+ do rng <- randomIO return $ DB_History { db_here = db,- db_random = randomIntegerStreamStream (seconds + picos) }+ db_random = rng } -- | -- Returns the DBState of the database.@@ -237,11 +235,14 @@ setPlayerState :: PlayerState -> DB () setPlayerState state = modify (\db -> db { db_player_state = state }) +dbActionCount :: (DBReadable db) => db Integer+dbActionCount = asks db_action_count+ -- | -- Gets the next ObjectRef integer, after incrementing it. -- dbNextObjectRef :: DB Integer-dbNextObjectRef = do modify (\db -> db { db_next_object_ref = succ $ db_next_object_ref db })+dbNextObjectRef = do modify $ \db -> db { db_next_object_ref = succ $ db_next_object_ref db } gets db_next_object_ref class (LocationType l) => CreatureLocation l where@@ -250,6 +251,12 @@ class (LocationType l) => ToolLocation l where toolLocation :: ToolRef -> l -> Location m ToolRef l +class (LocationType l) => BuildingLocation l where+ buildingLocation :: BuildingRef -> l -> Location m BuildingRef l++class (LocationType l) => PlaneLocation l where+ planeLocation :: PlaneRef -> l -> Location m PlaneRef l+ instance CreatureLocation Standing where creatureLocation a l = IsStanding (unsafeReference a) l @@ -262,6 +269,15 @@ instance ToolLocation Wielded where toolLocation a l = IsWielded (unsafeReference a) l +instance BuildingLocation Constructed where+ buildingLocation a l = IsConstructed (unsafeReference a) l++instance PlaneLocation TheUniverse where+ planeLocation a _ = InTheUniverse a++instance PlaneLocation Subsequent where+ planeLocation a l = IsSubsequent a l+ -- | -- Adds something to a map in the database using a new object reference. --@@ -287,8 +303,8 @@ -- | -- Adds a new Plane to the database. ---dbAddPlane :: Plane -> () -> DB PlaneRef-dbAddPlane = dbAddObjectComposable PlaneRef dbPutPlane (\a () -> InTheUniverse a)+dbAddPlane :: (PlaneLocation l) => Plane -> l -> DB PlaneRef+dbAddPlane = dbAddObjectComposable PlaneRef dbPutPlane planeLocation -- | -- Adds a new Tool to the database.@@ -297,6 +313,12 @@ dbAddTool = dbAddObjectComposable ToolRef dbPutTool toolLocation -- |+-- Adds a new Tool to the database.+--+dbAddBuilding :: (BuildingLocation l) => Building -> l -> DB BuildingRef+dbAddBuilding = dbAddObjectComposable BuildingRef dbPutBuilding buildingLocation++-- | -- This deletes an object, but leaves any of it's contents dangling. -- dbUnsafeDeleteObject :: (ReferenceType e) =>@@ -306,7 +328,7 @@ Reference e -> DB () dbUnsafeDeleteObject f ref =- do dbMoveAllWithin f ref+ do _ <- dbMoveAllWithin f ref modify $ \db -> db { db_creatures = Map.delete (unsafeReference ref) $ db_creatures db, db_planes = Map.delete (unsafeReference ref) $ db_planes db,@@ -343,31 +365,43 @@ dbPutTool = dbPutObjectComposable db_tools (\x db_base_type -> db_base_type { db_tools = x }) -- |+-- Puts a Building under an arbitrary BuildingRef+--+dbPutBuilding :: BuildingRef -> Building -> DB ()+dbPutBuilding = dbPutObjectComposable db_buildings (\x db_base_type -> db_base_type { db_buildings = x })++-- | -- Gets an object from the database using getter functions. ---dbGetObjectComposable :: (DBReadable db,Ord a) => (DB_BaseType -> Map a b) -> a -> db b-dbGetObjectComposable get_fn ref = - asks (fromMaybe (error "dbGetObjectComposable: Nothing") . Map.lookup ref . get_fn)+dbGetObjectComposable :: (DBReadable db,Ord a,GenericReference a x) => String -> (DB_BaseType -> Map a b) -> a -> db b+dbGetObjectComposable type_info get_fn ref = + asks (fromMaybe (error $ "dbGetObjectComposable: Nothing. UID was " ++ show (toUID $ generalizeReference ref) ++ ", type info was " ++ type_info) . Map.lookup ref . get_fn) -- | -- Gets a Creature from a CreatureRef -- dbGetCreature :: (DBReadable m) => CreatureRef -> m Creature-dbGetCreature = dbGetObjectComposable db_creatures+dbGetCreature = dbGetObjectComposable "CreatureRef" db_creatures -- | -- Gets a Plane from a PlaneRef -- dbGetPlane :: (DBReadable m) => PlaneRef -> m Plane-dbGetPlane = dbGetObjectComposable db_planes+dbGetPlane = dbGetObjectComposable "PlaneRef" db_planes -- | -- Gets a Plane from a PlaneRef -- dbGetTool :: (DBReadable m) => ToolRef -> m Tool-dbGetTool = dbGetObjectComposable db_tools+dbGetTool = dbGetObjectComposable "ToolRef" db_tools -- |+-- Gets a Plane from a PlaneRef+--+dbGetBuilding :: (DBReadable m) => BuildingRef -> m Building+dbGetBuilding = dbGetObjectComposable "BuildingRef" db_buildings++-- | -- Modifies an Object based on an ObjectRef. -- dbModObjectComposable :: (Reference e -> DB e) -> (Reference e -> e -> DB ()) -> @@ -393,13 +427,22 @@ dbModTool = dbModObjectComposable dbGetTool dbPutTool -- |+-- Modifies a Tool based on a PlaneRef.+--+dbModBuilding :: (Building -> Building) -> BuildingRef -> DB ()+dbModBuilding = dbModObjectComposable dbGetBuilding dbPutBuilding++-- | -- Set the location of an object.+-- This is where we handle making sure that a creature can only wield one tool, and+-- a Plane can point to only one subsequent Plane. -- dbSetLocation :: (LocationType e,LocationType t) => Location S e t -> DB () dbSetLocation loc = - do case (fmap location $ coerceLocationTyped _wielded loc) of- Just (Wielded c) -> dbUnwieldCreature c- Nothing -> return ()+ do case (fmap location $ coerceLocationTyped _wielded loc,fmap location $ coerceLocationTyped _subsequent loc) of+ (Just (Wielded c),_) -> dbUnwieldCreature c+ (_,Just (Subsequent b)) -> mapM_ (dbSetLocation . (InTheUniverse :: PlaneRef -> Location S PlaneRef TheUniverse)) =<< dbGetContents b+ (_,_) -> return () modify (\db -> db { db_hierarchy=HierarchicalDatabase.insert (unsafeLocation loc) $ db_hierarchy db }) -- |@@ -412,7 +455,7 @@ -- Moves an object, returning the location of the object before and after -- the move. ---dbMove :: (LocationType (Reference e),LocationType b) =>+dbMove :: (ReferenceType e, LocationType (Reference e),LocationType b) => (forall m. DBReadable m => Location M (Reference e) () -> m (Location M (Reference e) b)) -> (Reference e) -> DB (Location S (Reference e) (),Location S (Reference e) b)@@ -420,6 +463,8 @@ do old <- dbWhere ref new <- ro $ moveF (unsafeLocation old) dbSetLocation $ generalizeLocationRecord $ unsafeLocation new+ when (getLocation old =/= getLocation new) $ -- an entity arriving in a new container shouldn't act before, nor be suspended beyond, the next action of the container+ dbSetTimeCoordinate ref =<< dbGetTimeCoordinate (getLocation new) return (unsafeLocation old, unsafeLocation new) dbMoveAllWithin :: (forall m. DBReadable m => @@ -476,8 +521,8 @@ -- | -- Advances the time of an object. ---dbAdvanceTime :: (ReferenceType a) => Rational -> Reference a -> DB ()-dbAdvanceTime t ref = dbSetTimeCoordinate ref =<< (return . (advanceTime t)) =<< dbGetTimeCoordinate ref+dbAdvanceTime :: (ReferenceType a) => Reference a -> Rational -> DB ()+dbAdvanceTime ref t = dbSetTimeCoordinate ref =<< (return . (advanceTime t)) =<< dbGetTimeCoordinate ref -- | -- Finds the object whose turn is next, among a restricted group of objects.@@ -499,10 +544,10 @@ -- Sets the starting race. -- dbSetStartingRace :: Species -> DB ()-dbSetStartingRace species = modify (\db -> db { db_starting_race = Just species })+dbSetStartingRace the_species = modify (\db -> db { db_starting_race = Just the_species }) -- |--- Takes a snapshot of a DBEvent in progress.+-- Takes a snapshot of a SnapshotEvent in progress. -- dbPushSnapshot :: SnapshotEvent -> DB () dbPushSnapshot e = modify $ \db -> db {@@ -524,3 +569,10 @@ case isJust $ db_prior_snapshot =<< db_prior_snapshot db of False -> db { db_prior_snapshot = Nothing } True -> db { db_prior_snapshot = fmap popOldestSnapshot $ db_prior_snapshot db }++-- | Print a debug/trace message from DB.+{-# NOINLINE dbTrace #-}+dbTrace :: (DBReadable db) => String -> db ()+dbTrace s =+ do db <- ask+ trace ("trace (object count " ++ show (db_next_object_ref db) ++ ") : " ++ s) $ return ()
src/DBData.hs view
@@ -6,9 +6,10 @@ CreatureRef, PlaneRef, ToolRef,+ BuildingRef, TheUniverse(..), the_universe,- (=:=),+ (=:=), (=/=), GenericReference(..), locationsOf, ReferenceType(..),@@ -19,18 +20,25 @@ Dropped(..), Inventory(..), Wielded(..),+ Constructed(..),+ Subsequent(..), _nullary, _creature, _tool, _plane,+ _building, _standing, _dropped, _inventory, _wielded,+ _constructed,+ _subsequent, _position,+ _multiposition, _facing, _the_universe, asLocationTyped,+ asReferenceTyped, DBPrivate.S, location, entity,@@ -60,6 +68,7 @@ import ToolData import CreatureData import PlaneData+import BuildingData import Data.Maybe import Control.Monad import Position@@ -81,6 +90,9 @@ _plane :: Type PlaneRef _plane = Type $ error "_plane: undefined" +_building :: Type BuildingRef+_building = Type $ error "_building: undefined"+ _standing :: Type Standing _standing = Type $ error "_standing: undefined" @@ -93,9 +105,18 @@ _wielded :: Type Wielded _wielded = Type $ error "_wielded: undefined" +_constructed :: Type Constructed+_constructed = Type $ error "_constructed: undefined"++_subsequent :: Type Subsequent+_subsequent = Type $ error "_subsequent: undefined"+ _position :: Type Position _position = Type $ error "_position: undefined" +_multiposition :: Type MultiPosition+_multiposition = Type $ error "_multiposition: undefined"+ _facing :: Type Facing _facing = Type $ error "_facing: undefined" @@ -109,6 +130,13 @@ fromLocation :: (ReferenceType x) => Location m (Reference x) b -> Maybe a generalizeReference :: a -> Reference () +instance (GenericReference a m,GenericReference b m) => GenericReference (Either a b) m where+ fromLocation x = case (fromLocation x,fromLocation x) of+ (Just a,_) -> Just $ Left a+ (_,Just b) -> Just $ Right b+ _ | otherwise -> Nothing+ generalizeReference = either generalizeReference generalizeReference+ instance (ReferenceType a) => GenericReference (Reference a) m where fromLocation = coerceReference . entity generalizeReference = unsafeReference@@ -126,6 +154,9 @@ (=:=) :: (GenericReference a m,GenericReference b n) => a -> b -> Bool a =:= b = generalizeReference a == generalizeReference b +(=/=) :: (GenericReference a m,GenericReference b n) => a -> b -> Bool+a =/= b = not $ a =:= b+ -- -- References --@@ -157,6 +188,10 @@ coerceReference (CreatureRef ref) = Just $ CreatureRef ref coerceReference _ = Nothing +instance ReferenceType Building where+ coerceReference (BuildingRef ref) = Just $ BuildingRef ref+ coerceReference _ = Nothing+ instance ReferenceType TheUniverse where coerceReference UniverseRef = Just UniverseRef coerceReference _ = Nothing@@ -178,18 +213,25 @@ getLocation (IsDropped _ d) = unsafeReference $ dropped_plane d getLocation (InInventory _ c) = unsafeReference $ inventory_creature c getLocation (IsWielded _ c) = unsafeReference $ wielded_creature c+getLocation (IsConstructed _ c) = unsafeReference $ constructed_plane c getLocation (InTheUniverse _) = unsafeReference UniverseRef+getLocation (IsSubsequent _ b) = unsafeReference $ subsequent_to b getEntity :: Location m e t -> Reference () getEntity (IsStanding r _) = unsafeReference r getEntity (IsDropped r _) = unsafeReference r getEntity (InInventory r _) = unsafeReference r getEntity (IsWielded r _) = unsafeReference r+getEntity (IsConstructed r _) = unsafeReference r getEntity (InTheUniverse r) = unsafeReference r+getEntity (IsSubsequent r _) = unsafeReference r asLocationTyped :: (LocationType e,LocationType t) => Type e -> Type t -> Location m e t -> Location m e t asLocationTyped _ _ = id +asReferenceTyped :: (LocationType e) => Type e -> e -> e+asReferenceTyped _ = id+ coerceLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Maybe (Location m e t) coerceLocationTyped = const coerceLocation @@ -246,6 +288,21 @@ extractLocation _ = Nothing extractEntity = const Nothing +instance LocationType Constructed where+ extractLocation (IsConstructed _ i) = Just i+ extractLocation _ = Nothing+ extractEntity = const Nothing++instance LocationType TheUniverse where+ extractLocation (InTheUniverse {}) = Just TheUniverse+ extractLocation _ = Nothing+ extractEntity = const Nothing++instance LocationType Subsequent where+ extractLocation (IsSubsequent _ i) = Just i+ extractLocation _ = Nothing+ extractEntity = const Nothing+ instance LocationType () where extractLocation = const $ Just () extractEntity = const Nothing@@ -255,15 +312,24 @@ extractLocation (IsDropped _ d) = Just $ dropped_position d extractLocation (InInventory {}) = Nothing extractLocation (IsWielded {}) = Nothing+ extractLocation (IsConstructed _ c) = Just $ constructed_position c extractLocation (InTheUniverse {}) = Nothing+ extractLocation (IsSubsequent {}) = Nothing extractEntity = const Nothing +instance LocationType MultiPosition where+ extractLocation (IsConstructed _ c) = Just $ multiPosition (constructed_position c) (buildingOccupies $ constructed_type c)+ extractLocation x = fmap (toMultiPosition :: Position -> MultiPosition) $ extractLocation x+ extractEntity = const Nothing+ instance LocationType Facing where extractLocation (IsStanding _ s) = Just $ standing_facing s extractLocation (IsDropped {}) = Nothing extractLocation (InInventory {}) = Nothing extractLocation (IsWielded {}) = Nothing+ extractLocation (IsConstructed {}) = Nothing extractLocation (InTheUniverse {}) = Nothing+ extractLocation (IsSubsequent {}) = Nothing extractEntity = const Nothing instance ReferenceType a => LocationType (Reference a) where
src/DBPrivate.hs view
@@ -13,10 +13,13 @@ Dropped(..), Inventory(..), Wielded(..),+ Constructed(..), TheUniverse(..),+ Subsequent(..), CreatureRef, ToolRef,- PlaneRef)+ PlaneRef,+ BuildingRef) where import HierarchicalDatabase@@ -24,6 +27,7 @@ import CreatureData import ToolData import PlaneData+import BuildingData import Position --@@ -39,11 +43,12 @@ -- | -- Type representing the entire universe. ---data TheUniverse = TheUniverse deriving (Read,Show)+data TheUniverse = TheUniverse deriving (Read,Show,Eq,Ord) type CreatureRef = Reference Creature type ToolRef = Reference Tool type PlaneRef = Reference Plane+type BuildingRef = Reference Building -- | -- A typesafe reference to any entity.@@ -51,6 +56,7 @@ data Reference a = CreatureRef { uid:: Integer } | PlaneRef { uid :: Integer } | ToolRef { uid :: Integer }+ | BuildingRef { uid :: Integer } | UniverseRef deriving (Eq,Ord,Read,Show) @@ -58,6 +64,7 @@ unsafeReference (CreatureRef x) = CreatureRef x unsafeReference (PlaneRef x) = PlaneRef x unsafeReference (ToolRef x) = ToolRef x+unsafeReference (BuildingRef x) = BuildingRef x unsafeReference UniverseRef = UniverseRef toUID :: Reference a -> Integer@@ -82,6 +89,15 @@ deriving (Read,Show,Eq,Ord) -- |+-- The location of a Building constructed on a Plane.+--+data Constructed =+ Constructed { constructed_plane :: PlaneRef,+ constructed_position :: Position,+ constructed_type :: BuildingType }+ deriving (Read,Show,Eq,Ord)++-- | -- The location of a tool carried by a creature. -- data Inventory =@@ -94,21 +110,27 @@ data Wielded = Wielded { wielded_creature :: CreatureRef } deriving (Read,Show,Eq,Ord)+ -- |+-- The location of a Plane linked to from another Plane, such as with a Stargate.+--+data Subsequent =+ Subsequent { subsequent_to :: PlaneRef }+ deriving (Read,Show,Eq,Ord)++-- | -- A relational data structure defining the location of any entity. -- All of the type variables of Location are phantom types. ----- m represents the modification domain of the Location. For example,--- a Location M is the location of a moving entity. The goal of m--- is to ensure that the entity can not be changed when moving an entity,--- e.g. Robert can not turn into Susan by walking across the street.+-- m represents the modification domain of the Location. Location M is+-- a location of an moving entity, while Location S is the location of+-- a static entity.+--+-- The M parameter ensures that the entity's identity can not be changed +-- when moving an entity, e.g. Robert can not turn into Susan by walking across the street. -- No function Location M e t -> Location M e t can be written that -- changes the what entity the location references. ----- A Location S is the location of an still (unmoving) entity and may be--- mutilated at will, but the type checker ensures that no such--- mutilated Location may be used to move an entity.--- -- Thus, we accept functions of the type -- (Location M e a -> Location M e b) -> DB (), -- to move an object, a functions of the type@@ -127,7 +149,9 @@ | IsDropped ToolRef Dropped | InInventory ToolRef Inventory | IsWielded ToolRef Wielded+ | IsConstructed BuildingRef Constructed | InTheUniverse PlaneRef+ | IsSubsequent PlaneRef Subsequent deriving (Read,Show,Eq,Ord) unsafeLocation :: Location a b c -> Location d e f@@ -135,16 +159,22 @@ unsafeLocation (IsDropped a b) = IsDropped a b unsafeLocation (InInventory a b) = InInventory a b unsafeLocation (IsWielded a b) = IsWielded a b+unsafeLocation (IsConstructed a b) = IsConstructed a b unsafeLocation (InTheUniverse a) = InTheUniverse a+unsafeLocation (IsSubsequent a b) = IsSubsequent a b instance HierarchicalRelation (Location m e t) where parent (IsStanding _ t) = toUID $ standing_plane t parent (IsDropped _ t) = toUID $ dropped_plane t parent (InInventory _ t) = toUID $ inventory_creature t parent (IsWielded _ t) = toUID $ wielded_creature t+ parent (IsConstructed _ t) = toUID $ constructed_plane t parent (InTheUniverse _) = toUID UniverseRef+ parent (IsSubsequent _ t) = toUID $ subsequent_to t child (IsStanding e _) = toUID e child (IsDropped e _) = toUID e child (InInventory e _) = toUID e child (IsWielded e _) = toUID e+ child (IsConstructed e _) = toUID e child (InTheUniverse e) = toUID e+ child (IsSubsequent e _) = toUID e
− src/Dice.hs
@@ -1,10 +0,0 @@--module Dice (roll)- where--import Control.Monad.State-import DB-import RandomUtils--roll :: (DBReadable db) => [a] -> db a-roll xs = liftM (pick xs) dbNextRandomInteger
src/Facing.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE OverloadedStrings #-} module Facing (Facing(..), facingToRelative,@@ -12,6 +12,7 @@ import Position import Data.Ord import Data.List+import qualified Data.ByteString.Char8 as B data Facing = North | NorthEast@@ -29,7 +30,7 @@ -- The input string must be lower case. -- No form of "Here" is an acceptable input to this function. ---stringToFacing :: String -> Maybe Facing+stringToFacing :: B.ByteString -> Maybe Facing stringToFacing "n" = Just North stringToFacing "ne" = Just NorthEast stringToFacing "e" = Just East@@ -80,8 +81,8 @@ -- | -- A test function to detect when one Position + Facing points directly at another Position. ---isFacing :: (Position, Facing) -> Position -> Bool-isFacing ((Position a),face) (Position b) = f face a b+isFacing :: (PositionType a,PositionType b) => (a, Facing) -> b -> Bool+isFacing (as,face) bs = or $ map (\(a,b) -> f face (fromPosition a) (fromPosition b)) $ positionPairs as bs where f :: Facing -> (Integer,Integer) -> (Integer,Integer) -> Bool f North (x,y) (u,v) = x == u && v >= y f NorthEast (x,y) (u,v) = x - u == y - v && u >= x
src/FactionData.hs view
@@ -1,8 +1,10 @@-+{-# LANGUAGE OverloadedStrings #-} module FactionData- (Faction(..))+ (Faction(..),factionPrefix) where +import qualified Data.ByteString.Char8 as B+ data Faction = Player | InterstellarConcordance -- the lawful galactic government | PanGalacticTreatyOrganization -- the neutral galactic government@@ -10,8 +12,21 @@ | Monsters -- nonsentient monsters (indifferent "government") | Pirates -- pirates (tactical "government") | Cyborgs -- cyborgs (strategic "government")- | SocialUtopiate -- an economic quasi-alliance or super-clan (diplomatic "government")+ | SocialUtopiate -- an economic super-alliance (diplomatic "government") | Whispers -- the dark indifferent destroyers of worlds | Proselytes -- evil entities that possess others' minds- | Civilian -- merchants, children -- don't kill these+ | Civilian -- merchants, children -- killing these antagonizes all factions deriving (Eq,Read,Show,Enum,Bounded)++factionPrefix :: Faction -> B.ByteString+factionPrefix Player = "Z"+factionPrefix InterstellarConcordance = "C"+factionPrefix PanGalacticTreatyOrganization = "P"+factionPrefix ImperialAlliance = "A"+factionPrefix Monsters = "M"+factionPrefix Pirates = "R"+factionPrefix Cyborgs = "Y"+factionPrefix SocialUtopiate = "U"+factionPrefix Whispers = "X"+factionPrefix Proselytes = "K"+factionPrefix Civilian = "Q"
src/GridRayCaster.hs view
@@ -9,7 +9,6 @@ import Data.List as List import Data.Ratio import Tests-import Data.Maybe -- | -- When casting large numbers of rays from the same point, castRays will try to do this in
src/Grids.hs view
@@ -1,89 +1,88 @@- module Grids (Grid, gridAt, generateGrid,- arbitraryReplaceGrid)+ arbitraryReplaceGrid,+ specificReplaceGrid) where import RNG-import RandomUtils-import ListUtils import Data.Map as Map import Data.Ratio-import Data.List+import Data.List as List+import Random+import Data.MemoCombinators+import Control.Arrow -data Grid a = CompletelyRandomGrid Integer ((Integer,Integer) -> Integer) [(Integer,a)]- | InterpolatedGrid Integer ((Integer,Integer) -> Integer) (Map (a,a) [(Integer,a)]) (Grid a)- | ArbitraryReplacementGrid Integer ((Integer,Integer) -> Integer) [(Rational,a)] [(Integer,a)] (Grid a)- | SpecificPlacementGrid (Map (Integer,Integer) a) (Grid a)- | CachedGrid ((Integer,Integer) -> a) (Grid a)+newtype SeededGrid = SeededGrid Integer deriving (Read,Show)+data StorableCachedGrid a = StorableCachedGrid (Grid a) ((Integer,Integer) -> a) -data Grid_Persistant a = CompletelyRandomGrid_Persistant Integer [(Integer,a)]- | InterpolatedGrid_Persistant Integer [((a,a),[(Integer,a)])] (Grid_Persistant a)- | ArbitraryReplacementGrid_Persistant Integer [(Rational,a)] [(Integer,a)] (Grid_Persistant a)- | SpecificPlacementGrid_Persistant [((Integer,Integer),a)] (Grid_Persistant a)- deriving (Read,Show)+instance (Show a) => Show (StorableCachedGrid a) where+ show (StorableCachedGrid g _) = show g -toPersistant :: (Grid a) -> (Grid_Persistant a)-toPersistant (CompletelyRandomGrid x _ prob_list) = - CompletelyRandomGrid_Persistant x prob_list-toPersistant (InterpolatedGrid x _ prob_map grid) = - InterpolatedGrid_Persistant x (toList prob_map) (toPersistant grid)-toPersistant (ArbitraryReplacementGrid x _ sources replacements grid) = - ArbitraryReplacementGrid_Persistant x sources replacements $ toPersistant grid-toPersistant (SpecificPlacementGrid placement_map grid) = - SpecificPlacementGrid_Persistant (toList placement_map) (toPersistant grid)-toPersistant (CachedGrid _ grid) = toPersistant grid+instance (Read a,Ord a) => Read (StorableCachedGrid a) where+ readsPrec = (List.map (first storableCachedGrid) .) . readsPrec -fromPersistant :: (Ord a) => (Grid_Persistant a) -> (Grid a)-fromPersistant (CompletelyRandomGrid_Persistant x prob_list) = - cachedGridOf $ CompletelyRandomGrid x (randomIntegerGrid x) prob_list-fromPersistant (InterpolatedGrid_Persistant x prob_map grid) =- cachedGridOf $ InterpolatedGrid x (randomIntegerGrid x) (fromList prob_map) (fromPersistant grid)-fromPersistant (ArbitraryReplacementGrid_Persistant x sources replacements grid) =- cachedGridOf $ ArbitraryReplacementGrid x (randomIntegerGrid x) sources replacements (fromPersistant grid)-fromPersistant (SpecificPlacementGrid_Persistant placement_map grid) =- cachedGridOf $ SpecificPlacementGrid (fromList placement_map) (fromPersistant grid)+storableCachedGrid :: (Ord a) => Grid a -> StorableCachedGrid a+storableCachedGrid g = StorableCachedGrid g $ pair integral integral $ gridAt g -fromPersistant_tupled :: (Ord a) => (Grid_Persistant a,String) -> (Grid a,String)-fromPersistant_tupled (x,y) = (fromPersistant x,y)+seededGrid :: Integer -> SeededGrid+seededGrid n = SeededGrid n -instance (Show a) => Show (Grid a) where- show grid = show $ toPersistant grid+seededLookup :: SeededGrid -> (Integer,Integer) -> Integer+seededLookup (SeededGrid n) (x,y) = toInteger $ fst $ next $ mkRNG $+ (fst $ next $ mkRNG (fromInteger $ x `mod` max_int)) ++ (fst $ next $ mkRNG (fromInteger $ y `mod` max_int)) ++ (fromInteger $ n `mod` max_int)+ where max_int = toInteger (maxBound :: Int) -instance (Ord a, Read a) => Read (Grid a) where- readsPrec n = \x -> Prelude.map fromPersistant_tupled (readsPrec n x)+data Grid a = CompletelyRandomGrid {+ _grid_seed :: SeededGrid,+ _grid_weights :: [(Integer,a)] }+ | InterpolatedGrid {+ _grid_seed :: SeededGrid,+ _grid_interpolation_weights :: Map (a,a) [(Integer,a)],+ grid_next :: Grid a }+ | ArbitraryReplacementGrid {+ _grid_seed :: SeededGrid,+ _grid_sources :: [(Rational,a)],+ _grid_replacement_weights :: [(Integer,a)],+ grid_next :: Grid a }+ | SpecificPlacementGrid {+ _grid_replacements :: Map (Integer,Integer) a,+ grid_next :: Grid a }+ | CachedGrid (StorableCachedGrid a)+ deriving (Read,Show) -gridAt :: Ord a => Grid a -> (Integer,Integer) -> a-gridAt (CompletelyRandomGrid _ seedfn weights) at = weightedPick (seedfn at) weights-gridAt (InterpolatedGrid _ seedfn interpolation_map grid) at@(x,y) = +gridAt :: (Ord a) => Grid a -> (Integer,Integer) -> a+gridAt (CompletelyRandomGrid seeded weights) at = fst $ weightedPick weights (mkRNG $ seededLookup seeded at)+gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) = let here = gridAt grid (x `div` 2,y `div` 2) there = gridAt grid (x `div` 2 + 1,y `div` 2 + 1) there_x = gridAt grid (x `div` 2 + 1,y `div` 2) there_y = gridAt grid (x `div` 2,y `div` 2 + 1)- interpolate a1 a2 = weightedPick (seedfn at) (interpolation_map ! (a1,a2))+ interpolate a1 a2 = fst $ weightedPick (interpolation_map ! (a1,a2)) (mkRNG $ seededLookup seeded at) in case (even x,even y) of (True,True) -> here (True,False) -> (interpolate here there_y) (False,True) -> (interpolate here there_x) (False,False) -> (interpolate here there) -gridAt (ArbitraryReplacementGrid _ seedfn sources replacements grid) at = +gridAt (ArbitraryReplacementGrid seeded sources replacements grid) at = case fmap fst $ find ((== here) . snd) sources of- Just frequency | ((seedfn at) `mod` (denominator frequency) < (numerator frequency)) ->- weightedPick (seedfn at) replacements+ Just frequency | (seededLookup seeded at `mod` denominator frequency < numerator frequency) ->+ fst $ weightedPick replacements (mkRNG $ seededLookup seeded at) _ -> here where here = gridAt grid at gridAt (SpecificPlacementGrid rep_map grid) at = findWithDefault (gridAt grid at) at rep_map -gridAt (CachedGrid map_fn _) at = map_fn at+gridAt (CachedGrid (StorableCachedGrid _ f)) at = f at -cachedGridOf :: Ord a => Grid a -> Grid a-cachedGridOf already_cached_grid@(CachedGrid _ _) = already_cached_grid-cachedGridOf any_other_grid = CachedGrid (cachedAccessor2D (gridAt any_other_grid)) any_other_grid+cachedGridOf :: (Ord a) => Grid a -> Grid a+cachedGridOf already_cached_grid@(CachedGrid {}) = already_cached_grid+cachedGridOf any_other_grid = CachedGrid $ storableCachedGrid any_other_grid -- | -- Generates a random grid. The first Integer, smoothness,@@ -92,14 +91,32 @@ -- the map. generateGrid :: (Ord a) => [(Integer,a)] -> Map (a,a) [(Integer,a)] -> Integer -> [Integer] -> Grid a generateGrid weights _ 0 seeds = let seed = head seeds- in CompletelyRandomGrid seed (randomIntegerGrid seed) weights+ in CompletelyRandomGrid (seededGrid seed) weights generateGrid weights interps n seeds = let seed = head seeds- in cachedGridOf $ InterpolatedGrid seed (randomIntegerGrid seed) interps $ - generateGrid weights interps (n-1) (tail seeds)+ in optimizeGrid $ InterpolatedGrid (seededGrid seed) interps $ + generateGrid weights interps (n-1) (tail seeds) -- | -- Arbitrarily (randomly) replaces some elements of a grid with another. -- arbitraryReplaceGrid :: (Ord a) => [(Rational,a)] -> [(Integer,a)] -> Integer -> Grid a -> Grid a-arbitraryReplaceGrid sources replacements seed grid = cachedGridOf $- ArbitraryReplacementGrid seed (randomIntegerGrid seed) sources replacements grid+arbitraryReplaceGrid sources replacements seed grid = optimizeGrid $+ ArbitraryReplacementGrid (seededGrid seed) sources replacements grid++-- |+-- Replace a specific element of a grid.+--+specificReplaceGrid :: (Integer,Integer) -> a -> Grid a -> Grid a+specificReplaceGrid position x (SpecificPlacementGrid m grid) =+ SpecificPlacementGrid (Map.insert position x m) grid+specificReplaceGrid position x grid = specificReplaceGrid position x $ SpecificPlacementGrid (Map.empty) grid++-- |+-- Strip the cache out of lower layers of the grid, but apply a cache to the top layer.+--+optimizeGrid :: (Ord a) => Grid a -> Grid a+optimizeGrid = cachedGridOf . stripCache+ where stripCache (CachedGrid (StorableCachedGrid g _)) = g+ stripCache g@(CompletelyRandomGrid {}) = g+ stripCache grid = grid { grid_next = stripCache $ grid_next grid }+
src/HierarchicalDatabase.hs view
@@ -20,6 +20,7 @@ import Tests import Data.Maybe as Maybe +-- | A record that can be a component of a 'HierarchicalDatabase'. class HierarchicalRelation a where parent :: a -> Integer child :: a -> Integer@@ -28,6 +29,7 @@ parent = toInteger . snd child = toInteger . fst +-- | A tree or hierarchy based on records that represent parent-child relations. data HierarchicalDatabase a = HierarchicalDatabase { hd_children :: (Map Integer [Integer]),@@ -68,28 +70,32 @@ xsParent = parentOf x the_map -- |--- Answers the parent of an element, or nothing if the element--- is not listed as a child in this HierarchicalDatabase.+-- Answers the key of the parent of the given key, if any. -- parentOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe Integer parentOf x the_map = fmap parent $ Map.lookup x $ hd_parent the_map -- |--- Answers the parent relation and all children relations for a given key.+-- Answers the parent relation and all children relations of a given key. -- lookup :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> (Maybe a,[a]) lookup x the_map = (Map.lookup x $ hd_parent the_map, maybe [] (Maybe.mapMaybe (flip Map.lookup (hd_parent the_map))) $ Map.lookup x $ hd_children the_map) +-- |+-- Answers the child relations of a given key.+-- lookupChildren :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [a] lookupChildren x the_map = snd $ HierarchicalDatabase.lookup x the_map +-- |+-- Answers the parent relation of a given key, if any.+-- lookupParent :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe a lookupParent x the_map = fst $ HierarchicalDatabase.lookup x the_map -- |--- Answers a list of the children of an element, or the null list if the element is--- not listed as a parent in this HierarchicalDatabase.+-- Answers the keys of the children for a given key. -- childrenOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [Integer] childrenOf x the_map = maybe [] id $ Map.lookup x (hd_children the_map)
− src/HopList.hs
@@ -1,109 +0,0 @@--module HopList- (HopList,- toList,- fromList,- hopTail,- index,- hopLookup,- hopListTests)- where--import Data.List as List-import Tests---- |--- A data structure that is almost, but not exactly, completely unlike a skip list.--- Strictly speaking, skip lists are probabilistic data structures over sorted elements.--- This HopList implementation just allows O( log n ) access to elements of a haskell list.--- Like a skip list, it uses a stack of parallel arrays to quickly traverse a list.--- It supports infinite lists.------ The HopList looks something like this:------ 00 -> 16--- 00 -> 04 -> 08 -> 12 -> 16 -> 20--- 00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20----data HopList a = HopStack { hop_up :: HopList a, hop_right :: HopList a }- | HopNode { hop_down :: !(HopList a), hop_right :: HopList a }- | HopElem [a]--hopListFactor :: Integer-hopListFactor = 16--toList :: HopList a -> [a]-toList (HopElem xs) = xs-toList (HopStack _ right) = toList right-toList (HopNode down _) = toList down--fromList :: [a] -> HopList a-fromList xs = HopStack { hop_up=fromList_up (HopElem xs), hop_right=HopElem xs }--fromList_up :: HopList a -> HopList a-fromList_up param@(HopElem xs) = seq param $ HopNode { hop_down=param, hop_right=fromList_up (HopElem (genericDrop hopListFactor xs)) }-fromList_up param@(HopNode _ _) = seq param $ HopNode { hop_down=param, hop_right=fromList_up ((hop_rights param) `genericIndex` hopListFactor) }-fromList_up param@(HopStack _ _) = hop_up param--hop_rights :: HopList a -> [HopList a]-hop_rights param = iterate hop_right param---- |--- Answers the rest of a HopList starting from the specified index.--- ((fromList xs) `hopTail` 5) is equivalent to (drop 5 xs).----hopTail :: HopList a -> Integer -> [a]-hopTail hl i = hopTail_ hl 1 i--hopTail_ :: HopList a -> Integer -> Integer -> [a]-hopTail_ (HopElem xs) 1 i = genericDrop i xs-hopTail_ (HopElem _) _ _ = error "Depth of a HopElem is always 1"-hopTail_ param@(HopNode _ _) depth i = hopTail_ - (hop_down $ head $ genericDrop (i `div` depth) $ hop_rights param)- (depth `div` hopListFactor) - (i `mod` depth)-hopTail_ param@(HopStack _ _) depth i = let next_depth = depth * hopListFactor- in if next_depth < i- then hopTail_ (hop_up param) next_depth i- else hopTail_ (hop_right param) depth i---- |--- Answers the element at the specified index. ((fromList xs) `index` 5)--- is equivalent to (xs !! 5).----index :: HopList a -> Integer -> a-index hl i = head $ hopTail hl i---- |--- As index, but returns in a monad if the element is available--- or fails if it is beyond the end of the list.----hopLookup :: Monad m => HopList a -> Integer -> m a-hopLookup hl i = case (hopTail hl i) of- [] -> fail ("no element at index " ++ (show i))- xs -> return $ head xs--exampleHopListInfinite :: HopList Int-exampleHopListInfinite = fromList [0,2..]--exampleHopListFinite :: HopList Int-exampleHopListFinite = fromList [0,2..2000]--hopListTests :: [TestCase]-hopListTests = [hopListTestZeroIndex,hopListTestSmallIndex,hopListTestLargeIndex,hopListTestOutOfBoundsIndex]--hopListTestZeroIndex :: TestCase-hopListTestZeroIndex = test "hopListTestZeroIndex" - ((exampleHopListInfinite `hopLookup` 0) == Just 0)--hopListTestSmallIndex :: TestCase-hopListTestSmallIndex = test "hopListTestSmallIndex"- ((exampleHopListInfinite `hopLookup` 5) == Just 10)--hopListTestLargeIndex :: TestCase-hopListTestLargeIndex = test "hopListTestLargeIndex"- ((exampleHopListInfinite `hopLookup` 500000) == Just 1000000)--hopListTestOutOfBoundsIndex :: TestCase-hopListTestOutOfBoundsIndex = test "hopListTestOutOfBoundsIndex"- ((exampleHopListFinite `hopLookup` 500000) == Nothing)
− src/ListUtils.hs
@@ -1,96 +0,0 @@--module ListUtils - (listByFrequency,- count,- bidirect,- bidirectionalAccessor1D,- bidirectionalAccessor2D,- monodirect,- monodirectionalList1D,- monodirectionalList2D,- cachedAccessor1D,- cachedAccessor2D)- where--import Data.List-import SegHopList---- |--- Converts a list of elements to an infinite list of those same elements such--- that the frequency of an element of the result is related to how early--- that element occurs in the parameter. Each subsequent element in the parameter--- occurs half as often (and first occurs twice as late) as the one before.--- [a,b,c,d] becomes (cycle [a,b,a,c,a,b,a,d])----listByFrequency :: [a] -> [a]-listByFrequency (x:[]) = repeat x-listByFrequency (x:xs) = x : (intersperse x $ listByFrequency xs)-listByFrequency [] = error "Can't do anything with an empty list."---- |--- count 1 [2,5,1,4,1,1] is 3, because 1 occurs three times.----count :: Eq a => a -> [a] -> Integer-count element lst = genericLength $ elemIndices element lst---- |--- Maps integers in the range [-inf .. inf] to [0 .. inf]----bidirect :: Integer -> Integer-bidirect n = if n >= 0- then (2*n)- else (2*(-n)-1)---- |--- Inverse operation of bidirect.----monodirect :: Integer -> Integer-monodirect n = if (even n)- then n `div` 2- else -(n `div` 2)---- |--- Accessor to reference a one-dimensional list as a bidirectional list.--- In other words, the indexes becomes:--- [0,-1,1,-2,2,-3,3,-4,4,-5,5 ...]----bidirectionalAccessor1D :: [a] -> (Integer -> a)-bidirectionalAccessor1D xs = let sh_list = SegHopList.fromList xs- in (\i -> sh_list `SegHopList.index` (bidirect i))---- |--- Accessor to reference a two-dimensional list as a bidirectional two-dimensional list.--- The outer list is considered to be the y-axis, and the inner list the x-axis, if --- elements are references by (x,y)----bidirectionalAccessor2D :: [[a]] -> ((Integer,Integer) -> a)-bidirectionalAccessor2D xss = let sh_lists = SegHopList.fromList $ map SegHopList.fromList xss- in (\(x,y) -> (sh_lists `SegHopList.index` (bidirect y)) `SegHopList.index` (bidirect x))---- |--- Inverse operation of bidirectionalAccessor1D----monodirectionalList1D :: (Integer -> a) -> [a]-monodirectionalList1D fn = map (fn . monodirect) [0..]---- |--- Inverse operation of bidirectionalAccessor2D----monodirectionalList2D :: ((Integer,Integer) -> a) -> [[a]]-monodirectionalList2D fn = let zero_dot_dot = [0..]- pairs = [[(monodirect x,monodirect y) | x <- zero_dot_dot] | y <- zero_dot_dot]- in map (map fn) pairs---- |--- Combines monodirectionalList1D and bidirectionalAccessor1D to create a cached version--- of the original function. If the original was a sufficiently expensive function for which--- the same value is queried many times, then the cached version may be faster, at the expense--- of memory.-cachedAccessor1D :: (Integer -> a) -> (Integer -> a)-cachedAccessor1D = bidirectionalAccessor1D . monodirectionalList1D---- |--- 2D version of cachedAccessor1D.----cachedAccessor2D :: ((Integer,Integer) -> a) -> ((Integer,Integer) -> a)-cachedAccessor2D = bidirectionalAccessor2D . monodirectionalList2D
src/Main.hs view
@@ -4,19 +4,14 @@ import DB import System.Environment-import System.Random-import System.IO-import Data.List import Tests import HierarchicalDatabase-import Control.Monad import TerrainData-import HopList import Protocol import GridRayCaster roguestar_version_number :: String-roguestar_version_number = "0.2.2"+roguestar_version_number = "0.3" roguestar_program_name :: String roguestar_program_name = "roguestar-engine"@@ -31,7 +26,6 @@ runByArgs "tests" = do testsPassed <- runAllTests ([sampleTestCase] ++ insidenessTests ++- hopListTests ++ gridRayCasterTests) if testsPassed then putStrLn "All tests passed."
src/Perception.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE ExistentialQuantification, Rank2Types #-}+{-# LANGUAGE ExistentialQuantification, Rank2Types, FlexibleContexts #-} ---+-- | -- Perception is essentially a catalogue of information that can be -- observed from a creatures-eye-view, i.e. information that--- is legal for a human agent or ai agent to have.+-- is legal for a human agent or ai agent to have while choosing+-- it's next move. --- module Perception (DBPerception, whoAmI,@@ -14,20 +14,24 @@ myFaction, Perception.getCreatureFaction, whereAmI,- myPosition,- whereIs,- Perception.roll)+ localBiome,+ compass) where import Control.Monad.Reader-import Control.Monad+import Data.Ord import DB import FactionData import Creature import PlaneVisibility+import PlaneData import Data.Maybe+import Data.List import Facing-import Dice+import Position+import TerrainData+import BuildingData+import Building newtype (DBReadable db) => DBPerception db a = DBPerception { fromPerception :: (ReaderT CreatureRef db a) } @@ -35,20 +39,39 @@ (DBPerception a) >>= m = DBPerception $ a >>= (\x -> case m x of {(DBPerception b) -> b}) return = DBPerception . return +instance (DBReadable db,MonadRandom db) => MonadRandom (DBPerception db) where+ getRandom = liftDB getRandom+ getRandoms = liftDB getRandoms+ getRandomR min_max = liftDB $ getRandomR min_max+ getRandomRs min_max = liftDB $ getRandomRs min_max++-- |+-- 'liftDB' takes an action in DBReadable and lifts it to DBPerception. Obviously not exported,+-- or DBPerception wouldn't be limited.+-- liftDB :: (DBReadable db) => (forall m. DBReadable m => m a) -> DBPerception db a liftDB actionM = DBPerception $ lift actionM +-- |+-- A run of DBPerception is tied to the creature doing the percieving. 'whoAmI' answers that creature.+-- We will call this creature "me" or "I".+-- whoAmI :: (DBReadable db) => DBPerception db CreatureRef whoAmI = DBPerception $ ask +-- |+-- Run a DBPerception from the point-of-view of the given creature.+-- Note that if you pass any 'Reference' or 'Location' into the perception monad,+-- it will be able to cheat. Therefore, don't.+-- runPerception :: (DBReadable db) => CreatureRef -> (forall m. DBReadable m => DBPerception m a) -> db a runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref -visibleObjects :: (DBReadable db,LocationType a,LocationType b) => DBPerception db [Location S a b]-visibleObjects =+visibleObjects :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> DBPerception m Bool) -> DBPerception db [a]+visibleObjects filterF = do me <- whoAmI faction <- myFaction- liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction faction) =<< liftM extractLocation (dbWhere me)+ liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction (\a -> runPerception me $ filterF a) faction) =<< liftM extractLocation (dbWhere me) myFaction :: (DBReadable db) => DBPerception db Faction myFaction = Perception.getCreatureFaction =<< whoAmI@@ -59,11 +82,24 @@ whereAmI :: (DBReadable db) => DBPerception db (Facing,Position) whereAmI = liftM (fromMaybe (error "whereAmI: I'm not on a plane") . extractLocation) $ whereIs =<< whoAmI -myPosition :: (DBReadable db) => DBPerception db Position-myPosition = liftM snd whereAmI+whatPlaneAmIOn :: (DBReadable db) => DBPerception db PlaneRef+whatPlaneAmIOn = liftM (fromMaybe (error "whatPlaneAmIOn: I'm not on a plane") . extractLocation) $ whereIs =<< whoAmI whereIs :: (DBReadable db) => Reference a -> DBPerception db (Location S (Reference a) ()) whereIs ref = liftDB $ dbWhere ref -roll :: (DBReadable db) => [a] -> DBPerception db a-roll xs = liftDB $ Dice.roll xs+localBiome :: (DBReadable db) => DBPerception db Biome+localBiome = + do plane_ref <- whatPlaneAmIOn+ liftDB $ liftM plane_biome $ dbGetPlane plane_ref++compass :: (DBReadable db) => DBPerception db Facing+compass =+ do let signalling_building_types = [Portal,Monolith]+ (_,pos) <- whereAmI+ plane <- whatPlaneAmIOn+ liftDB $+ do buildings <- liftM (sortBy $ comparing $ distanceBetweenSquared pos . location) $ filterM (liftM (`elem` signalling_building_types) . buildingType . entity) =<< + dbGetContents plane+ return $ maybe Here (faceAt pos . location) $ listToMaybe buildings+
src/Plane.hs view
@@ -1,46 +1,68 @@-+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings #-} module Plane (dbNewPlane,+ planetName, dbGetCurrentPlane, dbDistanceBetweenSquared,+ pickRandomClearSite_withTimeout, pickRandomClearSite,- getPlanarLocation)+ getPlanarPosition,+ terrainAt,+ setTerrainAt,+ whatIsOccupying,+ isTerrainPassable,+ getBiome) where import Grids-import Dice import DB-import DBData import TerrainData import PlaneData import Control.Monad import Data.Maybe import Data.List import Position+import PlayerState+import FactionData+import qualified Data.ByteString.Char8 as B -dbNewPlane :: TerrainGenerationData -> DB PlaneRef-dbNewPlane tg_data = - do rns <- dbNextRandomIntegerStream- dbAddPlane (Plane { plane_terrain = generateTerrain tg_data rns }) ()+dbNewPlane :: (PlaneLocation l) => Maybe B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef+dbNewPlane name tg_data l = + do rns <- getRandoms+ random_id <- getRandomR (1,1000000)+ random_name <- randomPlanetName PanGalacticTreatyOrganization+ dbAddPlane (Plane { plane_biome = tg_biome tg_data,+ plane_terrain = generateTerrain tg_data rns,+ plane_random_id = random_id,+ plane_planet_name = fromMaybe random_name name}) l +planetName :: (DBReadable db) => PlaneRef -> db B.ByteString+planetName = liftM plane_planet_name . dbGetPlane++randomPlanetName :: (DBReadable db) => Faction -> db B.ByteString+randomPlanetName faction = + do planet_number <- getRandomR (1000 :: Integer,9999)+ return $ factionPrefix faction `B.append` "-" `B.append` B.pack (show planet_number)+ -- | -- If this object is anywhere on a plane (such as carried by a creature who is on the plane), -- returns the position of this object on that plane. ---getPlanarLocation :: (DBReadable db,ReferenceType a) => Reference a -> db (Maybe (Location S (Reference ()) (PlaneRef,Position)))-getPlanarLocation ref =+getPlanarPosition :: (DBReadable db,ReferenceType a,LocationType p) => Reference a -> db (Maybe (Location S (Reference ()) p))+getPlanarPosition ref = liftM (listToMaybe . mapMaybe coerceLocationRecord) $ dbGetAncestors ref -- |--- Distance between two entities.+-- Distance between two entities. If the entities are not on the same plane, or for some other reason it doesn't make+-- sense to ask their distance, the Nothing. -- dbDistanceBetweenSquared :: (DBReadable db,ReferenceType a,ReferenceType b) => Reference a -> Reference b -> db (Maybe Integer) dbDistanceBetweenSquared a_ref b_ref =- do m_a <- liftM (fmap location) $ getPlanarLocation a_ref- m_b <- liftM (fmap location) $ getPlanarLocation b_ref+ do m_a <- liftM (fmap location) $ getPlanarPosition a_ref+ m_b <- liftM (fmap location) $ getPlanarPosition b_ref return $- do (p_a,a) <- m_a- (p_b,b) <- m_b+ do (p_a :: PlaneRef,a :: MultiPosition) <- m_a+ (p_b,b :: MultiPosition) <- m_b guard $ p_a == p_b return $ distanceBetweenSquared a b @@ -48,18 +70,7 @@ -- Gets the current plane of interest based on whose turn it is. -- dbGetCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef)-dbGetCurrentPlane = - do state <- playerState- case state of- PlayerCreatureTurn creature_ref _ -> - liftM (fmap $ fst . location) $ getPlanarLocation creature_ref- SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) ->- liftM (fmap $ fst . location) $ getPlanarLocation attacker_ref- SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) ->- liftM (fmap $ fst . location) $ getPlanarLocation attacker_ref- SnapshotEvent (KilledEvent killed_ref) ->- liftM (fmap $ fst . location) $ getPlanarLocation killed_ref- _ -> return Nothing+dbGetCurrentPlane = liftM (fmap location) $ maybe (return Nothing) getPlanarPosition . creatureOf =<< playerState -- | -- Selects sites at random until one seems reasonably clear. It begins at@@ -68,30 +79,74 @@ -- -- A site is considered clear if there are no objects at all within object_clear squares, and -- only appropriate terrain (as defined by a predicate) within terrain_clear squares.+-- Distance is chessboard distance. ----- This function will return an unsuitable site if it can't find a suitable one.--- Such a site may have unsuitable terrain around it or it may be outside of--- the search_radius (it is never impossible to find an area free of objects, since--- terrain is infinite and objects are not).+-- This function will expand the search radius liberally if encounters the slightest+-- difficulty finding a qualifying position. The search radius parameter is strictly advisory. ---pickRandomClearSite :: Integer -> Integer -> Integer -> Position -> (TerrainPatch -> Bool) -> PlaneRef -> DB Position-pickRandomClearSite search_radius object_clear terrain_clear (Position (start_x,start_y)) terrainPredicate plane_ref =+-- This function can take an optional timeout parameter (pickRandomClearSite_withTimeout). When used+-- without a timeout parameter, it may not terminate. The only possible cause of non-termination is that no+-- site satisfies the terrain predicate.+--+-- The timeout value should be a small integer greater or equal to one, since this function is exponential in the timeout value.+--+pickRandomClearSite :: (DBReadable db) =>+ Integer -> Integer -> Integer -> + Position -> (TerrainPatch -> Bool) -> PlaneRef -> + db Position+pickRandomClearSite search_radius object_clear terrain_clear p terrainPredicate plane_ref = liftM (fromMaybe $ error "pickRandomClearSite: impossible") $+ pickRandomClearSite_withTimeout Nothing search_radius object_clear terrain_clear p terrainPredicate plane_ref++pickRandomClearSite_withTimeout :: (DBReadable db) => + Maybe Integer -> Integer -> Integer -> Integer -> + Position -> (TerrainPatch -> Bool) -> PlaneRef -> + db (Maybe Position)+pickRandomClearSite_withTimeout (Just x) _ _ _ _ _ _ | x <= 0 = return Nothing+pickRandomClearSite_withTimeout timeout search_radius object_clear terrain_clear (Position (start_x,start_y)) terrainPredicate plane_ref = do xys <- liftM2 (\a b -> map Position $ zip a b)- (mapM (\x -> liftM (+start_x) $ roll [-x..x]) [1..search_radius])- (mapM (\x -> liftM (+start_y) $ roll [-x..x]) [1..search_radius])+ (mapM (\x -> liftM (+start_x) $ getRandomR (-x,x)) [1..search_radius])+ (mapM (\x -> liftM (+start_y) $ getRandomR (-x,x)) [1..search_radius]) terrain <- liftM plane_terrain $ dbGetPlane plane_ref- clutter_locations <- locationsOf $ dbGetContents plane_ref+ (clutter_locations :: [MultiPosition]) <- locationsOf $ dbGetContents plane_ref let terrainIsClear (Position (x,y)) = all terrainPredicate $ concat [[gridAt terrain (x',y') | x' <- [x-terrain_clear..x+terrain_clear]] | y' <- [y-terrain_clear..y+terrain_clear]]- let clutterIsClear (Position (x,y)) = not $ any (\(Position (x',y')) -> abs (x' - x) <= object_clear && y' - y <= object_clear) clutter_locations- maybe (pickRandomClearSite (search_radius + 1) - object_clear - (max 0 $ terrain_clear - 1) - (Position (start_x,start_y))- terrainPredicate- plane_ref) - return $- find (\p -> terrainIsClear p && clutterIsClear p) xys+ let clutterIsClear here = not $ any (\p -> distanceBetweenChessboard here p <= object_clear) clutter_locations+ let m_result = find (\p -> terrainIsClear p && clutterIsClear p) xys+ case m_result of+ Just result -> return $ Just result+ Nothing -> pickRandomClearSite_withTimeout+ (fmap (subtract 1) timeout)+ (search_radius*2 + 1) + object_clear + (max 0 $ terrain_clear - 1) + (Position (start_x,start_y))+ terrainPredicate+ plane_ref++terrainAt :: (DBReadable db) => PlaneRef -> Position -> db TerrainPatch+terrainAt plane_ref (Position (x,y)) =+ do terrain <- liftM plane_terrain $ dbGetPlane plane_ref+ return $ gridAt terrain (x,y)++setTerrainAt :: PlaneRef -> Position -> TerrainPatch -> DB ()+setTerrainAt plane_ref (Position pos) patch = dbModPlane (\p -> p { plane_terrain = specificReplaceGrid pos patch $ plane_terrain p }) plane_ref++-- | Lists all of the entities that are on a specific spot, not including nested entities.+-- Typically this is zero or one creatures, and zero or more tools.+whatIsOccupying :: (DBReadable db,GenericReference a S) => PlaneRef -> Position -> db [a]+whatIsOccupying plane_ref position =+ liftM (mapMaybe fromLocation . filter ((== 0) . (distanceBetweenChessboard position) . location) . map (asLocationTyped _nullary _multiposition)) $ dbGetContents plane_ref++-- | Answers True iff a creature may walk or swim or drop objects at the position. +-- Lava is considered passable, but trees are not.+isTerrainPassable :: (DBReadable db) => PlaneRef -> CreatureRef -> Position -> db Bool+isTerrainPassable plane_ref creature_ref position = + do (critters :: [Either BuildingRef CreatureRef]) <- liftM (filter (=/= creature_ref)) $ whatIsOccupying plane_ref position+ terrain <- terrainAt plane_ref position+ return $ not (terrain `elem` [RockFace,Forest,DeepForest]) && null critters++getBiome :: (DBReadable db) => PlaneRef -> db Biome+getBiome = liftM plane_biome . dbGetPlane
src/PlaneData.hs view
@@ -4,7 +4,11 @@ where import TerrainData+import qualified Data.ByteString.Char8 as B data Plane = Plane- { plane_terrain :: TerrainMap }+ { plane_biome :: Biome,+ plane_terrain :: TerrainGrid,+ plane_random_id :: Integer,+ plane_planet_name :: B.ByteString } deriving (Read,Show)
src/PlaneVisibility.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, FlexibleContexts #-}+{-# LANGUAGE PatternGuards, FlexibleContexts, ScopedTypeVariables, RankNTypes #-} module PlaneVisibility (dbGetVisibleTerrainForFaction,@@ -12,17 +12,19 @@ import PlaneData import Control.Monad import CreatureData-import Data.Maybe import Data.List import Grids import GridRayCaster import VisibilityData import Facing import Data.Ratio+import Building+import Position+import Control.Applicative dbGetSeersForFaction :: (DBReadable db) => Faction -> PlaneRef -> db [CreatureRef] dbGetSeersForFaction faction plane_ref = - filterRO (filterByFaction faction) =<< dbGetContents plane_ref+ filterM (filterByFaction faction) =<< dbGetContents plane_ref -- | -- Returns a list of all terrain patches that are visible to any creature belonging@@ -39,7 +41,7 @@ -- dbGetVisibleTerrainForCreature :: (DBReadable db) => CreatureRef -> db [(TerrainPatch,Position)] dbGetVisibleTerrainForCreature creature_ref =- do loc <- liftM (fmap location) $ getPlanarLocation creature_ref+ do loc <- liftM (fmap location) $ getPlanarPosition creature_ref spot_check <- dbGetSpotCheck creature_ref case loc of Just (plane_ref,creature_at) -> liftM (visibleTerrain creature_at spot_check . plane_terrain) $ dbGetPlane plane_ref@@ -47,61 +49,65 @@ -- | -- Returns a list of all objects that are visible to any creature belonging--- to the specified faction on the specified plane.+-- to the specified faction on the specified plane. Accepts a filter to+-- determine what kinds of objects will be tested.. ---dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => Faction -> PlaneRef -> db [a]-dbGetVisibleObjectsForFaction faction plane_ref =+dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> Faction -> PlaneRef -> db [a]+dbGetVisibleObjectsForFaction filterF faction plane_ref = do critters <- dbGetSeersForFaction faction plane_ref- liftM (nubBy (=:=) . concat) $ mapM dbGetVisibleObjectsForCreature critters+ liftM (nubBy (=:=) . concat) $ mapRO (dbGetVisibleObjectsForCreature filterF) critters -- | -- Returns a list of all objects that are visible to the specified creature.+-- Accepts a filter to determine what kinds of objects will be tested. ---dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => CreatureRef -> db [a]-dbGetVisibleObjectsForCreature creature_ref =- do loc <- liftM (fmap location) $ getPlanarLocation creature_ref+dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> CreatureRef -> db [a]+dbGetVisibleObjectsForCreature filterF creature_ref =+ do (loc :: Maybe PlaneRef) <- liftM (fmap location) $ getPlanarPosition creature_ref case loc of- Just (plane_ref,_) -> filterRO (dbIsPlanarVisibleTo creature_ref . generalizeReference) =<< dbGetContents plane_ref+ Just plane_ref -> filterRO (\a -> (&&) <$> filterF a <*> (dbIsPlanarVisible creature_ref $ generalizeReference a)) =<< dbGetContents plane_ref Nothing -> return [] -- |--- dbIsPlanarVisibleTo (a creature) (some object) is true if the creature can see the object.+-- dbIsPlanarVisible (a creature) (some object) is true if the creature can see the object. ---dbIsPlanarVisibleTo :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool-dbIsPlanarVisibleTo creature_ref obj_ref | creature_ref =:= obj_ref = return True-dbIsPlanarVisibleTo creature_ref obj_ref =- do creature_loc <- liftM (fmap location) $ getPlanarLocation creature_ref- obj_loc <- liftM (fmap location) $ getPlanarLocation obj_ref+dbIsPlanarVisible :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool+dbIsPlanarVisible creature_ref obj_ref | creature_ref =:= obj_ref = return True+dbIsPlanarVisible creature_ref obj_ref =+ do (creature_loc :: Maybe (PlaneRef,Position)) <- liftM (fmap location) $ getPlanarPosition creature_ref+ (obj_loc :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap location) $ getPlanarPosition obj_ref spot_check <- dbGetOpposedSpotCheck creature_ref obj_ref case (creature_loc,obj_loc) of (Nothing,_) -> return False (_,Nothing) -> return False (Just (c_plane,_),Just (o_plane,_)) | c_plane /= o_plane -> return False --never see objects on different planes- (Just (_,Position (cx,cy)),Just (_,Position (ox,oy))) | abs (cx-ox) <= 1 && abs (cy-oy) <= 1 -> return True --automatically see 8-adjacent objects- (Just (_,Position (cx,cy)),Just (_,Position (ox,oy))) | (ox-cx)^2+(oy-cy)^2 > (maximumRangeForSpotCheck spot_check)^2 -> return False --cull objects that are too far away to ever be seen- (Just (c_plane,Position (cx,cy)),Just (_,Position (ox,oy))) -> - do let delta_at = (ox-cx,oy-cy)- terrain <- liftM plane_terrain $ dbGetPlane c_plane -- falling through all other tests, cast a ray for visibility- return $ castRay (cx,cy) (ox,oy) (spot_check - distanceCostForSight Here delta_at) (terrainOpacity . gridAt terrain)+ (Just (_,cp),Just (_,ops)) | distanceBetweenChessboard cp ops <= 1 -> return True --automatically see 8-adjacent objects+ (Just (_,cp),Just (_,ops)) | distanceBetweenSquared cp ops > (maximumRangeForSpotCheck spot_check)^2 -> return False --cull objects that are too far away to ever be seen+ (Just (c_plane,cp),Just (_,ops)) -> liftM or $ forM (positionPairs cp ops) $ + \(Position (cx,cy),Position (ox,oy)) ->+ do let delta_at = (ox-cx,oy-cy)+ terrain <- liftM plane_terrain $ dbGetPlane c_plane -- falling through all other tests, cast a ray for visibility+ return $ castRay (cx,cy) (ox,oy) (spot_check - distanceCostForSight Here delta_at) (terrainOpacity . gridAt terrain) dbGetOpposedSpotCheck :: (DBReadable db) => CreatureRef -> Reference a -> db Integer dbGetOpposedSpotCheck creature_ref object_ref = do spot <- dbGetSpotCheck creature_ref hide <- dbGetHideCheck object_ref- return $ spot * (round $ min 1 $ spot % hide)+ return $ round $ (spot%1) * opposedLinearPowerRatio spot hide dbGetSpotCheck :: (DBReadable db) => CreatureRef -> db Integer-dbGetSpotCheck creature_ref = liftM (creatureScore Spot) $ dbGetCreature creature_ref+dbGetSpotCheck creature_ref = liftM (creatureAbilityScore SpotSkill) $ dbGetCreature creature_ref dbGetHideCheck :: (DBReadable db) => Reference a -> db Integer-dbGetHideCheck ref | Just creature_ref <- coerceReferenceTyped _creature ref = liftM (creatureScore Hide) $ dbGetCreature creature_ref-dbGetHideCheck _ = return 1+dbGetHideCheck ref | Just creature_ref <- coerceReferenceTyped _creature ref = liftM (creatureAbilityScore HideSkill) $ dbGetCreature creature_ref+dbGetHideCheck ref | Just building_ref <- coerceReferenceTyped _building ref = liftM negate $ buildingSize building_ref+dbGetHideCheck _ | otherwise = return 1 -- | -- visibleTerrain (creature's location) (spot check) (the terrain map) gives -- a list of visible terrain patches from that location with that spot check. ---visibleTerrain :: Position -> Integer -> TerrainMap -> [(TerrainPatch,Position)]+visibleTerrain :: Position -> Integer -> TerrainGrid -> [(TerrainPatch,Position)] visibleTerrain (Position (creature_at@(creature_x,creature_y))) spot_check terrain = let max_range = maximumRangeForSpotCheck spot_check in map (\(x,y) -> (gridAt terrain (x,y),Position (x,y))) $
src/Position.hs view
@@ -1,18 +1,65 @@ module Position (Position(..),+ MultiPosition,+ multiPosition,+ PositionType(..), distanceBetweenSquared, distanceBetweenChessboard,- offsetPosition)+ positionPairs) where +import Data.List+import qualified Data.Set as Set++-- | Position of an object in \"chessboard space\". newtype Position = Position { fromPosition :: (Integer,Integer) } deriving (Eq,Ord,Read,Show) -offsetPosition :: (Integer,Integer) -> Position -> Position-offsetPosition (x,y) (Position (u,v)) = Position (x+u,y+v)+-- | For objects, such as buildings, that occupy multiple positions.+newtype MultiPosition = MultiPosition { fromMultiPosition :: [Position] } -distanceBetweenSquared :: Position -> Position -> Integer-distanceBetweenSquared (Position (x,y)) (Position (u,v)) = (x - u)^2 + (y - v)^2+instance Eq MultiPosition where+ (==) (MultiPosition as) (MultiPosition bs) = Set.fromList as == Set.fromList bs -distanceBetweenChessboard :: Position -> Position -> Integer-distanceBetweenChessboard (Position (x,y)) (Position (u,v)) = max (abs $ u - x) (abs $ v - y)+instance Ord MultiPosition where+ compare (MultiPosition as) (MultiPosition bs) = Set.fromList as `compare` Set.fromList bs++class PositionType p where+ toMultiPosition :: p -> MultiPosition+ offsetPosition :: (Integer,Integer) -> p -> p++instance PositionType Position where+ toMultiPosition p = MultiPosition [p]+ offsetPosition (x,y) (Position (u,v)) = Position (x+u,y+v)++instance PositionType MultiPosition where+ toMultiPosition = id+ offsetPosition xy (MultiPosition ps) = MultiPosition $ map (offsetPosition xy) ps++-- | Construct a 'MultiPosition' from a base position and a list of offsets.+-- The base position always counts as part of the MultiPosition.+multiPosition :: Position -> [(Integer,Integer)] -> MultiPosition+multiPosition (Position xy) xys = MultiPosition $ nub $ Position xy : map (offsetPosition xy . Position) xys++-- | Pythagorean distance, squared.+-- For multi-positions, measures the minimal distance.+distanceBetweenSquared :: (PositionType a,PositionType b) => a -> b -> Integer+distanceBetweenSquared as bs = minimum $+ do Position (x,y) <- fromMultiPosition $ toMultiPosition as+ Position (u,v) <- fromMultiPosition $ toMultiPosition bs+ return $ (x - u)^2 + (y - v)^2++-- | Number of squares you would have to move (as a queen on a chessboard) to arrive from the first position to the second.+-- For multi-positions, measures the minimal distance.+distanceBetweenChessboard :: (PositionType a,PositionType b) => a -> b -> Integer+distanceBetweenChessboard as bs = minimum $+ do Position (x,y) <- fromMultiPosition $ toMultiPosition as+ Position (u,v) <- fromMultiPosition $ toMultiPosition bs+ return $ max (abs $ u - x) (abs $ v - y)++-- | List all pairs of positions between two MutiPositions.+positionPairs :: (PositionType a,PositionType b) => a -> b -> [(Position,Position)]+positionPairs as bs = + do a <- fromMultiPosition $ toMultiPosition as+ b <- fromMultiPosition $ toMultiPosition bs+ return (a,b)
src/Protocol.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification, PatternSignatures #-}+{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, OverloadedStrings #-} module Protocol (mainLoop)@@ -9,41 +9,120 @@ import CreatureData import Creature import Character-import StatsData import DB-import DBData import System.Exit-import Races import System.IO import BeginGame import Data.Maybe import Plane+import PlaneData+import Building+import BuildingData import Tool import FactionData import PlaneVisibility import Facing import ToolData import Control.Monad.Error-import Numeric import Turns-import Data.IORef+import SpeciesData+import Species+import Data.Ord+import Combat+import Substances+import PlayerState+import Make+import Control.Concurrent+import Control.Monad.STM+import Control.Concurrent.STM.TVar+import Control.Exception+import WorkCluster+import qualified Data.ByteString.Char8 as B+import qualified Perception -- Don't call dbBehave, use dbPerformPlayerTurn import Behavior hiding (dbBehave) -- We need to construct References based on UIDs, so we cheat a little:-import DBPrivate (Reference(..))+import DBPrivate (Reference(ToolRef)) mainLoop :: DB_BaseType -> IO ()-mainLoop db0 = - do db <- newIORef db0- forever $- do next_command <- getLine- writeIORef db =<< ioDispatch (words $ map toLower next_command) =<< readIORef db- putStrLn "over"- hFlush stdout+mainLoop db_init = + do db_var <- newMVar db_init+ input_chan <- newChan+ output_chan <- newChan+ query_count <- newTVarIO (Just 0) -- Just (the number of running queries) or Nothing (a non-query action is in progress)+ wait_quit <- newEmptyMVar+ work_cluster <- newWorkCluster+ replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var+ let foreverLoopThenQuit = flip finally (putMVar wait_quit ()) . forever+ _ <- forkIO $ foreverLoopThenQuit $ writeChan input_chan =<< B.getLine+ _ <- forkIO $ foreverLoopThenQuit $+ do next_line <- liftM (B.map toLower . B.unlines . B.lines) (readChan output_chan)+ when (B.length next_line > 0) $+ do B.putStrLn next_line+ B.putStrLn "over"+ hFlush stdout+ _ <- forkIO $ foreverLoopThenQuit $+ do next_command <- readChan input_chan+ case (B.words $ B.map toLower next_command) of+ ["quit"] -> exitWith ExitSuccess+ ["reset"] -> stopping query_count $ modifyMVar_ db_var (const $ return initial_db)+ ("game":"query":args) -> + do querrying query_count $+ do result <- workRequest work_cluster (Query, args)+ complete Nothing output_chan result+ ("game":"action":args) ->+ do result <- workRequest work_cluster (Action, args)+ stopping query_count $ complete (Just db_var) output_chan result+ querrying query_count $ complete Nothing output_chan result -- print the result as a query, this will ensure errors get printed+ replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var+ ("noop":_) -> return ()+ failed -> + do _ <- forkIO $ complete Nothing output_chan $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ B.unpack (B.unwords failed) ++ "`"+ return ()+ takeMVar wait_quit -- "park" the main function -done :: DB String-done = return "done"+-- | Evaluate a 'GameDirective' and return it from a remote thread via an 'MVar'.+evaluateGame :: DB_BaseType -> WorkRequest -> IO WorkResult+evaluateGame db0 (Query, ["snapshot"]) = (runDB $ ro $ liftM (\b -> "answer: snapshot " `B.append` if b then "yes" else "no") dbHasSnapshot) db0+evaluateGame db0 (Query, args) = (runDB $ ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0+evaluateGame db0 (Action, args) = runDB (liftM (const "") $ dbDispatchAction args) db0 +-- | Wait for currently running queries to finish, and stop processing incomming queries while we mutate the database.+stopping :: TVar (Maybe Integer) -> IO () -> IO ()+stopping query_count actionM = bracket+ (atomically $ do maybe retry (\x -> when (x /= 0) retry) =<< readTVar query_count+ writeTVar query_count $ Nothing)+ (const $ atomically $ writeTVar query_count (Just 0))+ (const actionM)++-- | Process a querry concurrently with other queries.+querrying :: TVar (Maybe Integer) -> IO () -> IO ()+querrying query_count actionM =+ do atomically $ writeTVar query_count =<< liftM Just . (maybe retry $ return . (+1)) =<< readTVar query_count+ _ <- forkIO $ finally (atomically $ do writeTVar query_count =<< liftM (fmap (subtract 1)) (readTVar query_count)) actionM+ return ()++-- | Complete a querry or action. If a database variable is provided, it will be modified according to the result of the action.+-- The result of the action will be printed to the output_chan.+complete :: Maybe (MVar DB_BaseType) -> Chan B.ByteString -> Either DBError (B.ByteString,DB_BaseType) -> IO ()+complete m_db_var output_chan result =+ do case m_db_var of+ Just db_var -> + do modifyMVar_ db_var $ \db0 -> return $ case result of+ Right (_,db1) -> db1+ Left (DBErrorFlag errflag) -> db0 { db_error_flag = show errflag }+ Left (DBError _) -> db0+ writeChan output_chan "done"+ Nothing ->+ do case result of+ Right (outstr,_) ->+ do _ <- evaluate outstr+ writeChan output_chan outstr+ Left (DBErrorFlag _) -> return () -- client will query this explicitly (if it cares)+ Left (DBError errstr) ->+ do writeChan output_chan $ "error: " `B.append` B.pack errstr+ B.hPutStrLn stderr $ "DBError: " `B.append` B.pack errstr+ dbOldestSnapshotOnly :: (DBReadable db) => db () dbOldestSnapshotOnly = do b <- dbHasSnapshot@@ -53,199 +132,266 @@ -- Perform an action assuming the database is in the DBRaceSelectionState, -- otherwise returns an error message. ---dbRequiresRaceSelectionState :: (DBReadable db) => db String -> db String+dbRequiresRaceSelectionState :: (DBReadable db) => db a -> db a dbRequiresRaceSelectionState action = do dbOldestSnapshotOnly state <- playerState case state of RaceSelectionState -> action- _ -> return $ "protocol-error: not in race selection state (" ++ show state ++ ")"+ _ -> throwError $ DBError $ "protocol-error: not in race selection state (" ++ show state ++ ")" -- | -- Perform an action assuming the database is in the DBClassSelectionState, -- otherwise returns an error message. ---dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db String) -> db String+dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db a) -> db a dbRequiresClassSelectionState action = do dbOldestSnapshotOnly state <- playerState case state of ClassSelectionState creature -> action creature- _ -> return $ "protocol-error: not in class selection state (" ++ show state ++ ")"+ _ -> throwError $ DBError $ "protocol-error: not in class selection state (" ++ show state ++ ")" -- | -- Perform an action that operates on the player creature (not in any context). -- The states that work for this are: ----- DBClassSelectionState--- DBPlayerCreatureTurn+-- * ClassSelectionState+-- * PlayerCreatureTurn ---dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db String) -> db String+dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db a) -> db a dbRequiresPlayerCenteredState action = do dbOldestSnapshotOnly state <- playerState case state of ClassSelectionState creature -> action creature PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref- _ -> return $ "protocol-error: not in player-centered state (" ++ show state ++ ")"+ _ -> throwError $ DBError $ "protocol-error: not in player-centered state (" ++ show state ++ ")" -- | -- Perform an action that works during any creature's turn in a planar environment. -- The states that work for this are: ----- DBPlayerCreaturePickupMode--- DBEvent+-- * PlayerCreatureTurn+-- * SnapshotEvent ---dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String+dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a dbRequiresPlanarTurnState action = do dbOldestSnapshotOnly state <- playerState- case state of- PlayerCreatureTurn creature_ref _ -> action creature_ref- SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> action attacker_ref- SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> action attacker_ref- SnapshotEvent (KilledEvent killed_ref) -> action killed_ref- _ -> return $ "protocol-error: not in planar turn state (" ++ show state ++ ")"+ maybe (throwError $ DBError $ "protocol-error: not in planar turn state (" ++ show state ++ ")") action $ creatureOf state -- | -- Perform an action that works only during a player-character's turn. -- The states that work for this are: ----- DBPlayerCreatureTurn+-- PlayerCreatureTurn ---dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String+dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a dbRequiresPlayerTurnState action = do dbOldestSnapshotOnly state <- playerState case state of PlayerCreatureTurn creature_ref _ -> action creature_ref- _ -> return $ "protocol-error: not in player turn state (" ++ show state ++ ")"--ioDispatch :: [String] -> DB_BaseType -> IO DB_BaseType--ioDispatch ["quit"] _ = exitWith ExitSuccess--ioDispatch ["reset"] _ = do putStrLn "done"- return initial_db--ioDispatch ("game":game) db0 = - do a <- case game of- ["query","snapshot"] -> runDB (ro $ liftM (\b -> "answer: snapshot " ++ if b then "yes" else "no") $ dbHasSnapshot) db0- ("query":args) -> runDB (ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0- ("action":args) -> runDB (dbDispatchAction args) db0- _ -> return $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ unwords game ++ "`"- case a of- Right (outstr,db1) -> - do putStrLn (map toLower outstr)- return db1- Left (DBErrorFlag errstr) -> - do putStrLn "done"- return $ db0 { db_error_flag = errstr }- Left (DBError errstr) -> - do putStrLn (map toLower errstr ++ "\n")- return db0--ioDispatch ("save":_) db0 = do putStrLn "engine-error: save not implemented"- return db0--ioDispatch ("load":_) db0 = do putStrLn "engine-error: load not implemented"- return db0+ _ -> throwError $ DBError $ "protocol-error: not in player turn state (" ++ show state ++ ")" -ioDispatch ("noop":_) db0 = return db0+-- |+-- For arbitrary-length menu selections, get the current index into the menu, if any.+--+menuState :: (DBReadable db) => db (Maybe Integer)+menuState = liftM menuIndex playerState -ioDispatch unknown_command db0 = do putStrLn ("protocol-error: unknown command " ++ (unwords unknown_command))- return db0+-- |+-- For arbitrary-length menu selections, modify the current index into the menu. If there is no menu index+-- in the current state, this has no effect.+--+modifyMenuState :: (Integer -> Integer) -> DB ()+modifyMenuState f_ = + do number_of_tools <- liftM genericLength toolMenuElements+ let f = (\x -> if number_of_tools == 0 then 0 else x `mod` number_of_tools) . f_+ setPlayerState . modifyMenuIndex f =<< playerState -dbDispatchQuery :: (DBReadable db) => [String] -> db String+dbDispatchQuery :: (DBReadable db) => [B.ByteString] -> db B.ByteString dbDispatchQuery ["state"] = do state <- playerState return $ case state of RaceSelectionState -> "answer: state race-selection" ClassSelectionState {} -> "answer: state class-selection" PlayerCreatureTurn _ NormalMode -> "answer: state player-turn"- PlayerCreatureTurn _ PickupMode -> "answer: state pickup"- PlayerCreatureTurn _ DropMode -> "answer: state drop"- PlayerCreatureTurn _ WieldMode -> "answer: state wield"- SnapshotEvent (AttackEvent {}) -> "answer: state attack"- SnapshotEvent (MissEvent {}) -> "answer: state miss"- SnapshotEvent (KilledEvent {}) -> "answer: state killed"+ PlayerCreatureTurn _ MoveMode -> "answer: state move"+ PlayerCreatureTurn _ (PickupMode {}) -> "answer: state pickup"+ PlayerCreatureTurn _ (DropMode {}) -> "answer: state drop"+ PlayerCreatureTurn _ (WieldMode {}) -> "answer: state wield"+ PlayerCreatureTurn _ AttackMode -> "answer: state attack"+ PlayerCreatureTurn _ FireMode -> "answer: state fire"+ PlayerCreatureTurn _ JumpMode -> "answer: state jump"+ PlayerCreatureTurn _ TurnMode -> "answer: state turn"+ PlayerCreatureTurn _ (MakeMode _ make_prep) | isFinished make_prep -> "answer: state make-finished"+ PlayerCreatureTurn _ (MakeMode _ make_prep) | needsKind make_prep -> "answer: state make-what"+ PlayerCreatureTurn _ (MakeMode {}) -> "answer: state make"+ PlayerCreatureTurn _ ClearTerrainMode -> "answer: state clear-terrain"+ SnapshotEvent (AttackEvent {}) -> "answer: state attack-event"+ SnapshotEvent (MissEvent {}) -> "answer: state miss-event"+ SnapshotEvent (KilledEvent {}) -> "answer: state killed-event"+ SnapshotEvent (WeaponOverheatsEvent {}) -> "answer: state weapon-overheats-event"+ SnapshotEvent (WeaponExplodesEvent {}) -> "answer: state weapon-explodes-event"+ SnapshotEvent (DisarmEvent {}) -> "answer: state disarm-event"+ SnapshotEvent (SunderEvent {}) -> "answer: state sunder-event"+ SnapshotEvent (TeleportEvent {}) -> "answer: state teleport-event"+ SnapshotEvent (HealEvent {}) -> "answer: state heal-event"+ SnapshotEvent (ExpendToolEvent {}) -> "answer: state expend-tool-event" GameOver -> "answer: state game-over" +dbDispatchQuery ["action-count"] =+ do n <- dbActionCount+ return $ "answer: action-count " `B.append` (B.pack $ show n)++dbDispatchQuery ["menu-state"] =+ do m_state <- menuState+ return $ case m_state of+ Nothing -> "answer: menu-state 0"+ Just state -> "answer: menu-state " `B.append` (B.pack $ show state)+ dbDispatchQuery ["who-attacks"] = do state <- playerState return $ case state of- SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " ++ (show $ toUID attacker_ref)- SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " ++ (show $ toUID attacker_ref)+ SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)+ SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)+ SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)+ SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)+ SnapshotEvent (DisarmEvent { disarm_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)+ SnapshotEvent (SunderEvent { sunder_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref) _ -> "answer: who-attacks 0" dbDispatchQuery ["who-hit"] = do state <- playerState return $ case state of- SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " ++ (show $ toUID target_ref)+ SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)+ SnapshotEvent (DisarmEvent { disarm_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)+ SnapshotEvent (SunderEvent { sunder_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref) _ -> "answer: who-hit 0" +dbDispatchQuery ["tool-used"] =+ do state <- playerState+ return $ case state of+ SnapshotEvent (ExpendToolEvent { expend_tool_event_tool = tool_ref }) -> "answer: tool-used " `B.append` (B.pack $ show $ toUID tool_ref)+ _ -> "answer: tool-used 0"+ dbDispatchQuery ["weapon-used"] = do state <- playerState return $ case state of- SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref)- SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref)+ SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)+ SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)+ SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)+ SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)+ SnapshotEvent (SunderEvent { sunder_event_source_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref) _ -> "answer: weapon-used 0" +dbDispatchQuery ["tool-hit"] =+ do state <- playerState+ return $ case state of+ SnapshotEvent (DisarmEvent { disarm_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)+ SnapshotEvent (SunderEvent { sunder_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)+ _ -> "answer: tool-hit 0"+ dbDispatchQuery ["who-killed"] = do state <- playerState return $ case state of- SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " ++ (show $ toUID killed_ref)+ SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " `B.append` (B.pack $ show $ toUID killed_ref) _ -> "answer: who-killed 0" +dbDispatchQuery ["who-event"] =+ do state <- playerState+ return $ case state of+ SnapshotEvent event -> "answer: who-event " `B.append` fromMaybe "0" (fmap (B.pack . show . toUID) $ subjectOf event)+ _ -> "answer: who-event 0"+ dbDispatchQuery ["player-races","0"] =- return ("begin-table player-races 0 name\n" ++- unlines player_race_names +++ return ("begin-table player-races 0 name\n" `B.append`+ B.unlines (map B.pack player_race_names) `B.append` "end-table") dbDispatchQuery ["visible-terrain","0"] = do maybe_plane_ref <- dbGetCurrentPlane terrain_map <- maybe (return []) (dbGetVisibleTerrainForFaction Player) maybe_plane_ref - return ("begin-table visible-terrain 0 x y terrain-type\n" ++- (unlines $ map (\(terrain_type,Position (x,y)) -> unwords [show x, show y, show terrain_type]) terrain_map) +++ return ("begin-table visible-terrain 0 x y terrain-type\n" `B.append`+ (B.unlines $ map (\(terrain_type,Position (x,y)) -> B.unwords $ map B.pack [show x, show y, show terrain_type]) terrain_map) `B.append` "end-table") +dbDispatchQuery ["who-player"] = return "answer: who-player 2"+ dbDispatchQuery ["visible-objects","0"] = do maybe_plane_ref <- dbGetCurrentPlane- (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref+ (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref table_rows <- mapM (dbObjectToTableRow . entity) objects- return ("begin-table visible-objects 0 object-unique-id x y facing\n" ++- (unlines $ table_rows) +++ return ("begin-table visible-objects 0 object-unique-id x y facing\n" `B.append`+ (B.unlines $ table_rows) `B.append` "end-table") where dbObjectToTableRow obj_ref = do l <- dbWhere obj_ref return $ case (extractLocation l,extractLocation l) of- (Just (Position (x,y)),maybe_face) -> unwords [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]+ (Just (Position (x,y)),maybe_face) -> B.unwords $ map B.pack $ [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face] _ -> "" -dbDispatchQuery ["object-details",_] = ro $+dbDispatchQuery ["object-details",uid] = ro $ do maybe_plane_ref <- dbGetCurrentPlane- (visibles :: [Reference ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref+ (visibles :: [Reference ()]) <- maybe+ (return [])+ (flip dbGetVisibleObjectsForFaction Player $ \ref ->+ do let f = (== uid) . B.pack . show . toUID+ let m_wielder = coerceReference ref+ m_wield <- maybe (return Nothing) dbGetWielded m_wielder+ return $ maybe False f m_wield || f ref)+ maybe_plane_ref let creature_refs = mapMaybe (coerceReferenceTyped _creature) visibles wielded <- liftM catMaybes $ mapM dbGetWielded creature_refs let tool_refs = mapMaybe (coerceReferenceTyped _tool) visibles ++ wielded+ let building_refs = mapMaybe (coerceReferenceTyped _building) visibles creatures <- liftM (zip creature_refs) $ mapRO dbGetCreature creature_refs- tools <- liftM (zip tool_refs)$ mapRO dbGetTool tool_refs- return $ unlines $ (map creatureToTableData creatures ++- map toolToTableData tools)- where objectTableWrapper obj_ref table_data =- ("begin-table object-details " ++- (show $ toUID obj_ref) ++- " property value\n" ++- table_data ++- "end-table")- creatureToTableData :: (CreatureRef,Creature) -> String- creatureToTableData (ref,creature) = objectTableWrapper ref $- "object-type creature\n" ++- (concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ creatureStatsData creature)- toolToTableData :: (ToolRef,Tool) -> String- toolToTableData (ref,tool) = objectTableWrapper ref $- "object-type tool\n" ++- (concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ toolData tool)+ tools <- liftM (zip tool_refs) $ mapRO dbGetTool tool_refs+ buildings <- liftM (zip building_refs) $ mapRO dbGetBuilding building_refs+ liftM B.unlines $ liftM3 (\a b c -> concat [a,b,c])+ (mapM creatureToTableData creatures)+ (mapM toolToTableData tools)+ (mapM buildingToTableData buildings)+ where objectTableWrapper :: (DBReadable db) =>+ Reference a ->+ db B.ByteString ->+ db B.ByteString+ objectTableWrapper obj_ref tableDataF =+ do table_data <- tableDataF+ return $+ "begin-table object-details " `B.append`+ (B.pack $ show $ toUID obj_ref) `B.append`+ " property value\n" `B.append`+ table_data `B.append`+ "end-table"+ creatureToTableData :: (DBReadable db) =>+ (CreatureRef,Creature) ->+ db B.ByteString+ creatureToTableData (ref,creature) = objectTableWrapper ref $+ do fac <- getCreatureFaction ref+ hp <- getCreatureAbsoluteHealth ref+ maxhp <- getCreatureMaxHealth ref+ return $+ "object-type creature\n" `B.append`+ "species " `B.append` (B.pack $ show $ creature_species creature) `B.append` "\n" `B.append`+ "random-id " `B.append` (B.pack $ show $ creature_random_id creature) `B.append` "\n" `B.append`+ "faction " `B.append` B.pack (show fac) `B.append` "\n" `B.append`+ (if fac == Player then+ "hp " `B.append` B.pack (show hp) `B.append` "\n" `B.append`+ "maxhp " `B.append` B.pack (show maxhp) `B.append` "\n"+ else "")+ toolToTableData :: (DBReadable db) => (ToolRef,Tool) -> db B.ByteString+ toolToTableData (ref,tool) = objectTableWrapper ref $ return $+ "object-type tool\n" `B.append`+ "tool-type " `B.append` toolType tool `B.append` "\n" `B.append`+ "tool " `B.append` toolName tool `B.append` "\n"+ buildingToTableData :: (DBReadable db) => (BuildingRef,Building) -> db B.ByteString+ buildingToTableData (ref,Building) = objectTableWrapper ref $+ do building_type <- buildingType ref+ return $ "object-type building\n" `B.append`+ "building-type " `B.append` B.pack (show building_type) `B.append` "\n" dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats @@ -254,32 +400,66 @@ dbDispatchQuery ["base-classes","0"] = dbRequiresClassSelectionState dbQueryBaseClasses dbDispatchQuery ["pickups","0"] = dbRequiresPlayerTurnState $ \creature_ref -> - do pickups <- dbAvailablePickups creature_ref- return $ "begin-table pickups 0 uid\n" ++- unlines (map (show . toUID) pickups) ++- "end-table"+ liftM (showToolMenuTable "pickups" "0") $ toolsToMenuTable =<< dbAvailablePickups creature_ref dbDispatchQuery ["inventory","0"] = dbRequiresPlayerTurnState $ \creature_ref ->- do (inventory :: [ToolRef]) <- dbGetContents creature_ref- return $ "begin-table inventory 0 uid\n" ++- unlines (map (show . toUID) inventory) ++- "end-table"+ liftM (showToolMenuTable "inventory" "0") $ toolsToMenuTable =<< dbGetContents creature_ref +dbDispatchQuery ["menu","0"] =+ liftM (showToolMenuTable "menu" "0") $ toolsToMenuTable =<< toolMenuElements++dbDispatchQuery ["menu",s] | Just window_size <- readNumber s =+ do n <- liftM (fromMaybe 0) menuState+ let half_window = window_size `div` 2+ let windowF (x,_,_) = abs (x - (max half_window n)) <= half_window+ liftM (showToolMenuTable "menu" s . filter windowF) $ toolsToMenuTable =<< toolMenuElements+ dbDispatchQuery ["wielded-objects","0"] = do m_plane_ref <- dbGetCurrentPlane- creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction Player) m_plane_ref+ creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) m_plane_ref wielded_tool_refs <- mapM dbGetWielded creature_refs- let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe String- wieldedPairToTable creature_ref = fmap (\tool_ref -> (show $ toUID tool_ref) ++ " " ++ (show $ toUID creature_ref))- return $ "begin-table wielded-objects 0 uid creature\n" ++- unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) +++ let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe B.ByteString+ wieldedPairToTable creature_ref = fmap (\tool_ref -> (B.pack $ show $ toUID tool_ref) `B.append` " " `B.append` (B.pack $ show $ toUID creature_ref))+ return $ "begin-table wielded-objects 0 uid creature\n" `B.append`+ B.unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) `B.append` "end-table" -dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" ++ unwords unrecognized ++ "`"+dbDispatchQuery ["biome"] =+ do m_plane_ref <- dbGetCurrentPlane+ biome_name <- case m_plane_ref of+ Nothing -> return "nothing"+ Just plane_ref -> liftM (show . plane_biome) $ dbGetPlane plane_ref+ return $ "answer: biome " `B.append` B.pack biome_name -dbDispatchAction :: [String] -> DB String-dbDispatchAction ["continue"] = dbPopOldestSnapshot >> done+dbDispatchQuery ["current-plane"] =+ do m_plane_ref <- dbGetCurrentPlane+ return $ case m_plane_ref of+ Nothing -> "answer: current-plane 0"+ Just plane_ref -> "answer: current-plane " `B.append` (B.pack $ show $ toUID plane_ref) +dbDispatchQuery ["plane-random-id"] =+ do m_plane_ref <- dbGetCurrentPlane+ case m_plane_ref of+ Nothing -> return "answer: plane-random-id 0"+ Just plane_ref -> liftM (("answer: plane-random-id " `B.append`) . B.pack . show . plane_random_id) $ dbGetPlane plane_ref++dbDispatchQuery ["planet-name"] =+ do m_plane_ref <- dbGetCurrentPlane+ case m_plane_ref of+ Nothing -> return "answer: planet-name nothing"+ Just plane_ref -> liftM ("answer: planet-name " `B.append`) $ planetName plane_ref++dbDispatchQuery ["compass"] =+ do m_player_ref <- getCurrentCreature Player+ case m_player_ref of+ Nothing -> return "answer: compass nothing"+ Just player_ref -> Perception.runPerception player_ref $ liftM (("answer: compass " `B.append`) . B.pack . show) Perception.compass++dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" `B.append` B.unwords unrecognized `B.append` "`"++dbDispatchAction :: [B.ByteString] -> DB ()+dbDispatchAction ["continue"] = dbPopOldestSnapshot+ dbDispatchAction ["select-race",race_name] = dbRequiresRaceSelectionState $ dbSelectPlayerRace race_name @@ -289,149 +469,272 @@ dbDispatchAction ["select-class",class_name] = dbRequiresClassSelectionState $ dbSelectPlayerClass class_name +dbDispatchAction [direction] | isJust $ stringToFacing direction =+ do state <- playerState+ case state of+ PlayerCreatureTurn _ player_mode -> case player_mode of+ JumpMode -> dbDispatchAction ["jump",direction]+ TurnMode -> dbDispatchAction ["turn",direction]+ AttackMode -> dbDispatchAction ["attack",direction]+ FireMode -> dbDispatchAction ["fire",direction]+ MoveMode -> dbDispatchAction ["move",direction]+ ClearTerrainMode -> dbDispatchAction ["clear-terrain",direction]+ _ -> dbDispatchAction ["normal",direction]+ _ -> throwError $ DBError $ "protocol-error: not in player turn state"++dbDispatchAction ["normal"] =+ dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref NormalMode)++dbDispatchAction ["normal",direction] | Just face <- stringToFacing direction =+ dbRequiresPlayerTurnState $ \creature_ref -> + do behavior <- facingBehavior creature_ref face+ dbPerformPlayerTurn behavior creature_ref++dbDispatchAction ["move"] =+ dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref MoveMode)+ dbDispatchAction ["move",direction] | isJust $ stringToFacing direction =- dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref >> done)+ dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref) +dbDispatchAction ["jump"] =+ dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref JumpMode)++dbDispatchAction ["jump",direction] | isJust $ stringToFacing direction =+ dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Behavior.Jump $ fromJust $ stringToFacing direction) creature_ref)++dbDispatchAction ["turn"] =+ dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref TurnMode)+ dbDispatchAction ["turn",direction] | isJust $ stringToFacing direction =- dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref >> done)+ dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref +dbDispatchAction ["clear-terrain"] =+ dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref ClearTerrainMode)++dbDispatchAction ["clear-terrain",direction] | isJust $ stringToFacing direction =+ dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (ClearTerrain $ fromJust $ stringToFacing direction) creature_ref++dbDispatchAction ["next"] = modifyMenuState (+1)++dbDispatchAction ["prev"] = modifyMenuState (subtract 1)++dbDispatchAction ["select-menu"] =+ do state <- playerState+ i <- menuState+ tool_table <- toolsToMenuTable =<< toolMenuElements+ let selection = maybe "0" (\(_,tool_ref,_) -> B.pack $ show $ toUID tool_ref) $ find (\(n,_,_) -> Just n == i) tool_table+ case state of+ PlayerCreatureTurn _ player_mode -> case player_mode of+ PickupMode {} -> dbDispatchAction ["pickup",selection]+ DropMode {} -> dbDispatchAction ["drop",selection]+ WieldMode {} -> dbDispatchAction ["wield",selection]+ MakeMode {} -> dbDispatchAction ["make-with",selection]+ _ -> throwError $ DBError $ "protocol-error: not in menu selection state"+ _ -> throwError $ DBError $ "protocol-error: not in player turn state"++dbDispatchAction ["make-begin"] = dbRequiresPlayerTurnState $ \creature_ref ->+ setPlayerState (PlayerCreatureTurn creature_ref (MakeMode 0 prepare_make))++dbDispatchAction ["make-what",what] | (Just device_kind) <- readDeviceKind what =+ do state <- playerState+ case state of+ PlayerCreatureTurn c (MakeMode n make_prep) -> (setPlayerState $ PlayerCreatureTurn c $ MakeMode n (make_prep `makeWith` device_kind))+ _ -> throwError $ DBError $ "protocol-error: not in make or make-what state"++dbDispatchAction ["make-with",tool_uid] =+ do tool_ref <- readUID ToolRef tool_uid+ tool <- dbGetTool tool_ref+ state <- playerState+ case state of+ PlayerCreatureTurn c (MakeMode _ make_prep) -> case (hasChromalite tool, hasMaterial tool, hasGas tool) of+ (Just ch,_,_) | needsChromalite make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (ch,tool_ref))+ (_,Just m,_) | needsMaterial make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (m,tool_ref))+ (_,_,Just g) | needsGas make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (g,tool_ref))+ _ | otherwise -> throwError $ DBError "error: tool doesn't have needed substance"+ _ -> throwError $ DBError "protocol-error: not in make or make-what state"++dbDispatchAction ["make-end"] =+ do state <- playerState+ case state of+ PlayerCreatureTurn c (MakeMode _ make_prep) | isFinished make_prep -> dbPerformPlayerTurn (Make make_prep) c+ PlayerCreatureTurn _ (MakeMode {}) -> throwError $ DBError "protocol-error: make isn't complete"+ _ -> throwError $ DBError "protocol-error: not in make or make-what state"+ dbDispatchAction ["pickup"] = dbRequiresPlayerTurnState $ \creature_ref -> do pickups <- dbAvailablePickups creature_ref case pickups of [tool_ref] -> dbPerformPlayerTurn (Pickup tool_ref) creature_ref >> return ()- [] -> throwError $ DBErrorFlag "nothing-there"- _ -> setPlayerState (PlayerCreatureTurn creature_ref PickupMode)- done+ [] -> throwError $ DBErrorFlag NothingAtFeet+ _ -> setPlayerState (PlayerCreatureTurn creature_ref (PickupMode 0)) dbDispatchAction ["pickup",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref -> do tool_ref <- readUID ToolRef tool_uid dbPerformPlayerTurn (Pickup tool_ref) creature_ref- done dbDispatchAction ["drop"] = dbRequiresPlayerTurnState $ \creature_ref -> do inventory <- dbGetContents creature_ref case inventory of [tool_ref] -> dbPerformPlayerTurn (Drop tool_ref) creature_ref >> return ()- [] -> throwError $ DBErrorFlag "nothing-in-inventory"- _ -> setPlayerState (PlayerCreatureTurn creature_ref DropMode)- done+ [] -> throwError $ DBErrorFlag NothingInInventory+ _ -> setPlayerState (PlayerCreatureTurn creature_ref (DropMode 0)) dbDispatchAction ["drop",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref -> do tool_ref <- readUID ToolRef tool_uid dbPerformPlayerTurn (Drop tool_ref) creature_ref- done dbDispatchAction ["wield"] = dbRequiresPlayerTurnState $ \creature_ref ->- do inventory <- dbGetContents creature_ref- case inventory of+ do available <- availableWields creature_ref+ case available of [tool_ref] -> dbPerformPlayerTurn (Wield tool_ref) creature_ref >> return ()- [] -> throwError $ DBErrorFlag "nothing-in-inventory"- _ -> setPlayerState (PlayerCreatureTurn creature_ref WieldMode)- done+ [] -> throwError $ DBErrorFlag NothingInInventory+ _ -> setPlayerState (PlayerCreatureTurn creature_ref (WieldMode 0)) dbDispatchAction ["wield",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref -> do tool_ref <- readUID ToolRef tool_uid dbPerformPlayerTurn (Wield tool_ref) creature_ref- done -dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref >> done +dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref -dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref >> done+dbDispatchAction ["fire"] =+ dbRequiresPlayerTurnState $ \creature_ref -> rangedAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref FireMode) -dbDispatchAction unrecognized = return ("protocol-error: unrecognized action `" ++ (unwords unrecognized) ++ "`")+dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref -dbSelectPlayerRace :: String -> DB String-dbSelectPlayerRace race_name = case (selectPlayerRace race_name)- of- Nothing -> return ("protocol-error: unrecognized race '" ++ race_name ++ "'")- Just species -> do dbGenerateInitialPlayerCreature species- done+dbDispatchAction ["attack"] =+ dbRequiresPlayerTurnState $ \creature_ref -> meleeAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref AttackMode) -dbSelectPlayerClass :: String -> Creature -> DB String+dbDispatchAction ["attack",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Attack $ fromJust $ stringToFacing direction) creature_ref++dbDispatchAction ["activate"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Activate creature_ref++dbDispatchAction unrecognized = throwError $ DBError $ ("protocol-error: unrecognized action `" ++ (B.unpack $ B.unwords unrecognized) ++ "`")++dbSelectPlayerRace :: B.ByteString -> DB ()+dbSelectPlayerRace race_name = + case find (\s -> B.map toLower (B.pack $ show s) == race_name) player_species of+ Nothing -> throwError $ DBError $ "protocol-error: unrecognized race '" ++ B.unpack race_name ++ "'"+ Just species -> generateInitialPlayerCreature species++dbSelectPlayerClass :: B.ByteString -> Creature -> DB () dbSelectPlayerClass class_name creature = let eligable_base_classes = getEligableBaseCharacterClasses creature- in case find (\x -> (map toLower . show) x == class_name) eligable_base_classes of- Nothing -> return ("protocol-error: unrecognized or invalid class '" ++ class_name ++ "'")- Just the_class -> do dbBeginGame creature the_class- done+ in case find (\x -> (B.map toLower . B.pack . show) x == class_name) eligable_base_classes of+ Nothing -> throwError $ DBError $ "protocol-error: unrecognized or invalid class '" ++ B.unpack class_name ++ "'"+ Just the_class -> dbBeginGame creature the_class -dbRerollRace :: Creature -> DB String+dbRerollRace :: Creature -> DB () dbRerollRace _ = do starting_race <- dbGetStartingRace- dbGenerateInitialPlayerCreature $ fromJust starting_race- done+ generateInitialPlayerCreature $ fromJust starting_race -dbQueryPlayerStats :: (DBReadable db) => Creature -> db String+dbQueryPlayerStats :: (DBReadable db) => Creature -> db B.ByteString dbQueryPlayerStats creature = return $ playerStatsTable creature -- |--- Information about player creatures (for which the player should have almost all available information.)+-- Generate a list of tools, e.g. for an inventory list or pickup list.+-- The data source is selected on a context-sensitive basis. ---playerStatsTable :: Creature -> String-playerStatsTable c =- "begin-table player-stats 0 property value\n" ++- "str " ++ (show $ str c) ++ "\n" ++- "dex " ++ (show $ dex c) ++ "\n" ++- "con " ++ (show $ con c) ++ "\n" ++- "int " ++ (show $ int c) ++ "\n" ++- "per " ++ (show $ per c) ++ "\n" ++- "cha " ++ (show $ cha c) ++ "\n" ++- "mind " ++ (show $ mind c) ++ "\n" ++- "hp " ++ (show $ creatureScore HitPoints c) ++ "\n" ++- "maxhp " ++ (show $ creatureScore MaxHitPoints c) ++ "\n" ++- "species " ++ (creature_species_name c) ++ "\n" ++- "random-id " ++ (show $ creature_random_id c) ++ "\n" ++- "effective-level " ++ (show $ creatureScore EffectiveLevel c) ++ "\n" ++- "gender " ++ (show $ creatureGender c) ++ "\n" ++- "end-table"+toolMenuElements :: (DBReadable db) => db [ToolRef]+toolMenuElements =+ do state <- playerState+ case state of+ PlayerCreatureTurn c (PickupMode {}) -> dbAvailablePickups c+ PlayerCreatureTurn c (WieldMode {}) -> availableWields c+ PlayerCreatureTurn c (MakeMode _ make_prep) | needsChromalite make_prep -> filterM (liftM (isJust . hasChromalite) . dbGetTool) =<< availableWields c+ PlayerCreatureTurn c (MakeMode _ make_prep) | needsMaterial make_prep -> filterM (liftM (isJust . hasMaterial) . dbGetTool) =<< availableWields c+ PlayerCreatureTurn c (MakeMode _ make_prep) | needsGas make_prep -> filterM (liftM (isJust . hasGas) . dbGetTool) =<< availableWields c+ PlayerCreatureTurn c _ -> dbGetContents c+ _ -> return [] -- |--- Information about non-player creatures (for which there are very strict limits on what information--- the player can have). The result is in (Property,Value) form so that the result can easily be--- manipulated by the caller.+-- Convert a list of tool menu elements into table row entries.+-- The result entries consist of an index incrementing from zero, ToolRef, and name of the tool. ---creatureStatsData :: Creature -> [(String,String)]-creatureStatsData c = [("percent-hp",show $ (creatureScore HitPoints c * 100) `div` creatureScore MaxHitPoints c),- ("species",creature_species_name c),- ("random-id",show $ creature_random_id c)]+toolsToMenuTable :: (DBReadable db) => [ToolRef] -> db [(Integer,ToolRef,B.ByteString)]+toolsToMenuTable raw_uids =+ do let uids = sortBy (comparing toUID) raw_uids+ tool_names <- mapM (liftM toolName . dbGetTool) uids+ return $ zip3 [0..] uids tool_names -- |--- Information about non-owned tools.+-- Generate a tool menu table in text form, with the specified name and element list. ---toolData :: Tool -> [(String,String)]-toolData g@(GunTool {}) = [("tool-type","gun"),- ("tool",toolName g)]+showToolMenuTable :: B.ByteString -> B.ByteString -> [(Integer,ToolRef,B.ByteString)] -> B.ByteString+showToolMenuTable table_name table_id tool_table = + "begin-table " `B.append` table_name `B.append` " " `B.append` table_id `B.append` " n uid name" `B.append` "\n" `B.append`+ B.unlines (map (\(n,uid,tool_name) -> B.unwords [B.pack $ show n,B.pack $ show $ toUID uid,tool_name]) tool_table) `B.append`+ "end-table" -dbQueryBaseClasses :: (DBReadable db) => Creature -> db String+-- |+-- Information about player creatures (for which the player should have almost all available information.)+--+playerStatsTable :: Creature -> B.ByteString+playerStatsTable c =+ "begin-table player-stats 0 property value\n" `B.append`+ "str " `B.append` (B.pack $ show $ rawScore Strength c) `B.append` "\n" `B.append`+ "spd " `B.append` (B.pack $ show $ rawScore Speed c) `B.append` "\n" `B.append`+ "con " `B.append` (B.pack $ show $ rawScore Constitution c) `B.append` "\n" `B.append`+ "int " `B.append` (B.pack $ show $ rawScore Intellect c) `B.append` "\n" `B.append`+ "per " `B.append` (B.pack $ show $ rawScore Perception c) `B.append` "\n" `B.append`+ "cha " `B.append` (B.pack $ show $ rawScore Charisma c) `B.append` "\n" `B.append`+ "mind " `B.append` (B.pack $ show $ rawScore Mindfulness c) `B.append` "\n" `B.append`+ "maxhp " `B.append` (B.pack $ show $ creatureAbilityScore ToughnessTrait c) `B.append` "\n" `B.append`+ "species " `B.append` (B.pack $ show $ creature_species c) `B.append` "\n" `B.append`+ "random-id " `B.append` (B.pack $ show $ creature_random_id c) `B.append` "\n" `B.append`+ "gender " `B.append` (B.pack $ show $ creatureGender c) `B.append` "\n" `B.append`+ "end-table"++toolName :: Tool -> B.ByteString+toolName (DeviceTool _ d) = deviceName d+toolName (Sphere s) = prettySubstance s++toolType :: Tool -> B.ByteString+toolType (DeviceTool Gun _) = "gun"+toolType (DeviceTool Sword _) = "sword"+toolType (Sphere (GasSubstance _)) = "sphere-gas"+toolType (Sphere (MaterialSubstance _)) = "sphere-material"+toolType (Sphere (ChromaliteSubstance _)) = "sphere-chromalite"++dbQueryBaseClasses :: (DBReadable db) => Creature -> db B.ByteString dbQueryBaseClasses creature = return $ baseClassesTable creature -baseClassesTable :: Creature -> String+baseClassesTable :: Creature -> B.ByteString baseClassesTable creature = - "begin-table base-classes 0 class\n" ++- (unlines $ map show $ getEligableBaseCharacterClasses creature) +++ "begin-table base-classes 0 class\n" `B.append`+ (B.unlines $ map (B.pack . show) $ getEligableBaseCharacterClasses creature) `B.append` "end-table" -dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db String+dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db B.ByteString dbQueryCenterCoordinates creature_ref = do l <- dbWhere creature_ref case (extractLocation l,extractLocation l :: Maybe Facing) of (Just (Position (x,y)),Nothing) -> - return (begin_table ++- "x " ++ show x ++ "\n" ++- "y " ++ show y ++ "\n" +++ return (begin_table `B.append`+ "x " `B.append` B.pack (show x) `B.append` "\n" `B.append`+ "y " `B.append` B.pack (show y) `B.append` "\n" `B.append` "end-table") (Just (Position (x,y)),Just face) -> - return (begin_table ++- "x " ++ show x ++ "\n" ++- "y " ++ show y ++ "\n" ++- "facing " ++ show face ++ "\n" +++ return (begin_table `B.append`+ "x " `B.append` B.pack (show x) `B.append` "\n" `B.append`+ "y " `B.append` B.pack (show y) `B.append` "\n" `B.append`+ "facing " `B.append` B.pack (show face) `B.append` "\n" `B.append` "end-table")- _ -> return (begin_table ++ "end-table")+ _ -> return (begin_table `B.append` "end-table") where begin_table = "begin-table center-coordinates 0 axis coordinate\n" -readUID :: (Integer -> Reference a) -> String -> DB (Reference a)+readUID :: (Integer -> Reference a) -> B.ByteString -> DB (Reference a) readUID f x = - do let m_uid = fmap fst $ listToMaybe $ filter (null . snd) $ readDec x+ do let m_uid = readNumber x ok <- maybe (return False) (dbVerify . f) m_uid- when (not ok) $ throwError $ DBError $ "protocol-error: " ++ x ++ " is not a valid uid."+ when (not ok) $ throwError $ DBError $ "protocol-error: " ++ B.unpack x ++ " is not a valid uid." return $ f $ fromJust m_uid- ++readNumber :: B.ByteString -> Maybe Integer+readNumber = fmap fst . B.readInteger++readDeviceKind :: B.ByteString -> Maybe DeviceKind+readDeviceKind "pistol" = Just Pistol+readDeviceKind "carbine" = Just Carbine+readDeviceKind "rifle" = Just Rifle+readDeviceKind "fleuret" = Just Fleuret+readDeviceKind "sabre" = Just Sabre+readDeviceKind _ = Nothing
src/RNG.hs view
@@ -2,54 +2,36 @@ -- | -- Don't depend on any external source of psuedo-random numbers, because -- we want to be able to save a psuedo-random seed and know that we can--- generate the same psuedo-random sequence when we reload it.+-- generate the same psuedo-random sequence when we reload it, even across+-- different environments. -- module RNG- (randomIntegerStream,- randomIntegerStreamStream,- randomIntegerLine,- randomIntegerGrid)+ (mkRNG,+ RNG,+ Random(..),+ RandomGen(..)) where -import Data.List-import ListUtils+import System.Random+import Control.Arrow (first) --- |--- Generates the next in a sequence of psuedo-random Integers.--- These numbers should not be used raw. (Due to insufficient--- "random-ness" of the least significant bit.) Use a--- randomIntegerStream[Stream].----nextRandomSeed :: Integer -> Integer-nextRandomSeed x = (x * 0x5DEECE66D + 0xB) `mod` (2^48)+newtype RNG = RNG { rng_state :: Integer } --- |--- A stream of random integers from a seed.----randomIntegerStream :: Integer -> [Integer]-randomIntegerStream x = let nri = nextRandomSeed x- in (nri `quot` 24) : (randomIntegerStream nri)+instance RandomGen RNG where+ next g = (fromInteger $ x `quot` (2^24),RNG x)+ where x = (rng_state g * 0x5DEECE66D + 0xB) `mod` (2^48)+ split g = (mkRNG $ fromIntegral x,mkRNG $ fromIntegral y)+ where (x,g') = next g+ (y,_) = next g'+ genRange _ = (0,2^24) --- |--- A stream of random integer streams. Good when you need to do--- a lot of splitting.----randomIntegerStreamStream :: Integer -> [[Integer]]-randomIntegerStreamStream x = let nri1 = nextRandomSeed x- nri2 = nextRandomSeed nri1- in (randomIntegerStream (nri1 + 1) :- (randomIntegerStreamStream (nri2 - 1)))+instance Random RNG where+ random = first (mkRNG :: Integer -> RNG) . random+ randomR _ = random -- |--- An infinite (in both directions) sequence of random Integers, based--- on a seed.+-- Construct an RNG from a seed. ---randomIntegerLine :: Integer -> (Integer -> Integer)-randomIntegerLine seed = bidirectionalAccessor1D $ randomIntegerStream seed+mkRNG :: (Integral i) => i -> RNG+mkRNG = RNG . fromIntegral . fst . next . RNG . toInteger --- |--- An infinite (in all directions) grid of random Integers, based--- on a seed.----randomIntegerGrid :: Integer -> ((Integer,Integer) -> Integer)-randomIntegerGrid seed = bidirectionalAccessor2D $ map randomIntegerStream $ randomIntegerStream seed
− src/Races.hs
@@ -1,261 +0,0 @@--module Races- (selectPlayerRace,- player_race_names,- all_races,- allowed_player_races,- anachronid,- male_anachronid,- female_anachronid,- androsynth,- ascendant,- caduceator,- encephalon,- kraken,- goliath,- hellion,- myrmidon,- perennial,- recreant,- reptilian)- where--import Data.Char-import StatsData-import CreatureData-import CharacterData-import SpeciesData-import AttributeData-import Data.List--all_races :: [Species]-all_races = [anachronid,- androsynth,- ascendant,- caduceator,- encephalon,- goliath,- hellion,- kraken,- myrmidon,- perennial,- recreant,- reptilian]--allowed_player_races :: [Species]-allowed_player_races = [female_anachronid,- androsynth,- ascendant,- caduceator,- encephalon,- goliath,- hellion,- kraken,- myrmidon,- perennial,- recreant,- reptilian]--player_race_names :: [String]-player_race_names = map (map toLower . species_name) allowed_player_races--selectPlayerRace :: String -> Maybe Species-selectPlayerRace race_name = find - (\x -> (map toLower $ species_name x) == map toLower race_name) - allowed_player_races---- |--- Six-legged species that move through time unusually slowly, making them appear (to outsiders),--- to move very quickly. Yes, they eat their own males -- squad leaders are always female.--- Anachronids in modern times are often seen working as mercenaries and scouts for the Imperial Alliance,--- although as a species they are scattered on many worlds -- their homeworld having been destroyed--- in war with the myrmidons many centuries past.----anachronid :: Species-anachronid = Species {- averages = Stats { strength=10, dexterity=10, constitution=9, intelligence=8, perception=10, charisma=8, mindfulness=7 },- distributions = (stats 13),- attribute_generator = ([female 0.05,- AttributeAlways $ FavoredClass Barbarian,- AttributeAlways $ FavoredClass Pirate] ++ - (multipleAttribute SpeedTrait (3,5))),- species_name = "anachronid"- }--female_anachronid :: Species-female_anachronid = anachronid { attribute_generator = [female 1] ++ (attribute_generator anachronid) }--male_anachronid :: Species-male_anachronid = anachronid { attribute_generator = [male 1] ++ (attribute_generator anachronid) }---- |--- Androsynths are androids, created by the Ascendants to be their physical bodies before--- they learned to transform themselves into pure psionic energy. The Androsynths were left--- behind with all of the memories but none of the emotions of their creators. Over hundreds of--- years they developed their own civilization and culture. They have few emotions other their--- ongoing dedication to the ideals of their ancestors.----androsynth :: Species-androsynth = Species {- averages = (stats (14)) { intelligence=22, charisma=8 },- distributions = (stats 0) { intelligence=0 },- attribute_generator = ([AttributeAlways $ FavoredClass Engineer] ++- (multipleAttribute DamageReductionTrait (3,3))), --also: some resistance to kinetic energy- species_name = "androsynth"- }---- |--- This ancient race (who early in their evolution had the form of flightless birds) was known for its--- craft in the force and psionic arts. Ascendant force knights once guaranteed peace in the galaxy.--- As they evolved, their bodies were no longer able to contain their powerful psionic energies,--- and they became pure psionic life forces. It is rumored that the energy beings recognized as the--- Ascendants are actually mere shadows of what have grown into vastly powerful, almost godlike creatures--- engaged in an epic battle against evil in a dimension beyond mortal comprehension. At least, that--- theory tries to explain why they no longer work to maintain peace in the galaxy of today.------ The last of the Ascendant knights still posessing a physical form signed with the Interstellar Concordance,--- but its not clear if the Ascendants still recognize that alliance.----ascendant :: Species-ascendant = Species {- averages = Stats { strength=6, dexterity=9, constitution=9, intelligence=12, perception=9, charisma=11, mindfulness=20 },- distributions = (stats 14) { mindfulness=20 },- attribute_generator = [AttributeAlways $ FavoredClass Shepherd,- AttributeAlways $ FavoredClass ForceAdept,- male 0.45], -- also: very high resistance to kinetic,fire,cold- species_name = "ascendant"- }---- |--- This serpentine species has a unique facility with language, and in the last thousand years--- have supersceded the Ascendants as peacemakers in the galaxy. They are the founders of the--- Interstellar Concordance, but they have seen their influence wane in the face of the reptilians--- and kraken, who know how to leverage business relationships to faciliatate their political will.----caduceator :: Species-caduceator = Species {- averages = Stats { strength=9, dexterity=12, constitution=9, intelligence=8, perception=8, charisma=16, mindfulness=12 },- distributions = (stats 15),- attribute_generator = [male 0.6,- AttributeAlways $ FavoredClass Consular], -- also: vulnerability to heat and cold- species_name = "caduceator"- }--- |--- Encephalons are a sort of hyper-intelligent fungus, in fact, they are considered the most intelligent --- life forms in the galaxy, but their mobility and alertness are limited, dependant as their are on their various machine servants.----encephalon :: Species-encephalon = Species {- averages = Stats { strength=5, dexterity=5, constitution=40, intelligence=40, perception=5, charisma=5, mindfulness=5 },- distributions = (stats 15),- attribute_generator = [male 0.95,- AttributeAlways $ FavoredClass Engineer],- species_name = "encephalon"- }- - ---- |--- These are brightly colored blobs of flesh and brain with eye-stalks and six limbs.--- The Hellion homeworld is a member of the Interstellar Concordance.----hellion :: Species-hellion = Species {- averages = Stats { strength=9, dexterity=18, constitution=9, intelligence=11, perception=12, charisma=9, mindfulness=9 },- distributions = (stats 20),- attribute_generator = [AttributeAlways $ FavoredClass Scout,- AttributeAlways $ FavoredClass Marine,- AttributeAlways $ FavoredClass Thief,- AttributeAlways $ FavoredClass Pirate,- male 0.65],- species_name = "hellion"- }---- |--- Large, tough, gray aliens with big heads and big eyes that like to smash.----goliath :: Species-goliath = Species {- averages = Stats { strength=15, dexterity=9, constitution=15, intelligence=8, perception=10, charisma=6, mindfulness=7 },- distributions = (stats 14),- attribute_generator = ([male 0.55,- AttributeAlways $ FavoredClass Barbarian,- AttributeAlways $ FavoredClass Warrior,- AttributeAlways $ FavoredClass Scout] ++- (multipleAttribute ToughnessTrait (3,7))),- species_name = "goliath"- }---- |--- Aquatic species with tenticles. The kraken homeworld is the capital of the Imperial Aliance.----kraken :: Species-kraken = Species {- averages = Stats { strength=12, dexterity=12, constitution=14, intelligence=10, perception=4, charisma=14, mindfulness=10 },- distributions = (stats 12),- attribute_generator = ([male 0.5,- AttributeAlways $ FavoredClass Consular]), -- also, water survival skill- species_name = "kraken"- }---- |--- Ant-like species. An inventive species that effectively uses consensus decision making. They are--- somehow signatories to the Pan Galactic Treaty Organization even though they have no formal government.--- In ancient times members of this race were responsible for the destruction of the anachronic homeworld.----myrmidon :: Species-myrmidon = Species {- averages = Stats { strength=20, dexterity=11, constitution=9, intelligence=14, perception=8, charisma=10, mindfulness=10 },- distributions = (stats 14),- attribute_generator = [AttributeAlways $ FavoredClass Barbarian,- AttributeAlways $ FavoredClass Engineer,- AttributeAlways $ FavoredClass Warrior,- female 1],- species_name = "myrmidon"- }---- |--- Plant creatures! Mobile flowering shrubs. Although their homeword has been a member of the Pan Galactic--- Treaty Organization since shortly after it was first established, they have never as a group participated in any--- actions with that organization.----perennial :: Species-perennial = Species {- averages = Stats { strength=3, dexterity=3, constitution=11, intelligence=11, perception=9, charisma=10, mindfulness=20 },- distributions = (stats 20),- attribute_generator = ([AttributeAlways $ FavoredClass Barbarian,- AttributeAlways $ FavoredClass Consular,- AttributeAlways $ FavoredClass Shepherd,- AttributeAlways DamageReductionTrait]),- species_name = "perennial"- }---- |--- Recreants are not a single species, but a variety of different self-replicating machines left over from--- the Myrmidon-Anachronid war.----recreant :: Species-recreant = Species {- averages = (stats (6)) { strength=14, dexterity=14 },- distributions = (stats 13),- attribute_generator = ([AttributeAlways $ FavoredClass Barbarian]), -- also: resistance to every energy type escept kinetic- species_name = "recreant"- }---- |--- An adaptable, velociraptor-esque species was genetically engineered for combat in ancient times but --- today has developed a culture and unique psychology that allows them to serve as negotiators and peacemakers.--- The reptilian homeworld is a signatory planet to the Pan Galactic Treaty Organization.----reptilian :: Species-reptilian = Species {- averages = Stats { strength=11, dexterity=11, constitution=11, intelligence=6, perception=10, charisma=12, mindfulness=6 },- distributions = (stats 13),- attribute_generator = ([male 0.35,- AttributeAlways $ FavoredClass Warrior,- AttributeAlways $ FavoredClass Consular] ++- (multipleAttribute ToughnessTrait (2,3)) ++- (multipleAttribute SpeedTrait (0,2)) ++- (multipleAttribute MeleeAttackSkill (2,5))), -- also: vulnerability to cold and fire- species_name = "reptilian"- }
− src/RandomUtils.hs
@@ -1,18 +0,0 @@--module RandomUtils- (pick,- weightedPick)- where--import Data.List-import Data.Maybe--pick :: [a] -> Integer -> a-pick elems seed = elems `genericIndex` (seed `mod` (genericLength elems))--weightedPick :: Integer -> [(Integer,a)] -> a-weightedPick seed elems = let (weights,values) = unzip elems- (weightTotal,weightTotals) = mapAccumL (\x y -> (x+y,x+y)) 0 weights- weightToFind = seed `mod` weightTotal- index = fromJust $ findIndex (\x -> x > weightToFind) weightTotals- in values !! index
− src/SegHopList.hs
@@ -1,20 +0,0 @@--module SegHopList- (SegHopList,SegHopList.fromList,SegHopList.index)- where--import SegmentList-import HopList-import Data.Array---- |--- A system that combines the benefits of the SegmentList and the HopList--- to access data arbitrarily far away in an infinite list quickly.----type SegHopList a = HopList (Array Int a)--fromList :: [a] -> SegHopList a-fromList xs = HopList.fromList (segmentList xs)--index :: SegHopList a -> Integer -> a-index shl i = (shl `HopList.index` (i `div` segmentSizeI)) ! ((fromInteger i) `mod` segmentSizei)
− src/SegmentList.hs
@@ -1,36 +0,0 @@--module SegmentList- (segmentSizei,segmentSizeI,segmentList,segmentIndex)- where--import Data.List-import Data.Array--segmentSizei :: Int-segmentSizei = 100--segmentSizeI :: Integer-segmentSizeI = toInteger segmentSizei---- |--- Constructs a list in which chunks of sequential elements are held together--- in an array, to improve access time. This is only intended for--- use in an infinite list (otherwise just pack the entire thing--- in one array).--- -segmentList :: [a] -> [Array Int a]-segmentList xs = let (firstGroup,restGroups) = seqSplitAt segmentSizei xs- in (listArray (0,segmentSizei-1) firstGroup) :- (segmentList restGroups)--seqSplitAt :: Int -> [a] -> ([a],[a])-seqSplitAt 0 xs = ([],xs)-seqSplitAt i (x:xs) = let rest = (seqSplitAt (i-1) xs)- in seq x $ (x : (fst rest),snd rest)-seqSplitAt i [] = error ("Tried to access " ++ (show i) ++ "'th element of []")---- |--- Retrieve an element from a segment list by index.----segmentIndex :: [Array Int a] -> Integer -> a-segmentIndex xss i = (xss `genericIndex` (i `div` segmentSizeI)) ! ((fromInteger i) `mod` segmentSizei)
src/Species.hs view
@@ -1,18 +1,132 @@ module Species- (generateCreatureData)+ (player_race_names,+ SpeciesData(..),+ speciesInfo) where -import DB-import Control.Monad+import Data.Char+import CreatureData+import CharacterData import SpeciesData-import Stats-import Attribute+import CreatureAttribute+import Data.Monoid+import TerrainData ------ Randomly generates a new creature.----generateCreatureData :: Species -> DB CreatureGenerationData-generateCreatureData species = do new_stats <- generateStats (averages species) (distributions species) - new_attribs <- generateAttributes (attribute_generator species) - return ( new_stats, new_attribs, (species_name species) )+player_race_names :: [String]+player_race_names = map (map toLower . show) player_species++data SpeciesData = SpeciesData { + species_recurring_attributes :: CreatureAttribute,+ species_starting_attributes :: [CreatureAttributeGenerator] }++-- | Give a minimum and maximum ability score, along with a list of special aptitudes that are doubled.+aptitudeBlock :: Integer -> Integer -> [CreatureAptitude] -> CreatureAttributeGenerator+aptitudeBlock minimal maximal special = mconcat $+ map (\a -> attributeMinMax (minimal,maximal) a) [minBound..maxBound :: CreatureAptitude] +++ map (\a -> attributeMinMax (minimal,maximal) a) special++-- | Low probability, large magnitude bonuses to aptitude scores.+surpriseAptitudes :: CreatureAttributeGenerator+surpriseAptitudes = mconcat $ map (\a -> attributeChoice 0.05 [attributeMinMax (1,30) a] []) [minBound..maxBound :: CreatureAptitude]++speciesInfo :: Species -> SpeciesData++speciesInfo Anachronid = SpeciesData (Speed & Mindfulness & SpotSkill) [+ gender 0.8+ [aptitudeBlock 1 10 [Speed,Mindfulness],+ attributeStatic 2 SpotSkill]+ [aptitudeBlock 10 25 [Speed,Mindfulness], + attributeStatic 15 SpotSkill,+ surpriseAptitudes],+ attributeStatic 1 $ FavoredClass Barbarian,+ attributeStatic 1 $ FavoredClass Pirate]++speciesInfo Androsynth = SpeciesData (Strength & Intellect) [+ aptitudeBlock 12 17 [Strength,Intellect],+ attributeStatic 1 $ FavoredClass Engineer] ++speciesInfo Ascendant = SpeciesData (Strength & Mindfulness) [+ gender 0.45 [] [],+ aptitudeBlock 5 15 [Strength,Mindfulness],+ surpriseAptitudes,+ attributeStatic 10 JumpSkill,+ attributeStatic 1 $ FavoredClass Shepherd,+ attributeStatic 1 $ FavoredClass ForceAdept]++speciesInfo Caduceator = SpeciesData (Strength & Charisma) [+ gender 0.6 [] [],+ aptitudeBlock 5 15 [Strength,Charisma],+ surpriseAptitudes,+ attributeStatic 1 $ FavoredClass Consular]++speciesInfo Encephalon = SpeciesData (Constitution & Intellect) [+ gender 0.95 [] [],+ aptitudeBlock 3 20 [Constitution,Intellect],+ attributeStatic 1 $ FavoredClass Engineer]++speciesInfo Hellion = SpeciesData (Strength & Perception) [+ gender 0.5 [] [],+ aptitudeBlock 5 15 [Strength,Perception],+ surpriseAptitudes,+ attributeStatic 5 $ HideSkill,+ attributeStatic 1 $ FavoredClass Scout,+ attributeStatic 1 $ FavoredClass Marine,+ attributeStatic 1 $ FavoredClass Thief,+ attributeStatic 1 $ FavoredClass Pirate]++speciesInfo Goliath = SpeciesData (Constitution & Perception) [+ gender 0.55 [] [],+ aptitudeBlock 3 20 [Constitution,Perception],+ surpriseAptitudes,+ attributeStatic 4 $ DamageReductionTrait Melee,+ attributeStatic 4 $ DamageReductionTrait Ranged,+ attributeStatic 4 $ DamageReductionTrait Unarmed,+ attributeStatic 1 $ FavoredClass Barbarian,+ attributeStatic 1 $ FavoredClass Warrior,+ attributeStatic 1 $ FavoredClass Scout]++speciesInfo Kraken = SpeciesData (Constitution & Charisma) [+ gender 0.5 [] [],+ aptitudeBlock 3 20 [Constitution,Charisma],+ attributeStatic 1 $ TerrainAffinity Water,+ surpriseAptitudes,+ attributeStatic 1 $ FavoredClass Consular]++speciesInfo Myrmidon = SpeciesData (Speed & Intellect) [+ gender 0.0 [] [],+ aptitudeBlock 5 15 [Speed,Intellect],+ surpriseAptitudes,+ attributeStatic 1 $ FavoredClass Barbarian,+ attributeStatic 1 $ FavoredClass Engineer,+ attributeStatic 1 $ FavoredClass Warrior,+ attributeStatic 5 $ AttackSkill Melee,+ attributeStatic 5 $ DefenseSkill Melee]++speciesInfo Perennial = SpeciesData (Constitution & Mindfulness) [+ aptitudeBlock 1 25 [Constitution, Mindfulness],+ attributeStatic 1 $ TerrainAffinity Forest,+ attributeStatic 1 $ TerrainAffinity DeepForest,+ surpriseAptitudes,+ attributeStatic 1 $ FavoredClass Barbarian,+ attributeStatic 1 $ FavoredClass Engineer,+ attributeStatic 1 $ FavoredClass Consular,+ attributeStatic 1 $ FavoredClass Shepherd]++speciesInfo Recreant = SpeciesData (Speed & Perception) [+ aptitudeBlock 2 5 [Speed,Perception],+ surpriseAptitudes, surpriseAptitudes,+ attributeStatic 5 $ AttackSkill Ranged,+ attributeStatic 5 $ DamageSkill Ranged,+ attributeStatic 1 $ FavoredClass Marine,+ attributeStatic 1 $ FavoredClass Scout]++speciesInfo Reptilian = SpeciesData (Speed & Charisma) [+ gender 0.35 [] [],+ aptitudeBlock 5 15 [Speed,Charisma],+ surpriseAptitudes,+ attributeStatic 5 $ AttackSkill Unarmed,+ attributeStatic 5 $ DefenseSkill Unarmed,+ attributeStatic 1 $ FavoredClass Warrior,+ attributeStatic 1 $ FavoredClass Consular]+
src/SpeciesData.hs view
@@ -1,47 +1,39 @@- module SpeciesData- (male,- female,- exampleSpecies,- Species(..),- CreatureGenerationData)+ (Species(..),+ all_species,+ player_species) where -import StatsData-import CreatureData-import AttributeData------- Makes the creature male x percent of the time (female otherwise).----male :: Rational -> AttributeGenerator CreatureAttribute-male x = AttributeSometimes (Gender Male) x $ Just (AttributeAlways (Gender Female))------- Makes the creature female x percent of the time (male otherwise).----female :: Rational -> AttributeGenerator CreatureAttribute-female x = AttributeSometimes (Gender Female) x $ Just (AttributeAlways (Gender Male))+data Species =+ Anachronid+ | Androsynth+ | Ascendant+ | Caduceator+ | Encephalon+ | Goliath+ | Hellion+ | Kraken+ | Myrmidon+ | Perennial+ | Recreant+ | Reptilian+ deriving (Eq,Ord,Bounded,Enum,Read,Show) -data Species = Species { averages :: Stats, - distributions :: Stats,- attribute_generator :: [AttributeGenerator CreatureAttribute],- species_name :: String } - deriving (Show, Read)+all_species :: [Species]+all_species = [minBound..maxBound] ------ Tuple that contains generated data for a new creature. Contains the stats for the new creature,--- the attributes, and the name of the creature's species.----type CreatureGenerationData = ( Stats, [CreatureAttribute], String )+player_species :: [Species]+player_species = [+ Anachronid,+ Androsynth,+ Ascendant,+ Caduceator,+ Encephalon,+ Goliath,+ Hellion,+ Kraken,+ Myrmidon,+ Perennial,+ Recreant,+ Reptilian] ------ An example species.----exampleSpecies :: Species-exampleSpecies = Species {- averages = Stats { strength=1, dexterity=(-2), constitution=1, intelligence=(-1), perception=(-1), charisma=3, mindfulness=(-1) },- distributions = (stats 2),- attribute_generator = [male 0.4],- species_name = "Example-Species" - }
src/Substances.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE OverloadedStrings #-} module Substances (Gas(..), Material(..),@@ -6,11 +6,16 @@ Solid(..), materialValue, MaterialValue(..),- Substance,+ Substance(..),+ SubstanceType(toSubstance),+ coerceSubstance,+ isGas,+ isMaterial,+ isChromalite, substances, prettySubstance, printSubstances,- gasWeight,+ gasValue, chromaliteAlignment, chromalitePotency) where@@ -18,6 +23,8 @@ import Alignment import Data.List import Data.Ord+import Data.Maybe+import qualified Data.ByteString.Char8 as B data Substance = GasSubstance Gas@@ -30,20 +37,21 @@ map MaterialSubstance [minBound..maxBound] ++ map ChromaliteSubstance [minBound..maxBound] -prettySubstance :: Substance -> String-prettySubstance (GasSubstance x) = show x-prettySubstance (MaterialSubstance x) = show x-prettySubstance (ChromaliteSubstance x) = show x+prettySubstance :: Substance -> B.ByteString+prettySubstance (GasSubstance x) = B.pack $ show x+prettySubstance (MaterialSubstance x) = B.pack $ show x+prettySubstance (ChromaliteSubstance x) = B.pack $ show x printSubstances :: IO ()-printSubstances = putStrLn $ unlines $ map (\(x,y) -> prettySubstance y ++ ": " ++ show x) $ sortBy (comparing fst) $ map (\x -> (substanceValue x,x)) substances+printSubstances = B.putStrLn $ B.unlines $ map (\(x,y) -> prettySubstance y `B.append` ": " `B.append` B.pack (show x)) $ sortBy (comparing fst) $ map (\x -> (substanceValue x,x)) substances data Solid = MaterialSolid Material | ChromaliteSolid Chromalite deriving (Read,Show,Eq,Ord) data Gas = - Hydrogen+ Water+ | Hydrogen | Helium | Oxygen | Nitrogen@@ -53,6 +61,9 @@ | Krypton | Xenon | Radon+ | Methane+ | Ammonia+ | Iodine | Chlorine deriving (Eq,Enum,Ord,Show,Read,Bounded) data Material = @@ -76,6 +87,8 @@ | Carbon | Wood | Plastic+ | Silicon+ | Nickel deriving (Eq,Enum,Ord,Show,Read,Bounded) --@@ -104,45 +117,51 @@ | Bectonite -- radiant black Chromalite deriving (Eq,Enum,Ord,Show,Read,Bounded) +gasValue :: Gas -> Integer+gasValue Water = 2+gasValue Hydrogen = 4+gasValue Helium = 6+gasValue Nitrogen = 7+gasValue Oxygen = 10+gasValue Flourine = 12+gasValue Neon = 20+gasValue Ammonia = 21+gasValue Methane = 24+gasValue Chlorine = 30+gasValue Argon = 40+gasValue Krypton = 42+gasValue Xenon = 60+gasValue Radon = 70+gasValue Iodine = 100+ data MaterialValue = MaterialValue { material_construction_value :: Integer, -- value of material for constructing buildings, pipes, casings for gadgets, etc material_critical_value :: Integer, -- value of material for critical purposes, such as miniature electronic components- material_scarcity :: Integer } -- how rare the material is in nature and by synthesis--gasWeight :: Gas -> Integer-gasWeight Hydrogen = 1-gasWeight Helium = 4-gasWeight Oxygen = 16-gasWeight Nitrogen = 14-gasWeight Flourine = 19-gasWeight Neon = 20-gasWeight Argon = 40-gasWeight Krypton = 84-gasWeight Xenon = 131-gasWeight Radon = 222-gasWeight Chlorine = 35+ material_scarcity :: Integer } -- scarcity of material materialValue :: Material -> MaterialValue-materialValue Aluminum = MaterialValue 10 10 10-materialValue Titanium = MaterialValue 15 10 20-materialValue Palladium = MaterialValue 2 150 5-materialValue Molybdenum = MaterialValue 1 50 3-materialValue Lead = MaterialValue 3 20 2-materialValue Copper = MaterialValue 8 80 15-materialValue Iron = MaterialValue 5 10 2-materialValue Cobalt = MaterialValue 3 60 7-materialValue Zirconium = MaterialValue 2 40 10-materialValue Gold = MaterialValue 4 20 50-materialValue Silver = MaterialValue 3 30 20-materialValue Platinum = MaterialValue 1 100 70-materialValue Zinc = MaterialValue 6 50 4-materialValue Uranium = MaterialValue 1 300 40-materialValue Plutonium = MaterialValue 1 500 100-materialValue Thorium = MaterialValue 2 200 4-materialValue Diamond = MaterialValue 40 20 15-materialValue Carbon = MaterialValue 2 20 1-materialValue Wood = MaterialValue 3 0 2-materialValue Plastic = MaterialValue 4 0 2+materialValue Aluminum = MaterialValue 50 20 6+materialValue Titanium = MaterialValue 70 15 15+materialValue Palladium = MaterialValue 30 30 65+materialValue Molybdenum = MaterialValue 18 55 40+materialValue Lead = MaterialValue 15 7 31+materialValue Copper = MaterialValue 40 40 18+materialValue Iron = MaterialValue 25 15 10+materialValue Cobalt = MaterialValue 30 35 30+materialValue Zirconium = MaterialValue 12 50 23+materialValue Gold = MaterialValue 20 35 83+materialValue Silver = MaterialValue 10 20 80+materialValue Platinum = MaterialValue 22 40 81+materialValue Zinc = MaterialValue 35 25 26+materialValue Uranium = MaterialValue 5 90 37+materialValue Plutonium = MaterialValue 1 100 100+materialValue Thorium = MaterialValue 20 80 33+materialValue Diamond = MaterialValue 100 100 90+materialValue Carbon = MaterialValue 60 20 20+materialValue Wood = MaterialValue 25 1 3+materialValue Plastic = MaterialValue 30 10 1+materialValue Silicon = MaterialValue 25 50 5+materialValue Nickel = MaterialValue 25 45 25 chromaliteAlignment :: Chromalite -> Alignment chromaliteAlignment Rutilium = (Chaotic,Strategic)@@ -163,32 +182,53 @@ chromaliteAlignment Bectonite = (Evil,Indifferent) class SubstanceType a where- substanceValue :: a -> Integer toSubstance :: a -> Substance+ fromSubstance :: Substance -> Maybe a +coerceSubstance :: (SubstanceType a,SubstanceType b) => a -> Maybe b+coerceSubstance = fromSubstance . toSubstance++isGas :: (SubstanceType a) => a -> Bool+isGas = isJust . (`asTypeOf` (undefined :: Maybe Gas)) . coerceSubstance++isMaterial :: (SubstanceType a) => a -> Bool+isMaterial = isJust . (`asTypeOf` (undefined :: Maybe Material)) . coerceSubstance++isChromalite :: (SubstanceType a) => a -> Bool+isChromalite = isJust . (`asTypeOf` (undefined :: Maybe Chromalite)) . coerceSubstance++substanceValue :: (SubstanceType a) => a -> Integer+substanceValue a = case toSubstance a of+ GasSubstance x -> gasValue x + 10+ MaterialSubstance x -> (nom + crit) * scarce+ where MaterialValue nom crit scarce = materialValue x+ ChromaliteSubstance x -> 1000 + 2 * chromalitePotency x ^ 2+ instance SubstanceType Gas where- substanceValue x = gasWeight x ^ 2 - gasWeight x toSubstance x = GasSubstance x+ fromSubstance (GasSubstance x) = Just x+ fromSubstance _ = Nothing instance SubstanceType Material where- substanceValue x = nom * crit * scarce + nom + crit + scarce- where MaterialValue nom crit scarce = materialValue x toSubstance x = MaterialSubstance x+ fromSubstance (MaterialSubstance x) = Just x+ fromSubstance _ = Nothing instance SubstanceType Chromalite where- substanceValue x = 10 * chromalitePotency x ^ 2 + 100 * chromalitePotency x toSubstance x = ChromaliteSubstance x+ fromSubstance (ChromaliteSubstance x) = Just x+ fromSubstance _ = Nothing instance SubstanceType Substance where- substanceValue (GasSubstance x) = substanceValue x- substanceValue (MaterialSubstance x) = substanceValue x- substanceValue (ChromaliteSubstance x) = substanceValue x toSubstance x = x+ fromSubstance = Just instance SubstanceType Solid where- substanceValue = substanceValue . toSubstance toSubstance (MaterialSolid x) = toSubstance x toSubstance (ChromaliteSolid x) = toSubstance x+ fromSubstance (MaterialSubstance x) = Just $ MaterialSolid x+ fromSubstance (ChromaliteSubstance x) = Just $ ChromaliteSolid x+ fromSubstance _ = Nothing chromalitePotency :: Chromalite -> Integer chromalitePotency = alignmentPotency . chromaliteAlignment
− src/Terrain.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE PatternSignatures, FlexibleContexts #-}--module Terrain- (terrainAt,- whatIsOccupying,- isTerrainPassable)- where--import TerrainData-import DB-import Control.Monad-import PlaneData-import Grids-import Data.Maybe--terrainAt :: (DBReadable db) => PlaneRef -> Position -> db TerrainPatch-terrainAt plane_ref (Position (x,y)) =- do terrain <- liftM plane_terrain $ dbGetPlane plane_ref- return $ gridAt terrain (x,y)--whatIsOccupying :: (DBReadable db,GenericReference a S) => PlaneRef -> Position -> db [a]-whatIsOccupying plane_ref position =- liftM (mapMaybe fromLocation . filter ((== position) . location) . map (asLocationTyped _nullary _position)) $ dbGetContents plane_ref--isTerrainPassable :: (DBReadable db) => PlaneRef -> CreatureRef -> Position -> db Bool-isTerrainPassable plane_ref creature_ref position = - do (critters :: [CreatureRef]) <- liftM (filter (/= creature_ref)) $ whatIsOccupying plane_ref position- terrain <- terrainAt plane_ref position- return $ not (terrain `elem` [RockFace,Forest,DeepForest]) && null critters
src/TerrainData.hs view
@@ -2,20 +2,21 @@ module TerrainData (Biome(..), TerrainPatch(..),- TerrainMap,+ TerrainGrid, TerrainGenerationData(..), TerrainPlacement, recreantFactories, generateTerrain, generateExampleTerrain, prettyPrintTerrain,- difficult_terrains)+ difficult_terrains,+ impassable_terrains) where import Grids import Data.List as List import Data.Map as Map-import Substances+--import Substances hiding (Water) import RNG import Data.Ratio @@ -35,7 +36,7 @@ deriving (Read,Show,Eq,Ord,Enum,Bounded) -- |--- All static terrain elements are members of TerrainMap+-- All static terrain elements are members of TerrainGrid -- -- The only difference between "Deasert" and "Sand" is that where -- "Deasert" and "Water" touch, the map generator will produce@@ -43,7 +44,7 @@ -- data TerrainPatch = RockFace | Rubble- | Ore Solid+ | Ore | RockyGround | Dirt | Grass@@ -71,7 +72,7 @@ placement_seed :: Integer } deriving (Read,Show) -placeTerrain :: TerrainPlacement -> TerrainMap -> TerrainMap+placeTerrain :: TerrainPlacement -> TerrainGrid -> TerrainGrid placeTerrain terrain_placement = arbitraryReplaceGrid (placement_sources terrain_placement) (placement_replacements terrain_placement)@@ -97,8 +98,15 @@ -- or for constructing buildings. -- difficult_terrains :: [TerrainPatch]-difficult_terrains = [RockFace,Forest,DeepForest,Water,DeepWater,Ice,Lava,RecreantFactory]+difficult_terrains = impassable_terrains +++ [Water,DeepWater,Ice,Lava,RecreantFactory] +-- |+-- A list of TerrainPatches that are considered "impassable" for traveling.+--+impassable_terrains :: [TerrainPatch]+impassable_terrains = [RockFace,Forest,DeepForest]+ terrainFrequencies :: Biome -> [(Integer,TerrainPatch)] terrainFrequencies RockBiome = [(15,RockFace),(15,Rubble),(55,RockyGround),(15,Sand)] terrainFrequencies IcyRockBiome = [(10,RockFace),(10,Rubble),(20,RockyGround),(60,Ice)]@@ -144,7 +152,7 @@ interps = List.map terrainInterpFn terrain_patch_pairs in fromList (zip terrain_patch_pairs interps) -type TerrainMap = Grid TerrainPatch+type TerrainGrid = Grid TerrainPatch -- | -- Generates a random terrain map. The Biome indicates determines what TerrainPatches@@ -152,7 +160,7 @@ -- generated terrain. Finally, a random Integer stream is needed to provide the random data -- to generate the terrain. ---generateTerrain :: TerrainGenerationData -> [Integer] -> TerrainMap+generateTerrain :: TerrainGenerationData -> [Integer] -> TerrainGrid generateTerrain tg rands = flip (foldr placeTerrain) (tg_placements tg) $ generateGrid (terrainFrequencies (tg_biome tg)) terrainInterpMap@@ -162,7 +170,7 @@ terrainPatchToASCII :: TerrainPatch -> Char terrainPatchToASCII RockFace = '#' terrainPatchToASCII Rubble = '*'-terrainPatchToASCII (Ore _) = '$'+terrainPatchToASCII Ore = '$' terrainPatchToASCII RockyGround = ':' terrainPatchToASCII Dirt = '.' terrainPatchToASCII Grass = ','@@ -183,10 +191,10 @@ tg_biome = ForestBiome, tg_placements = [] } -generateExampleTerrain :: Integer -> TerrainMap-generateExampleTerrain seed = generateTerrain exampleTerrainGenerator (randomIntegerStream seed)+generateExampleTerrain :: Integer -> TerrainGrid+generateExampleTerrain seed = generateTerrain exampleTerrainGenerator (randoms $ mkRNG seed) -prettyPrintTerrain :: ((Integer,Integer),(Integer,Integer)) -> TerrainMap -> [String]+prettyPrintTerrain :: ((Integer,Integer),(Integer,Integer)) -> TerrainGrid -> [String] prettyPrintTerrain ((left_bound,right_bound),(top_bound,bottom_bound)) terrain_map = [[terrainPatchToASCII $ gridAt terrain_map (x,y) | x <- [left_bound..right_bound]]
src/Tool.hs view
@@ -1,38 +1,47 @@-{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} module Tool (dbPickupTool, dbWieldTool, dbDropTool, dbAvailablePickups,- dbGetInventory,- dbGetCarried,- dbGetWielded)+ availableWields,+ dbGetWielded,+ deleteTool,+ toolDurability) where import DB import Control.Monad.Error import Data.Maybe+import Data.List as List+import ToolData+import Substances dbPickupTool :: (DBReadable db,LocationType a) => CreatureRef -> Location s ToolRef a -> db (Location s ToolRef Inventory) dbPickupTool c l = - do (c_where :: Maybe (Position,PlaneRef)) - <- liftM extractLocation $ dbWhere c+ do (c_where :: Maybe (Position,PlaneRef)) <- liftM extractLocation $ dbWhere c when ((c_where /= extractLocation l && Just c /= extractLocation l) || isNothing c_where) $ - throwError (DBErrorFlag "not-at-feet")+ throwError (DBErrorFlag ToolIs_NotAtFeet) return $ toInventory (Inventory c) l +-- | Move a tool into wielded position for whatever creature is carrying it. dbWieldTool :: (DBReadable db,LocationType a) => Location s ToolRef a -> db (Location s ToolRef Wielded) dbWieldTool l =- case extractLocation l of- _ | isLocationTyped _wielded l -> throwError (DBErrorFlag "already-wielded")- Just (Inventory c) -> return $ toWielded (Wielded c) l- Nothing -> throwError (DBErrorFlag "not-in-inventory")+ case () of+ () | Just l' <- coerceLocation l -> return l' -- if it coerces into our return type, then it's already wielded+ () | Just (Dropped plane_ref position) <- extractLocation l ->+ do pickupers <- liftM (map entity . filter ((== position) . location)) $ dbGetContents plane_ref+ case pickupers of -- the creature that is standing over the tool -- there can be only one+ [single_pickuper] -> return $ toWielded (Wielded single_pickuper) l+ _ -> throwError $ DBError "dbWieldTool: there were multiple creatures in reach of a single tool"+ () | Just (Inventory c) <- extractLocation l -> return $ toWielded (Wielded c) l+ () | otherwise -> throwError $ DBErrorFlag ToolIs_NotWieldable dbDropTool :: (DBReadable db,LocationType a) => Location s ToolRef a -> db (Location s ToolRef Dropped) dbDropTool l = do lp <- liftM extractLocation $ dbWhere (getLocation l)- flip (maybe (throwError $ DBErrorFlag "not-standing")) lp $ \(creature_position,plane_ref) ->+ flip (maybe (throwError $ DBErrorFlag NotStanding)) lp $ \(creature_position,plane_ref) -> do return $ toDropped (Dropped plane_ref creature_position) l dbAvailablePickups :: (DBReadable db) => CreatureRef -> db [ToolRef]@@ -42,12 +51,23 @@ do contents <- dbGetContents plane_ref return $ map entity $ filter ((== creature_position) . location) contents -dbGetInventory :: (DBReadable db) => CreatureRef -> db [ToolRef]-dbGetInventory = dbGetContents--dbGetCarried :: (DBReadable db) => CreatureRef -> db [ToolRef]-dbGetCarried = dbGetContents+-- | List of tools that the specified creature may choose to wield.+-- That is, they are either on the ground or in the creature's inventory.+availableWields :: (DBReadable db) => CreatureRef -> db [ToolRef]+availableWields creature_ref = liftM2 List.union (dbAvailablePickups creature_ref) (dbGetContents creature_ref) dbGetWielded :: (DBReadable db) => CreatureRef -> db (Maybe ToolRef) dbGetWielded = liftM (listToMaybe . map (entity . asLocationTyped _tool _wielded)) . dbGetContents +-- | Safely delete tools.+deleteTool :: ToolRef -> DB ()+deleteTool = dbUnsafeDeleteObject (error "deleteTool: impossible case: tools shouldn't contain anything")++toolDurability :: (DBReadable db) => ToolRef -> db Integer+toolDurability tool_ref = + do t <- dbGetTool tool_ref+ return $ case t of+ DeviceTool _ d -> deviceDurability d+ Sphere (MaterialSubstance m) -> material_construction_value (materialValue m) + 10+ Sphere (GasSubstance {}) -> 10+ Sphere (ChromaliteSubstance {}) -> 110
src/ToolData.hs view
@@ -1,53 +1,142 @@+{-# LANGUAGE OverloadedStrings #-} module ToolData (Tool(..),- Gun,- gunEnergyOutput,- gunThroughput,- gunEndurance,- toolName,- phase_pistol)+ fromSphere,+ sphere,+ Device,+ PseudoDevice(..),+ DeviceKind(..),+ DeviceFunction(..),+ DeviceType(..),+ deviceName,+ deviceOutput,+ deviceAccuracy,+ deviceSpeed,+ deviceDurability,+ deviceSize,+ deviceChromalite,+ deviceMaterial,+ deviceGas,+ improvised,+ phase_pistol,+ phaser,+ phase_rifle,+ kinetic_fleuret,+ kinetic_sabre) where import Substances+import qualified Data.ByteString.Char8 as B -data Tool = GunTool Gun- deriving (Read,Show)+data Tool = DeviceTool DeviceFunction Device+ | Sphere Substance+ deriving (Read,Show,Eq) -data GunSize = Pistol- | Carbine- | Rifle- | Cannon- | Launcher- deriving (Read,Show,Eq)+-- | Get the substance type of a material sphere, if it is one.+fromSphere :: Tool -> Maybe Substance+fromSphere (Sphere s) = Just s+fromSphere _ = Nothing -data Gun = Gun {- gun_name :: String,- gun_power_cell :: Chromalite,- gun_substrate :: Material,- gun_casing :: Material,- gun_medium :: Gas,- gun_size :: GunSize }+sphere :: (SubstanceType a) => a -> Tool+sphere = Sphere . toSubstance++data DeviceFunction = Gun | Sword+ deriving (Read,Show,Eq)++data DeviceKind =+ Pistol+ | Carbine+ | Rifle+ | Fleuret+ | Sabre+ deriving (Read,Show,Eq)++kindToFunction :: DeviceKind -> (DeviceFunction,Integer)+kindToFunction Pistol = (Gun,1)+kindToFunction Carbine = (Gun,3)+kindToFunction Rifle = (Gun,5)+kindToFunction Fleuret = (Sword,2)+kindToFunction Sabre = (Sword,4) ++-- | Any kind of device that is constructed from a power cell, materal, and gas medium,+-- using the various device rules to determine it's power.+data Device = Device {+ device_name :: B.ByteString,+ device_chromalite :: Chromalite,+ device_material :: Material,+ device_gas :: Gas,+ device_size :: Integer } deriving (Eq,Read,Show) +-- | Anything that operates like a device, but isn't. For example, an unarmed attack.+data PseudoDevice = PseudoDevice {+ pdevice_accuracy :: Integer,+ pdevice_output :: Integer,+ pdevice_speed :: Integer,+ pdevice_size :: Integer }++class DeviceType d where+ toPseudoDevice :: d -> PseudoDevice++instance DeviceType Device where+ toPseudoDevice d = let chromalite = chromalitePotency $ device_chromalite d+ gas = gasValue $ device_gas d+ material = material_critical_value $ materialValue $ device_material d+ size = device_size d+ in PseudoDevice {+ pdevice_accuracy = min chromalite material + chromalite,+ pdevice_output = min chromalite gas + chromalite,+ pdevice_speed = gas + material,+ pdevice_size = size }++instance DeviceType PseudoDevice where+ toPseudoDevice = id++device :: B.ByteString -> DeviceKind -> Chromalite -> Material -> Gas -> Tool+device s dk c m g = DeviceTool func (Device s c m g size)+ where (func,size) = kindToFunction dk++improvised :: DeviceKind -> Chromalite -> Material -> Gas -> Tool+improvised dk c m g = device ("improvised_" `B.append` B.pack (show dk)) dk c m g+ phase_pistol :: Tool-phase_pistol = GunTool $ Gun "phase_pistol" Pteulanium Palladium Zinc Argon Pistol+phase_pistol = device "phase_pistol" Pistol Caerulite Zinc Flourine -gunEnergyOutput :: Gun -> Integer-gunEnergyOutput g = gunSizeClass g * (chromalitePotency $ gun_power_cell g)+phaser :: Tool+phaser = device "phaser" Carbine Caerulite Zinc Flourine -gunThroughput :: Gun -> Integer-gunThroughput g = ((material_critical_value $ materialValue $ gun_substrate g) + 1) *- (gasWeight $ gun_medium g)+phase_rifle :: Tool+phase_rifle = device "phase_rifle" Rifle Caerulite Zinc Flourine -gunEndurance :: Gun -> Integer-gunEndurance g = 10 * (material_construction_value $ materialValue $ gun_casing g)^2+kinetic_fleuret :: Tool+kinetic_fleuret = device "kinetic_fleuret" Fleuret Ionidium Aluminum Nitrogen -gunSizeClass :: Gun -> Integer-gunSizeClass (Gun { gun_size = Pistol }) = 1-gunSizeClass (Gun { gun_size = Carbine}) = 3-gunSizeClass (Gun { gun_size = Rifle}) = 4-gunSizeClass (Gun { gun_size = Cannon}) = 7-gunSizeClass (Gun { gun_size = Launcher}) = 10+kinetic_sabre :: Tool+kinetic_sabre = device "kinetic_sabre" Sabre Ionidium Aluminum Nitrogen -toolName :: Tool -> String-toolName (GunTool (Gun { gun_name = s })) = s+deviceName :: Device -> B.ByteString+deviceName = device_name++deviceDurability :: Device -> Integer+deviceDurability d = device_size d * (material_construction_value $ materialValue $ device_material d)++deviceOutput :: (DeviceType d) => d -> Integer+deviceOutput = pdevice_output . toPseudoDevice++deviceAccuracy :: (DeviceType d) => d -> Integer+deviceAccuracy = pdevice_accuracy . toPseudoDevice++deviceSpeed :: (DeviceType d) => d -> Integer+deviceSpeed = pdevice_speed . toPseudoDevice++deviceSize :: (DeviceType d) => d -> Integer+deviceSize = pdevice_size . toPseudoDevice++deviceChromalite :: Device -> Chromalite+deviceChromalite = device_chromalite++deviceMaterial :: Device -> Material+deviceMaterial = device_material++deviceGas :: Device -> Gas+deviceGas = device_gas
+ src/Town.hs view
@@ -0,0 +1,18 @@+module Town+ (createTown)+ where++import BuildingData+import DB+import TerrainData+import Plane++-- | Create a town from a list of buildings.+createTown :: PlaneRef -> [BuildingType] -> DB [BuildingRef]+createTown plane_ref = mapM $ \building_type ->+ do let clear_need = minimum $ map abs $ uncurry (++) $ unzip $ buildingOccupies building_type+ p <- pickRandomClearSite 25 (clear_need*2+1) (clear_need+1) (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref+ dbAddBuilding Building $ Constructed {+ constructed_plane = plane_ref,+ constructed_position = p,+ constructed_type = building_type }
src/Travel.hs view
@@ -1,16 +1,24 @@ module Travel (stepCreature,- turnCreature)+ turnCreature,+ TeleportJumpOutcome,+ resolveTeleportJump,+ executeTeleportJump) where import Control.Monad.Maybe-import Terrain import Facing import DB-import Terrain+import Plane import Data.Maybe import Control.Monad import Control.Monad.Trans+import Data.Ord+import Position+import TerrainData+import Data.List (minimumBy)+import Creature+import CreatureData walkCreature :: (DBReadable db) => Facing -> (Integer,Integer) -> Location m CreatureRef () -> db (Location m CreatureRef ())@@ -27,4 +35,43 @@ turnCreature :: (DBReadable db) => Facing -> Location m CreatureRef () -> db (Location m CreatureRef ()) turnCreature face = walkCreature face (0,0)++-------------------------------------------------------------------------------------------------------------+-- Teleportation/Jumping+-------------------------------------------------------------------------------------------------------------++-- |+-- Try to teleport the creature to the specified Position. The teleport attempt can be automatically retried a number of times, and the most accurate attempt will be used.+-- If the retries are negative, the teleport will be made artificially innacurate.+--+randomTeleportLanding :: (DBReadable db) => Integer -> PlaneRef -> Position -> Position -> db Position+randomTeleportLanding retries plane_ref source_destination goal_destination =+ do landings <- replicateM (fromInteger $ max 1 retries) $ (pickRandomClearSite 3) 0 0 goal_destination (not . (`elem` impassable_terrains)) plane_ref+ return $ minimumBy (comparing $ \p -> distanceBetweenSquared goal_destination p ^ 2 * distanceBetweenSquared source_destination p) landings++data TeleportJumpOutcome =+ TeleportJumpGood CreatureRef Standing+ | TeleportJumpFailed++-- |+-- Teleport jump a creature about 7 units in the specified direction.+--+resolveTeleportJump :: (DBReadable db) => CreatureRef -> Facing -> db TeleportJumpOutcome+resolveTeleportJump creature_ref face = liftM (fromMaybe TeleportJumpFailed) $ runMaybeT $+ do start_location <- lift $ dbWhere creature_ref+ jump_roll <- liftM roll_log $ lift $ rollCreatureAbilityScore JumpSkill 0 (entity start_location)+ standing_location <- MaybeT $ return $ extractLocation start_location+ landing_position <- lift $ randomTeleportLanding jump_roll (standing_plane standing_location) (standing_position standing_location) $+ offsetPosition (facingToRelative7 face) $ standing_position standing_location+ case () of+ () | jump_roll <= 0 -> return TeleportJumpFailed+ () | otherwise -> return $ TeleportJumpGood (entity start_location) $ standing_location { standing_position = landing_position, standing_facing = face }++-- | Execute a resolved teleport jump.+executeTeleportJump :: TeleportJumpOutcome -> DB ()+executeTeleportJump TeleportJumpFailed = return ()+executeTeleportJump (TeleportJumpGood creature_ref standing_location) = + do _ <- dbMove (return . toStanding standing_location) creature_ref+ dbPushSnapshot $ TeleportEvent creature_ref+ return ()
src/Turns.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, PatternSignatures #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} module Turns (dbPerformPlayerTurn)@@ -7,20 +7,19 @@ import Control.Monad.Maybe import Control.Monad.Trans import DB-import DBData import FactionData-import Races+import SpeciesData import Plane import Control.Monad import Creature import Data.Ratio import Facing-import Dice import TerrainData import Data.Maybe import Behavior import qualified Perception as P import Position+import PlayerState dbPerformPlayerTurn :: Behavior -> CreatureRef -> DB () dbPerformPlayerTurn beh creature_ref =@@ -36,7 +35,8 @@ dbFinishPlanarAITurns :: PlaneRef -> DB () dbFinishPlanarAITurns plane_ref =- do (all_creatures_on_plane :: [CreatureRef]) <- dbGetContents plane_ref+ do sweepDead plane_ref+ (all_creatures_on_plane :: [CreatureRef]) <- dbGetContents plane_ref any_players_left <- liftM (any (== Player)) $ mapM getCreatureFaction all_creatures_on_plane next_turn <- dbNextTurn $ map generalizeReference all_creatures_on_plane ++ [generalizeReference plane_ref] case next_turn of@@ -55,25 +55,35 @@ return () _ -> error "dbFinishPlanarAITurns: impossible case" +planar_turn_frequency :: Integer+planar_turn_frequency = 100+ dbPerform1PlanarAITurn :: PlaneRef -> DB () dbPerform1PlanarAITurn plane_ref = do creature_locations <- dbGetContents plane_ref player_locations <- filterRO (liftM (== Player) . getCreatureFaction . entity) creature_locations native_locations <- filterRO (liftM (/= Player) . getCreatureFaction . entity) creature_locations- when (length native_locations < length player_locations * 2) $- do p <- roll $ map location player_locations- spawn_position <- pickRandomClearSite 5 0 0 p (== RecreantFactory) plane_ref- dbNewCreature Pirates recreant (Standing plane_ref spawn_position Here)- return ()- dbAdvanceTime (1%100) plane_ref+ should_randomly_generate_monster <- liftM (<= 10) $ linearRoll planar_turn_frequency+ when (length native_locations < length player_locations * 2 && should_randomly_generate_monster) $+ do p <- pickM $ map location player_locations+ m_spawn_position <- pickRandomClearSite_withTimeout (Just 2) 7 0 0 p (== RecreantFactory) plane_ref+ maybe (return () )+ (\spawn_position -> newCreature Pirates Recreant (Standing plane_ref spawn_position Here) >> return ()) $ + m_spawn_position+ dbAdvanceTime plane_ref (1%planar_turn_frequency) dbPerform1CreatureAITurn :: CreatureRef -> DB () dbPerform1CreatureAITurn creature_ref = atomic $ liftM (flip dbBehave creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $- do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects - my_position <- lift P.myPosition+ do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects (return . const True)+ (rand_x :: Integer) <- lift $ getRandomR (1,100)+ rand_face <- lift $ pickM [minBound..maxBound]+ (_,my_position) <- lift P.whereAmI let face_to_player = faceAt my_position (location player) return $ case distanceBetweenChessboard my_position (location player) of- 1 -> Attack $ face_to_player- _ -> Step $ face_to_player+ _ | rand_x < 5 -> Wait -- if AI gets stuck, this will make sure they waste time so the game doesn't hang+ _ | rand_x < 20 -> Step rand_face+ 1 -> Attack face_to_player+ -- x | x >= 10 -> Jump face_to_player -- disable this until we can handle non-player teleporting sanely+ _ -> Step face_to_player