summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopherLaneHinson <>2010-06-18 00:29:26 (GMT)
committerLuite Stegeman <luite@luite.com>2010-06-18 00:29:26 (GMT)
commitb67cdc0fd964a43ae48d49b113cecb509445e5cd (patch)
tree981208f0168d8a3b77331730e0301891b4245c68
parentcd8e1afe24674f017713047b42c33db70f749b2b (diff)
version 0.4.0.00.4.0.0
-rw-r--r--[-rwxr-xr-x]Setup.hs0
-rw-r--r--roguestar-engine.cabal41
-rw-r--r--src/Alignment.hs4
-rw-r--r--src/Attribute.hs31
-rw-r--r--src/AttributeData.hs34
-rw-r--r--src/AttributeGeneration.hs66
-rw-r--r--src/BeginGame.hs84
-rw-r--r--src/Behavior.hs171
-rw-r--r--src/Building.hs78
-rw-r--r--src/BuildingData.hs25
-rw-r--r--src/Character.hs90
-rw-r--r--src/CharacterData.hs3
-rw-r--r--src/Combat.hs263
-rw-r--r--src/Creature.hs133
-rw-r--r--src/CreatureAttribute.hs52
-rw-r--r--src/CreatureData.hs307
-rw-r--r--src/DB.hs242
-rw-r--r--src/DBData.hs68
-rw-r--r--src/DBPrivate.hs50
-rw-r--r--src/Dice.hs10
-rw-r--r--src/Facing.hs9
-rw-r--r--src/FactionData.hs23
-rw-r--r--src/GridRayCaster.hs1
-rw-r--r--src/Grids.hs145
-rw-r--r--src/HierarchicalDatabase.hs16
-rw-r--r--src/HopList.hs109
-rw-r--r--src/ListUtils.hs96
-rw-r--r--src/Main.hs8
-rw-r--r--src/Perception.hs68
-rw-r--r--src/Plane.hs145
-rw-r--r--src/PlaneData.hs6
-rw-r--r--src/PlaneVisibility.hs64
-rw-r--r--src/Position.hs61
-rw-r--r--src/Protocol.hs715
-rw-r--r--src/RNG.hs62
-rw-r--r--src/Races.hs261
-rw-r--r--src/RandomUtils.hs18
-rw-r--r--src/SegHopList.hs20
-rw-r--r--src/SegmentList.hs36
-rw-r--r--src/Species.hs140
-rw-r--r--src/SpeciesData.hs74
-rw-r--r--src/Substances.hs144
-rw-r--r--src/Terrain.hs29
-rw-r--r--src/TerrainData.hs34
-rw-r--r--src/Tool.hs54
-rw-r--r--src/ToolData.hs167
-rw-r--r--src/Town.hs18
-rw-r--r--src/Travel.hs53
-rw-r--r--src/Turns.hs40
49 files changed, 2563 insertions, 1805 deletions
diff --git a/Setup.hs b/Setup.hs
index 64b897b..64b897b 100755..100644
--- a/Setup.hs
+++ b/Setup.hs
diff --git a/roguestar-engine.cabal b/roguestar-engine.cabal
index 8cd4a93..0bebdf5 100644
--- a/roguestar-engine.cabal
+++ b/roguestar-engine.cabal
@@ -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 @@ description: Roguestar is a science fiction themed roguelike (turn-based
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
diff --git a/src/Alignment.hs b/src/Alignment.hs
index 6998a36..e5ab198 100644
--- a/src/Alignment.hs
+++ b/src/Alignment.hs
@@ -8,8 +8,8 @@ module Alignment
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]
diff --git a/src/Attribute.hs b/src/Attribute.hs
deleted file mode 100644
index 91f7dc6..0000000
--- a/src/Attribute.hs
+++ /dev/null
@@ -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
diff --git a/src/AttributeData.hs b/src/AttributeData.hs
deleted file mode 100644
index 1d4f21a..0000000
--- a/src/AttributeData.hs
+++ /dev/null
@@ -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"
diff --git a/src/AttributeGeneration.hs b/src/AttributeGeneration.hs
new file mode 100644
index 0000000..5c02823
--- /dev/null
+++ b/src/AttributeGeneration.hs
@@ -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
diff --git a/src/BeginGame.hs b/src/BeginGame.hs
index 60d3e7a..432a4fa 100644
--- a/src/BeginGame.hs
+++ b/src/BeginGame.hs
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE OverloadedStrings #-}
module BeginGame
(dbBeginGame)
where
@@ -7,35 +7,67 @@ import Plane
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 ()
+
+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]
-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)]
+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 @@ dbBeginGame creature character_class =
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
diff --git a/src/Behavior.hs b/src/Behavior.hs
index c328abe..28874fb 100644
--- a/src/Behavior.hs
+++ b/src/Behavior.hs
@@ -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 @@ import Control.Monad.Maybe
data Behavior =
Step Facing
| TurnInPlace Facing
+ | Jump Facing
| Pickup ToolRef
| Wield ToolRef
| Unwield
@@ -31,57 +41,164 @@ data Behavior =
| 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
diff --git a/src/Building.hs b/src/Building.hs
new file mode 100644
index 0000000..ce9434a
--- /dev/null
+++ b/src/Building.hs
@@ -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
+
+
+
diff --git a/src/BuildingData.hs b/src/BuildingData.hs
new file mode 100644
index 0000000..c388aaf
--- /dev/null
+++ b/src/BuildingData.hs
@@ -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)]
+
diff --git a/src/Character.hs b/src/Character.hs
index fae3314..1a9a051 100644
--- a/src/Character.hs
+++ b/src/Character.hs
@@ -5,19 +5,21 @@ module Character
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 @@ getEligableBaseCharacterClasses = getEligableCharacterClassesComposable base_cha
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 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 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 second parameter is the list of 'CreatureAttribute's that a Creature gains when it levels in the
+-- 'CharacterClass'.
--
--- The third parameter is the list CreatureAttributes 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 :: CharacterClass -> CharacterClassData
--
-------------------------------------------------------------------------------
-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
diff --git a/src/CharacterData.hs b/src/CharacterData.hs
index 229874e..6685813 100644
--- a/src/CharacterData.hs
+++ b/src/CharacterData.hs
@@ -16,7 +16,7 @@ data CharacterClass = Barbarian
| 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 @@ base_character_classes = [Barbarian,
Shepherd,
Thief,
Warrior]
+
diff --git a/src/Combat.hs b/src/Combat.hs
index c662db2..b1cda3d 100644
--- a/src/Combat.hs
+++ b/src/Combat.hs
@@ -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 ToolData
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
-
-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
-
-data MeleeAttackOutcome =
- UnarmedAttackHitCreature CreatureRef CreatureRef Integer
- | UnarmedAttackMiss CreatureRef
-
-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
-
-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)
-
-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)
-
-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
-
-dbRollMeleeDamage :: (DBReadable db) => CreatureRef -> db Integer
-dbRollMeleeDamage attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeDamage 0 attacker_ref
-
-dbRollRangedAttack :: (DBReadable db) => CreatureRef -> db Integer
-dbRollRangedAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore RangedAttack 0 attacker_ref
-
-dbRollMeleeAttack :: (DBReadable db) => CreatureRef -> db Integer
-dbRollMeleeAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeAttack 0 attacker_ref
-
-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
-
-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
-
-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
+
+data AttackModel =
+ RangedAttackModel CreatureRef ToolRef Device
+ | MeleeAttackModel CreatureRef ToolRef Device
+ | UnarmedAttackModel CreatureRef
+
+attacker :: AttackModel -> CreatureRef
+attacker (RangedAttackModel attacker_ref _ _) = attacker_ref
+attacker (MeleeAttackModel attacker_ref _ _) = attacker_ref
+attacker (UnarmedAttackModel attacker_ref) = attacker_ref
+
+weapon :: AttackModel -> Maybe ToolRef
+weapon (RangedAttackModel _ weapon_ref _) = Just weapon_ref
+weapon (MeleeAttackModel _ weapon_ref _) = Just weapon_ref
+weapon (UnarmedAttackModel {}) = Nothing
+
+instance DeviceType AttackModel where
+ toPseudoDevice (RangedAttackModel _ _ d) = toPseudoDevice d
+ toPseudoDevice (MeleeAttackModel _ _ d) = toPseudoDevice d
+ toPseudoDevice (UnarmedAttackModel {}) = PseudoDevice 0 0 0 1
+
+interactionMode :: AttackModel -> CreatureInteractionMode
+interactionMode (RangedAttackModel {}) = Ranged
+interactionMode (MeleeAttackModel {}) = Melee
+interactionMode (UnarmedAttackModel {}) = Unarmed
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+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
+
+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)
+
+data DefenseOutcome = DefenseOutcome {
+ do_defender_wield :: Maybe ToolRef,
+ do_skill_roll :: Integer,
+ do_damage_reduction :: Integer,
+ do_disarm_bonus :: Integer }
+
+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
+
+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
+
diff --git a/src/Creature.hs b/src/Creature.hs
index cf59188..b43c10a 100644
--- a/src/Creature.hs
+++ b/src/Creature.hs
@@ -1,85 +1,131 @@
{-# 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 }
+
+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
-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
+-- | 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 }
+
+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)
-dbGetDead :: (DBReadable db) => Reference a -> db [CreatureRef]
-dbGetDead parent_ref = filterRO (liftM (\c -> creatureScore HitPoints c <= 0) . dbGetCreature) =<< dbGetContents parent_ref
+getDead :: (DBReadable db) => Reference a -> db [CreatureRef]
+getDead parent_ref = filterRO (liftM (<= 0) . getCreatureHealth) =<< dbGetContents parent_ref
deleteCreature :: CreatureRef -> DB ()
deleteCreature = dbUnsafeDeleteObject $ \l ->
@@ -88,9 +134,10 @@ deleteCreature = dbUnsafeDeleteObject $ \l ->
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
diff --git a/src/CreatureAttribute.hs b/src/CreatureAttribute.hs
new file mode 100644
index 0000000..397a0b8
--- /dev/null
+++ b/src/CreatureAttribute.hs
@@ -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
diff --git a/src/CreatureData.hs b/src/CreatureData.hs
index 944d31a..8ab34ee 100644
--- a/src/CreatureData.hs
+++ b/src/CreatureData.hs
@@ -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
-
-data Creature = Creature { creature_stats :: Stats,
- creature_attribs :: [CreatureAttribute],
- creature_species_name :: String,
+import Data.Monoid
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import SpeciesData
+import TerrainData
+
+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
-
-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)
-
-data Score = MaxHitPoints
- | HitPoints
- | DamageReduction
- | MeleeAttack
- | MeleeDefense
- | MeleeDamage
- | RangedAttack
- | RangedDefense
- | Speed Statistic
- | EffectiveLevel
- | Spot
- | Hide
-
--- |
--- 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 }
-
-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
-
--- |
--- 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))
-
-attributeCount :: CreatureAttribute -> Creature -> Integer
-attributeCount attrib creature = count attrib $ creature_attribs creature
-
--- |
--- 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
-
--- |
--- 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.
+-- | Creature having no attributes and undefined 'creature_species', 'creature_random_id', and 'creature_faction'
--
-characterClassLevels :: CharacterClass -> Creature -> Integer
-characterClassLevels character_class creature = count (CharacterLevel character_class) (creature_attribs creature)
+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" }
--- |
--- 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
-
--- |
--- 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
-
--- |
--- applyCreatureAttribute with no special handling.
---
-putCreatureAttribute :: CreatureAttribute -> Creature -> Creature
-putCreatureAttribute attrib creature = creature { creature_attribs = (attrib : (creature_attribs creature))}
-
-incCreatureStat :: Statistic -> Creature -> Creature
-incCreatureStat statistic creature =
- let sts = creature_stats creature
- in creature { creature_stats = setStatistic statistic (succ $ getStatistic statistic sts) sts }
+data CreatureGender = Male | Female | Neuter deriving (Eq,Read,Show)
-genderOf :: CreatureAttribute -> Maybe CreatureGender
-genderOf attrib = case attrib of
- Gender gender -> Just gender
- _ -> Nothing
+-- | 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
+
+-- | Primitive numeric properties of a Creature.
+class CreatureScore s where
+ rawScore :: s -> Creature -> Integer
+
+instance (CreatureEndo a,Integral i) => CreatureEndo (a,i) where
+ applyToCreature (_,i) | i <= 0 = id
+ applyToCreature (a,i) = applyToCreature (a,toInteger i - 1) . applyToCreature a
+
+instance (CreatureEndo a) => CreatureEndo [a] where
+ applyToCreature = appEndo . mconcat . map (Endo . applyToCreature)
+
+instance CreatureEndo CreatureGender where
+ applyToCreature g c = c { creature_gender = g }
+
+-- | The seven aptitudes.
+data CreatureAptitude =
+ Strength
+ | Speed
+ | Constitution
+ | Intellect
+ | Perception
+ | Charisma
+ | Mindfulness
+ deriving (Eq,Read,Show,Ord,Enum,Bounded)
+
+instance CreatureEndo CreatureAptitude where
+ applyToCreature aptitude c = c { creature_aptitude = Map.insertWith (+) aptitude 1 $ creature_aptitude c }
+
+instance CreatureScore CreatureAptitude where
+ rawScore aptitude c = fromMaybe 0 $ Map.lookup aptitude (creature_aptitude c)
+
+-- | 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)
+
+data CreatureAbility =
+ ToughnessTrait
+ | AttackSkill CreatureInteractionMode
+ | DefenseSkill CreatureInteractionMode
+ | DamageSkill CreatureInteractionMode
+ | DamageReductionTrait CreatureInteractionMode
+ | ReloadSkill CreatureInteractionMode
+ | TerrainAffinity TerrainPatch
+ | HideSkill
+ | SpotSkill
+ | JumpSkill
+ | InventorySkill
+ deriving (Eq,Read,Show,Ord)
+
+instance CreatureEndo CreatureAbility where
+ applyToCreature ability c = c { creature_ability = Map.insertWith (+) ability 1 $ creature_ability c }
+
+instance CreatureScore CreatureAbility where
+ rawScore ability c = fromMaybe 0 $ Map.lookup ability $ creature_ability c
+
+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)
+
diff --git a/src/DB.hs b/src/DB.hs
index f733f21..7c692b1 100644
--- a/src/DB.hs
+++ b/src/DB.hs
@@ -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 @@ module DB
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 ToolData
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 @@ data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
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
+
+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 })
-class (Monad db,MonadError DBError db,MonadReader DB_BaseType db) => DBReadable db where
- dbNextRandomInteger :: db Integer
- dbNextRandomIntegerStream :: db [Integer]
+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 :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
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 @@ initial_db = DB_BaseType {
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 @@ playerState = asks db_player_state
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) => CreatureLocation l where
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 Inventory where
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 @@ dbAddCreature = dbAddObjectComposable CreatureRef dbPutCreature creatureLocation
-- |
-- 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 :: (ToolLocation l) => Tool -> l -> DB ToolRef
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 @@ dbUnsafeDeleteObject :: (ReferenceType e) =>
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,29 +365,41 @@ dbPutTool :: ToolRef -> Tool -> DB ()
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.
@@ -393,13 +427,22 @@ dbModTool :: (Tool -> Tool) -> ToolRef -> DB ()
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 @@ dbUnwieldCreature c = mapM_ (dbSetLocation . returnToInventory) =<< dbGetContent
-- 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 @@ dbMove moveF ref =
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 @@ dbSetTimeCoordinate ref tc = modify (\db -> db { db_time_coordinates = Map.inser
-- |
-- 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 @@ dbGetStartingRace = do gets db_starting_race
-- 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 @@ popOldestSnapshot db =
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 ()
diff --git a/src/DBData.hs b/src/DBData.hs
index 4beb828..37c953e 100644
--- a/src/DBData.hs
+++ b/src/DBData.hs
@@ -6,9 +6,10 @@ module DBData
CreatureRef,
PlaneRef,
ToolRef,
+ BuildingRef,
TheUniverse(..),
the_universe,
- (=:=),
+ (=:=), (=/=),
GenericReference(..),
locationsOf,
ReferenceType(..),
@@ -19,18 +20,25 @@ module DBData
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 DBPrivate
import ToolData
import CreatureData
import PlaneData
+import BuildingData
import Data.Maybe
import Control.Monad
import Position
@@ -81,6 +90,9 @@ _tool = Type $ error "_tool: undefined"
_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 @@ _inventory = Type $ error "_inventory: undefined"
_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 @@ class GenericReference a m | a -> m where
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 @@ locationsOf = liftM (map location)
(=:=) :: (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 @@ instance ReferenceType Creature where
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 (IsStanding _ s) = unsafeReference $ standing_plane s
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 @@ instance LocationType Wielded where
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,7 +312,14 @@ instance LocationType Position where
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
@@ -263,7 +327,9 @@ instance LocationType Facing where
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
diff --git a/src/DBPrivate.hs b/src/DBPrivate.hs
index 99c401f..8b2a760 100644
--- a/src/DBPrivate.hs
+++ b/src/DBPrivate.hs
@@ -13,10 +13,13 @@ module DBPrivate
Dropped(..),
Inventory(..),
Wielded(..),
+ Constructed(..),
TheUniverse(..),
+ Subsequent(..),
CreatureRef,
ToolRef,
- PlaneRef)
+ PlaneRef,
+ BuildingRef)
where
import HierarchicalDatabase
@@ -24,6 +27,7 @@ import Facing
import CreatureData
import ToolData
import PlaneData
+import BuildingData
import Position
--
@@ -39,11 +43,12 @@ import Position
-- |
-- 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 @@ type PlaneRef = Reference Plane
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 :: Reference a -> Reference b
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 @@ data Dropped =
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 Inventory =
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 @@ data Location m e t =
| 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 (IsStanding a b) = IsStanding a b
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
diff --git a/src/Dice.hs b/src/Dice.hs
deleted file mode 100644
index ef989a3..0000000
--- a/src/Dice.hs
+++ /dev/null
@@ -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
diff --git a/src/Facing.hs b/src/Facing.hs
index cae9f8f..5a84430 100644
--- a/src/Facing.hs
+++ b/src/Facing.hs
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE OverloadedStrings #-}
module Facing
(Facing(..),
facingToRelative,
@@ -12,6 +12,7 @@ module Facing
import Position
import Data.Ord
import Data.List
+import qualified Data.ByteString.Char8 as B
data Facing = North
| NorthEast
@@ -29,7 +30,7 @@ data Facing = North
-- 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 @@ facingDistance a b = toInteger $ if enum_distance > 4 then 8 - enum_distance els
-- |
-- 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
diff --git a/src/FactionData.hs b/src/FactionData.hs
index 2a06c77..e47367b 100644
--- a/src/FactionData.hs
+++ b/src/FactionData.hs
@@ -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 @@ data Faction = Player
| 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"
diff --git a/src/GridRayCaster.hs b/src/GridRayCaster.hs
index 65499bb..fb4584d 100644
--- a/src/GridRayCaster.hs
+++ b/src/GridRayCaster.hs
@@ -9,7 +9,6 @@ import Data.Set as Set
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
diff --git a/src/Grids.hs b/src/Grids.hs
index ebf65ad..7ca0ada 100644
--- a/src/Grids.hs
+++ b/src/Grids.hs
@@ -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
-
-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)
-
-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)
-
-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
-
-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)
-
-fromPersistant_tupled :: (Ord a) => (Grid_Persistant a,String) -> (Grid a,String)
-fromPersistant_tupled (x,y) = (fromPersistant x,y)
-
-instance (Show a) => Show (Grid a) where
- show grid = show $ toPersistant grid
-
-instance (Ord a, Read a) => Read (Grid a) where
- readsPrec n = \x -> Prelude.map fromPersistant_tupled (readsPrec n x)
-
-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) =
+import Data.List as List
+import Random
+import Data.MemoCombinators
+import Control.Arrow
+
+newtype SeededGrid = SeededGrid Integer deriving (Read,Show)
+data StorableCachedGrid a = StorableCachedGrid (Grid a) ((Integer,Integer) -> a)
+
+instance (Show a) => Show (StorableCachedGrid a) where
+ show (StorableCachedGrid g _) = show g
+
+instance (Read a,Ord a) => Read (StorableCachedGrid a) where
+ readsPrec = (List.map (first storableCachedGrid) .) . readsPrec
+
+storableCachedGrid :: (Ord a) => Grid a -> StorableCachedGrid a
+storableCachedGrid g = StorableCachedGrid g $ pair integral integral $ gridAt g
+
+seededGrid :: Integer -> SeededGrid
+seededGrid n = SeededGrid n
+
+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)
+
+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 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 @@ cachedGridOf any_other_grid = CachedGrid (cachedAccessor2D (gridAt any_other_gri
-- 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 }
+
diff --git a/src/HierarchicalDatabase.hs b/src/HierarchicalDatabase.hs
index e05acf8..bc4f984 100644
--- a/src/HierarchicalDatabase.hs
+++ b/src/HierarchicalDatabase.hs
@@ -20,6 +20,7 @@ import Data.List as List
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 @@ instance (Integral a,Integral b) => HierarchicalRelation (a,b) where
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 @@ delete x the_map =
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)
diff --git a/src/HopList.hs b/src/HopList.hs
deleted file mode 100644
index 0b9db67..0000000
--- a/src/HopList.hs
+++ /dev/null
@@ -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)
diff --git a/src/ListUtils.hs b/src/ListUtils.hs
deleted file mode 100644
index e8f5c30..0000000
--- a/src/ListUtils.hs
+++ /dev/null
@@ -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
diff --git a/src/Main.hs b/src/Main.hs
index 575059f..4f2cad2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,19 +4,14 @@ module Main (main)
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 :: String -> IO ()
runByArgs "tests" = do testsPassed <- runAllTests ([sampleTestCase] ++
insidenessTests ++
- hopListTests ++
gridRayCasterTests)
if testsPassed
then putStrLn "All tests passed."
diff --git a/src/Perception.hs b/src/Perception.hs
index 70549f0..cb17090 100644
--- a/src/Perception.hs
+++ b/src/Perception.hs
@@ -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 @@ module Perception
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 @@ instance (DBReadable db) => Monad (DBPerception db) where
(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 @@ getCreatureFaction creature_ref = liftDB $ Creature.getCreatureFaction creature_
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
+
diff --git a/src/Plane.hs b/src/Plane.hs
index 2bb2d63..8b5e272 100644
--- a/src/Plane.hs
+++ b/src/Plane.hs
@@ -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 :: (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
-dbNewPlane :: TerrainGenerationData -> DB PlaneRef
-dbNewPlane tg_data =
- do rns <- dbNextRandomIntegerStream
- dbAddPlane (Plane { plane_terrain = generateTerrain tg_data rns }) ()
+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 @@ dbDistanceBetweenSquared a_ref b_ref =
-- 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 @@ dbGetCurrentPlane =
--
-- 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
diff --git a/src/PlaneData.hs b/src/PlaneData.hs
index cddce3b..4646240 100644
--- a/src/PlaneData.hs
+++ b/src/PlaneData.hs
@@ -4,7 +4,11 @@ module PlaneData
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)
diff --git a/src/PlaneVisibility.hs b/src/PlaneVisibility.hs
index 210ab50..93d54ec 100644
--- a/src/PlaneVisibility.hs
+++ b/src/PlaneVisibility.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, FlexibleContexts #-}
+{-# LANGUAGE PatternGuards, FlexibleContexts, ScopedTypeVariables, RankNTypes #-}
module PlaneVisibility
(dbGetVisibleTerrainForFaction,
@@ -12,17 +12,19 @@ import Plane
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 @@ dbGetVisibleTerrainForFaction faction plane_ref =
--
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 @@ dbGetVisibleTerrainForCreature creature_ref =
-- |
-- 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))) $
diff --git a/src/Position.hs b/src/Position.hs
index 6a59cd5..2925345 100644
--- a/src/Position.hs
+++ b/src/Position.hs
@@ -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] }
+
+instance Eq MultiPosition where
+ (==) (MultiPosition as) (MultiPosition bs) = Set.fromList as == Set.fromList bs
+
+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
-distanceBetweenSquared :: Position -> Position -> Integer
-distanceBetweenSquared (Position (x,y)) (Position (u,v)) = (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)
-distanceBetweenChessboard :: Position -> Position -> Integer
-distanceBetweenChessboard (Position (x,y)) (Position (u,v)) = 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)
diff --git a/src/Protocol.hs b/src/Protocol.hs
index 18603a5..a1253fa 100644
--- a/src/Protocol.hs
+++ b/src/Protocol.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, PatternSignatures #-}
+{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, OverloadedStrings #-}
module Protocol
(mainLoop)
@@ -9,40 +9,119 @@ import Data.List as List
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
-
-done :: DB String
-done = return "done"
+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
+
+-- | 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 =
@@ -53,199 +132,266 @@ dbOldestSnapshotOnly =
-- 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
+ _ -> throwError $ DBError $ "protocol-error: not in player turn state (" ++ show state ++ ")"
-ioDispatch ("save":_) db0 = do putStrLn "engine-error: save not implemented"
- return db0
-
-ioDispatch ("load":_) db0 = do putStrLn "engine-error: load not implemented"
- return db0
-
-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,31 +400,65 @@ dbDispatchQuery ["center-coordinates","0"] = dbRequiresPlanarTurnState dbQueryCe
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
+
+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
-dbDispatchAction :: [String] -> DB String
-dbDispatchAction ["continue"] = dbPopOldestSnapshot >> done
+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 ["reroll"] =
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 []
+
+-- |
+-- 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.
+--
+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-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.
+-- Generate a tool menu table in text form, with the specified name and element list.
--
-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)]
+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"
-- |
--- Information about non-owned tools.
+-- Information about player creatures (for which the player should have almost all available information.)
--
-toolData :: Tool -> [(String,String)]
-toolData g@(GunTool {}) = [("tool-type","gun"),
- ("tool",toolName g)]
+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 String
+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
diff --git a/src/RNG.hs b/src/RNG.hs
index f2fa2ff..b88ee73 100644
--- a/src/RNG.hs
+++ b/src/RNG.hs
@@ -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
diff --git a/src/Races.hs b/src/Races.hs
deleted file mode 100644
index b77ef78..0000000
--- a/src/Races.hs
+++ /dev/null
@@ -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"
- }
diff --git a/src/RandomUtils.hs b/src/RandomUtils.hs
deleted file mode 100644
index 8846e3e..0000000
--- a/src/RandomUtils.hs
+++ /dev/null
@@ -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
diff --git a/src/SegHopList.hs b/src/SegHopList.hs
deleted file mode 100644
index c21c089..0000000
--- a/src/SegHopList.hs
+++ /dev/null
@@ -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)
diff --git a/src/SegmentList.hs b/src/SegmentList.hs
deleted file mode 100644
index 0dea1bf..0000000
--- a/src/SegmentList.hs
+++ /dev/null
@@ -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)
diff --git a/src/Species.hs b/src/Species.hs
index 0294205..690e58a 100644
--- a/src/Species.hs
+++ b/src/Species.hs
@@ -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
-
---
--- 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) )
+import CreatureAttribute
+import Data.Monoid
+import TerrainData
+
+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]
+
diff --git a/src/SpeciesData.hs b/src/SpeciesData.hs
index 5714057..1db80d7 100644
--- a/src/SpeciesData.hs
+++ b/src/SpeciesData.hs
@@ -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"
- }
diff --git a/src/Substances.hs b/src/Substances.hs
index 9f63659..a0711d9 100644
--- a/src/Substances.hs
+++ b/src/Substances.hs
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE OverloadedStrings #-}
module Substances
(Gas(..),
Material(..),
@@ -6,11 +6,16 @@ module Substances
Solid(..),
materialValue,
MaterialValue(..),
- Substance,
+ Substance(..),
+ SubstanceType(toSubstance),
+ coerceSubstance,
+ isGas,
+ isMaterial,
+ isChromalite,
substances,
prettySubstance,
printSubstances,
- gasWeight,
+ gasValue,
chromaliteAlignment,
chromalitePotency)
where
@@ -18,6 +23,8 @@ module Substances
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 @@ substances = map GasSubstance [minBound..maxBound] ++
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 @@ data Gas =
| Krypton
| Xenon
| Radon
+ | Methane
+ | Ammonia
+ | Iodine
| Chlorine deriving (Eq,Enum,Ord,Show,Read,Bounded)
data Material =
@@ -76,6 +87,8 @@ data Material =
| Carbon
| Wood
| Plastic
+ | Silicon
+ | Nickel
deriving (Eq,Enum,Ord,Show,Read,Bounded)
--
@@ -104,45 +117,51 @@ data Chromalite =
| 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 Diabolite = (Evil,Diplomatic)
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
diff --git a/src/Terrain.hs b/src/Terrain.hs
deleted file mode 100644
index 47ddb39..0000000
--- a/src/Terrain.hs
+++ /dev/null
@@ -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
diff --git a/src/TerrainData.hs b/src/TerrainData.hs
index 7751511..a2df7f3 100644
--- a/src/TerrainData.hs
+++ b/src/TerrainData.hs
@@ -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 @@ data Biome = RockBiome
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 Biome = RockBiome
--
data TerrainPatch = RockFace
| Rubble
- | Ore Solid
+ | Ore
| RockyGround
| Dirt
| Grass
@@ -71,7 +72,7 @@ data TerrainPlacement = TerrainPlacement {
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,7 +98,14 @@ recreantFactories seed = TerrainPlacement {
-- 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)]
@@ -144,7 +152,7 @@ terrainInterpMap = let terrain_patch_pairs = [(a,b) | a <- baseTerrainPatches, b
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 @@ type TerrainMap = Grid TerrainPatch
-- 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 @@ generateTerrain tg rands = flip (foldr placeTerrain) (tg_placements tg) $
terrainPatchToASCII :: TerrainPatch -> Char
terrainPatchToASCII RockFace = '#'
terrainPatchToASCII Rubble = '*'
-terrainPatchToASCII (Ore _) = '$'
+terrainPatchToASCII Ore = '$'
terrainPatchToASCII RockyGround = ':'
terrainPatchToASCII Dirt = '.'
terrainPatchToASCII Grass = ','
@@ -183,10 +191,10 @@ exampleTerrainGenerator = TerrainGenerationData
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]]
diff --git a/src/Tool.hs b/src/Tool.hs
index fb85058..2f4fd8f 100644
--- a/src/Tool.hs
+++ b/src/Tool.hs
@@ -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 @@ dbAvailablePickups creature_ref =
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
diff --git a/src/ToolData.hs b/src/ToolData.hs
index f40a61c..efd9bc5 100644
--- a/src/ToolData.hs
+++ b/src/ToolData.hs
@@ -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 GunSize = Pistol
- | Carbine
- | Rifle
- | Cannon
- | Launcher
- deriving (Read,Show,Eq)
-
-data Gun = Gun {
- gun_name :: String,
- gun_power_cell :: Chromalite,
- gun_substrate :: Material,
- gun_casing :: Material,
- gun_medium :: Gas,
- gun_size :: GunSize }
+data Tool = DeviceTool DeviceFunction Device
+ | Sphere Substance
+ 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
+
+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
+
+phaser :: Tool
+phaser = device "phaser" Carbine Caerulite Zinc Flourine
+
+phase_rifle :: Tool
+phase_rifle = device "phase_rifle" Rifle Caerulite Zinc Flourine
+
+kinetic_fleuret :: Tool
+kinetic_fleuret = device "kinetic_fleuret" Fleuret Ionidium Aluminum Nitrogen
+
+kinetic_sabre :: Tool
+kinetic_sabre = device "kinetic_sabre" Sabre Ionidium Aluminum Nitrogen
+
+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
-gunEnergyOutput :: Gun -> Integer
-gunEnergyOutput g = gunSizeClass g * (chromalitePotency $ gun_power_cell g)
+deviceSpeed :: (DeviceType d) => d -> Integer
+deviceSpeed = pdevice_speed . toPseudoDevice
-gunThroughput :: Gun -> Integer
-gunThroughput g = ((material_critical_value $ materialValue $ gun_substrate g) + 1) *
- (gasWeight $ gun_medium g)
+deviceSize :: (DeviceType d) => d -> Integer
+deviceSize = pdevice_size . toPseudoDevice
-gunEndurance :: Gun -> Integer
-gunEndurance g = 10 * (material_construction_value $ materialValue $ gun_casing g)^2
+deviceChromalite :: Device -> Chromalite
+deviceChromalite = device_chromalite
-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
+deviceMaterial :: Device -> Material
+deviceMaterial = device_material
-toolName :: Tool -> String
-toolName (GunTool (Gun { gun_name = s })) = s
+deviceGas :: Device -> Gas
+deviceGas = device_gas
diff --git a/src/Town.hs b/src/Town.hs
new file mode 100644
index 0000000..7c9648a
--- /dev/null
+++ b/src/Town.hs
@@ -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 }
diff --git a/src/Travel.hs b/src/Travel.hs
index 7727dc4..5c711a6 100644
--- a/src/Travel.hs
+++ b/src/Travel.hs
@@ -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 ())
@@ -28,3 +36,42 @@ stepCreature face = walkCreature face (facingToRelative face)
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 ()
+
diff --git a/src/Turns.hs b/src/Turns.hs
index fd8ece7..31eb9df 100644
--- a/src/Turns.hs
+++ b/src/Turns.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, PatternSignatures #-}
+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
module Turns
(dbPerformPlayerTurn)
@@ -7,20 +7,19 @@ module Turns
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 @@ dbFinishPendingAITurns =
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 @@ dbFinishPlanarAITurns plane_ref =
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