diff --git a/roguestar-engine.cabal b/roguestar-engine.cabal --- 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 +author: Christopher Lane Hinson maintainer: Christopher Lane Hinson category: Game @@ -12,30 +12,39 @@ provides the core game engine; you'll probably want to also install the OpenGL client. . - This initial release allows you to play one of six alien races. You begin - the game stranded on an alien planet, fighting off an endless hoard of - hostile robots. - . The git repository is available at . 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 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -8,8 +8,8 @@ alignmentPotency) where -data MoralAlignment = Lawful | Neutral | Chaotic | Evil deriving (Eq,Read,Show) -data EthicalAlignment = Strategic | Tactical | Diplomatic | Indifferent deriving (Eq,Read,Show) +data MoralAlignment = Lawful | Neutral | Chaotic | Evil deriving (Eq,Read,Show,Ord) +data EthicalAlignment = Strategic | Tactical | Diplomatic | Indifferent deriving (Eq,Read,Show,Ord) type Alignment = (MoralAlignment,EthicalAlignment) alignments :: [Alignment] diff --git a/src/Attribute.hs b/src/Attribute.hs deleted file mode 100644 --- 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 --- 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 --- /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 --- a/src/BeginGame.hs +++ b/src/BeginGame.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE OverloadedStrings #-} module BeginGame (dbBeginGame) where @@ -7,35 +7,67 @@ import CreatureData import Character import CharacterData +import BuildingData import DB -import DBData import Facing import TerrainData -import Data.Maybe import ToolData +import Control.Monad +import SpeciesData +import Substances +import PlayerState +import Town +import PlanetData +import Planet +import qualified Data.ByteString.Char8 as B () -player_race_to_biome :: [(String,Biome)] -player_race_to_biome = - [("anachronid",DesertBiome), - ("androsynth",RockBiome), - ("ascendant",MountainBiome), - ("canduceator",SwampBiome), - ("encephalon",GrasslandBiome{-SwampBiome-}), - ("goliath",DesertBiome), - ("hellion",GrasslandBiome), - ("kraken",OceanBiome), - ("myrmidon",DesertBiome), - ("perennial",ForestBiome), - ("recreant",DesertBiome), - ("reptilian",SwampBiome)] +homeBiome :: Species -> Biome +homeBiome Anachronid = ForestBiome +homeBiome Ascendant = MountainBiome +homeBiome Androsynth = IcyRockBiome +homeBiome Caduceator = GrasslandBiome +homeBiome Encephalon = SwampBiome +homeBiome Goliath = DesertBiome +homeBiome Hellion = SwampBiome +homeBiome Kraken = OceanBiome +homeBiome Myrmidon = DesertBiome +homeBiome Perennial = GrasslandBiome +homeBiome Recreant = TundraBiome +homeBiome Reptilian = ForestBiome +startingEquipmentByClass :: CharacterClass -> [Tool] +startingEquipmentByClass Barbarian = [kinetic_fleuret] +startingEquipmentByClass Consular = [sphere Silver] +startingEquipmentByClass Engineer = [sphere Crudnium,sphere Molybdenum,sphere Uranium] +startingEquipmentByClass ForceAdept = [kinetic_sabre] +startingEquipmentByClass Marine = [phase_pistol,phase_rifle] +startingEquipmentByClass Ninja = [] +startingEquipmentByClass Pirate = [phaser] +startingEquipmentByClass Scout = [phase_pistol] +startingEquipmentByClass Shepherd = [sphere Wood] +startingEquipmentByClass Thief = [sphere Platinum] +startingEquipmentByClass Warrior = [phaser,kinetic_fleuret] + +startingEquipmentBySpecies :: Species -> [Tool] +startingEquipmentBySpecies Anachronid = [sphere Radon] +startingEquipmentBySpecies Ascendant = [sphere Neon] +startingEquipmentBySpecies Androsynth = [sphere Silicon] +startingEquipmentBySpecies Caduceator = [sphere Silver] +startingEquipmentBySpecies Encephalon = [sphere Ammonia] +startingEquipmentBySpecies Goliath = [sphere Iron] +startingEquipmentBySpecies Hellion = [sphere Methane] +startingEquipmentBySpecies Kraken = [sphere Substances.Water] +startingEquipmentBySpecies Myrmidon = [sphere Krypton] +startingEquipmentBySpecies Perennial = [sphere Wood] +startingEquipmentBySpecies Recreant = [sphere Malignite] +startingEquipmentBySpecies Reptilian = [sphere Oxygen] + dbCreateStartingPlane :: Creature -> DB PlaneRef dbCreateStartingPlane creature = - do seed <- dbNextRandomInteger - dbNewPlane $ TerrainGenerationData { + do dbNewPlane (Just "belhaven") (TerrainGenerationData { tg_smootheness = 3, - tg_biome = fromMaybe GrasslandBiome $ lookup (creature_species_name creature) player_race_to_biome, - tg_placements = [recreantFactories seed] } + tg_biome = homeBiome $ creature_species creature, + tg_placements = [] }) TheUniverse -- | -- Begins the game with the specified starting player creature and the specified starting character class. @@ -47,6 +79,12 @@ plane_ref <- dbCreateStartingPlane creature landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref creature_ref <- dbAddCreature first_level_creature (Standing plane_ref landing_site Here) - phaser_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref - dbAddTool phase_pistol (Dropped plane_ref phaser_position) + _ <- createTown plane_ref [Portal,Monolith] + let starting_equip = startingEquipmentBySpecies (creature_species creature) ++ startingEquipmentByClass character_class + forM_ starting_equip $ \tool -> dbAddTool tool (Inventory creature_ref) + forM_ [0..10] $ \_ -> do tool_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref + tool_type <- weightedPickM [(8,phase_pistol),(5,phaser),(3,phase_rifle),(8,kinetic_fleuret),(3,kinetic_sabre), + (5,Sphere $ toSubstance Nitrogen),(5,Sphere $ toSubstance Ionidium),(5,Sphere $ toSubstance Aluminum)] + dbAddTool tool_type (Dropped plane_ref tool_position) + _ <- makePlanets (Subsequent plane_ref) =<< generatePlanetInfo all_planets setPlayerState $ PlayerCreatureTurn creature_ref NormalMode diff --git a/src/Behavior.hs b/src/Behavior.hs --- 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 @@ data Behavior = Step Facing | TurnInPlace Facing + | Jump Facing | Pickup ToolRef | Wield ToolRef | Unwield @@ -31,57 +41,164 @@ | Attack Facing | Wait | Vanish + | Activate + | Make PrepareMake + | ClearTerrain Facing + | ActivateBuilding Facing +-- | Get an appropriate behavior facing in the given direction. +-- If the adjacent facing square is empty, this is 'Step', but +-- if occupied by a creature this is 'Attack'. +facingBehavior :: (DBReadable db) => CreatureRef -> Facing -> db Behavior +facingBehavior creature_ref face = + do (m_standing :: Maybe (PlaneRef,Position)) <- liftM (fmap location) $ getPlanarPosition creature_ref + case m_standing of + Nothing -> return Wait + Just (plane_ref,pos) -> + do let facing_pos = offsetPosition (facingToRelative face) pos + t <- terrainAt plane_ref facing_pos + who :: [CreatureRef] <- whatIsOccupying plane_ref facing_pos + what :: [BuildingRef] <- whatIsOccupying plane_ref facing_pos + case t of + _ | not (null who) -> return $ Attack face + _ | not (null what) -> return $ ActivateBuilding face + Forest -> return $ TurnInPlace face + DeepForest -> return $ TurnInPlace face + RockFace -> return $ TurnInPlace face + _ -> return $ Step face + dbBehave :: Behavior -> CreatureRef -> DB () dbBehave (Step face) creature_ref = - do dbMove (stepCreature face) creature_ref - dbAdvanceTime (1%20) creature_ref + do (move_from,move_to) <- dbMove (stepCreature face) creature_ref + dbAdvanceTime creature_ref =<< case () of + () | (move_from == move_to) -> return 0 + () | face == Here -> quickActionTime creature_ref -- counts as turning in place + () | face `elem` [North,South,East,West] -> move1ActionTime creature_ref + () | otherwise -> move2ActionTime creature_ref +dbBehave (Jump face) creature_ref = + do atomic $ liftM executeTeleportJump $ resolveTeleportJump creature_ref face + dbAdvanceTime creature_ref =<< fullActionTime creature_ref + dbBehave (TurnInPlace face) creature_ref = - do dbMove (turnCreature face) creature_ref - dbAdvanceTime (1%40) creature_ref + do _ <- dbMove (turnCreature face) creature_ref + dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave (Pickup tool_ref) creature_ref = - do dbMove (dbPickupTool creature_ref) tool_ref - dbAdvanceTime (1%20) creature_ref + do _ <- dbMove (dbPickupTool creature_ref) tool_ref + dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave (Wield tool_ref) creature_ref = - do tool_parent <- liftM extractLocation $ dbWhere tool_ref - when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag "not-in-inventory" - dbMove dbWieldTool tool_ref - dbAdvanceTime (1%10) creature_ref + do available <- availableWields creature_ref + already_wielded <- dbGetWielded creature_ref + when (not $ tool_ref `elem` available) $ throwError $ DBErrorFlag ToolIs_Unreachable + _ <- dbMove dbWieldTool tool_ref + dbAdvanceTime creature_ref =<< case () of + () | Just tool_ref == already_wielded -> return 0 -- already wielded, so this was an empty action + () | otherwise -> quickActionTime creature_ref dbBehave (Unwield) creature_ref = do dbUnwieldCreature creature_ref - dbAdvanceTime (1%40) creature_ref + dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave (Drop tool_ref) creature_ref = do tool_parent <- liftM extractLocation $ dbWhere tool_ref - when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag "not-in-inventory" - dbMove dbDropTool tool_ref - return () + already_wielded <- dbGetWielded creature_ref + when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag ToolIs_NotInInventory + _ <- dbMove dbDropTool tool_ref + dbAdvanceTime creature_ref =<< case () of + () | Just tool_ref == already_wielded -> return 0 -- instantly drop a tool if it's already held in the hand + () | otherwise -> quickActionTime creature_ref dbBehave (Fire face) creature_ref = - do dbMove (turnCreature face) creature_ref - atomic $ liftM dbExecuteRangedAttack $ dbResolveRangedAttack creature_ref face - dbAdvanceTime (1%20) creature_ref + do _ <- dbMove (turnCreature face) creature_ref + ranged_attack_model <- rangedAttackModel creature_ref + atomic $ liftM executeAttack $ resolveAttack ranged_attack_model face + dbAdvanceTime creature_ref =<< quickActionTime creature_ref return () dbBehave (Attack face) creature_ref = - do dbMove (turnCreature face) creature_ref - atomic $ liftM dbExecuteMeleeAttack $ dbResolveMeleeAttack creature_ref face - dbAdvanceTime (1%20) creature_ref + do _ <- dbMove (turnCreature face) creature_ref + melee_attack_model <- meleeAttackModel creature_ref + atomic $ liftM executeAttack $ resolveAttack melee_attack_model face + dbAdvanceTime creature_ref =<< move1ActionTime creature_ref return () -dbBehave Wait creature_ref = - do dbAdvanceTime (1%40) creature_ref +dbBehave Wait creature_ref = dbAdvanceTime creature_ref =<< quickActionTime creature_ref dbBehave Vanish creature_ref = - do runMaybeT $ - do plane_ref <- MaybeT $ liftM (fmap $ fst . location) $ getPlanarLocation creature_ref + do dbAdvanceTime creature_ref =<< quickActionTime creature_ref + _ <- runMaybeT $ + do (plane_ref :: PlaneRef) <- MaybeT $ liftM (fmap location) $ getPlanarPosition creature_ref lift $ do faction <- getCreatureFaction creature_ref is_visible_to_anyone_else <- liftM (any (creature_ref `elem`)) $ - mapM (flip dbGetVisibleObjectsForFaction plane_ref) (delete faction [minBound..maxBound]) + mapM (\fact -> dbGetVisibleObjectsForFaction (return . const True) fact plane_ref) + ({- all factions except this one: -} delete faction [minBound..maxBound]) when (not is_visible_to_anyone_else) $ deleteCreature creature_ref - dbAdvanceTime (1%100) creature_ref + return () + +dbBehave Activate creature_ref = + do atomic $ liftM executeActivation $ resolveActivation creature_ref + dbAdvanceTime creature_ref =<< quickActionTime creature_ref + return () + +dbBehave (Make make_prep) creature_ref = + do atomic $ liftM executeMake $ resolveMake creature_ref make_prep + dbAdvanceTime creature_ref =<< fullActionTime creature_ref + return () + +dbBehave (ClearTerrain face) creature_ref = + do _ <- dbMove (turnCreature face) creature_ref + ok <- modifyFacingTerrain clearTerrain face creature_ref + when (not ok) $ throwError $ DBErrorFlag Unable + dbAdvanceTime creature_ref =<< fullActionTime creature_ref + return () + +dbBehave (ActivateBuilding face) creature_ref = + do _ <- dbMove (turnCreature face) creature_ref + ok <- activateFacingBuilding face creature_ref + when (not ok) $ throwError $ DBErrorFlag Unable + dbAdvanceTime creature_ref =<< fullActionTime creature_ref + +{--------------------------------------------------------------------------------------------------- +-- These are functions related to determing how long it takes for a creature to execute an action. +----------------------------------------------------------------------------------------------------} + +-- | A value indicating the degree of difficulty a creature suffers on account of the inventory it is carrying. +inventoryBurden :: (DBReadable db) => CreatureRef -> db Rational +inventoryBurden creature_ref = + do inventory_size <- liftM (genericLength . map (asReferenceTyped _tool)) $ dbGetContents creature_ref + inventory_skill <- liftM roll_ideal $ rollCreatureAbilityScore InventorySkill 0 creature_ref + return $ (inventory_size ^ 2) % inventory_skill + +-- | Multiplier penalty if a creature is overweighted. +overweightPenalty :: (DBReadable db) => CreatureRef -> db Rational +overweightPenalty = liftM (max 1.0) . inventoryBurden + +-- | Multiplier penalty if a creature is injured. +healthPenalty :: (DBReadable db) => CreatureRef -> db Rational +healthPenalty creature_ref = + do current_health <- getCreatureHealth creature_ref + raw_speed <- liftM (rawScore Speed) $ dbGetCreature creature_ref + return $ (max 1.0 $ recip $ max (1%raw_speed) current_health) -- maximum health penalty determined by speed + +-- | Multiplier penalties for doing anything that requires physical movement, e.g. walking. +physicalActionPenalties :: (DBReadable db) => CreatureRef -> db Rational +physicalActionPenalties creature_ref = liftM2 (*) (overweightPenalty creature_ref) (healthPenalty creature_ref) + +-- | Time required to do a simple physical task. +quickActionTime :: (DBReadable db) => CreatureRef -> db Rational +quickActionTime creature_ref = liftM2 (*) (physicalActionPenalties creature_ref) (liftM ((3%) . rawScore Speed) $ dbGetCreature creature_ref) + +-- | Time required to move one step. +move1ActionTime :: (DBReadable db) => CreatureRef -> db Rational +move1ActionTime creature_ref = liftM2 (*) (physicalActionPenalties creature_ref) (liftM ((5%) . rawScore Speed) $ dbGetCreature creature_ref) + +-- | Time required to move diagonally one step. +move2ActionTime :: (DBReadable db) => CreatureRef -> db Rational +move2ActionTime = liftM (*1.4142) . move1ActionTime + +-- | Time required to complete a complex physical action. +fullActionTime :: (DBReadable db) => CreatureRef -> db Rational +fullActionTime = liftM (*2) . move1ActionTime diff --git a/src/Building.hs b/src/Building.hs new file mode 100644 --- /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 --- /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 --- a/src/Character.hs +++ b/src/Character.hs @@ -5,19 +5,21 @@ applyCharacterClass) where -import Data.List as List import Alignment import CharacterData +import CreatureAttribute import CreatureData -import StatsData +import TerrainData type Prerequisite = Creature -> Bool -type CharacterClassData = (Prerequisite,[CreatureAttribute]) +data CharacterClassData = CharacterClassData { + character_class_prerequisite :: Prerequisite, + character_class_attributes :: CreatureAttribute } getEligableCharacterClassesComposable :: [CharacterClass] -> Creature -> [CharacterClass] getEligableCharacterClassesComposable allowed_classes creature = - filter (\x -> (fst $ classInfo x) creature) allowed_classes + filter (\x -> character_class_prerequisite (classInfo x) creature || isFavoredClass x creature) allowed_classes getEligableCharacterClasses :: Creature -> [CharacterClass] getEligableCharacterClasses = getEligableCharacterClassesComposable all_character_classes @@ -28,29 +30,23 @@ prerequisites :: [Prerequisite] -> Prerequisite prerequisites prereqs creature = all ($ creature) prereqs -mustHave :: Statistic -> Integer -> Prerequisite -mustHave statistic min_score creature = (getStatistic statistic $ creature_stats creature) >= min_score +mustHave :: (CreatureScore a) => a -> Integer -> Prerequisite +mustHave score min_score creature = (rawScore score creature) >= min_score -- | -- Constructor function for CharacterClassData objects. -- --- First parameter should be the CharacterClass. --- --- The second parameter should be the prerequisite (or more than one prerequisite using the prerequisites --- function). The prerequisite(s) restrict what Creatures can advance in the CharacterClass. +-- The first parameter should be the prerequisite (or more than one prerequisite using the 'prerequisites' +-- function). The prerequisite(s) restrict what 'Creatures' can advance in the 'CharacterClass'. -- --- The third parameter is the list CreatureAttributes that a Creature gains when it levels in the --- CharacterClass. +-- The second parameter is the list of 'CreatureAttribute's that a Creature gains when it levels in the +-- 'CharacterClass'. -- -characterClass :: CharacterClass -> Prerequisite -> [CreatureAttribute] -> CharacterClassData -characterClass character_class prereqs level_xforms = - ((\x -> prereqs x || isFavoredClass character_class x),CharacterLevel character_class : level_xforms) +characterClass :: Prerequisite -> CreatureAttribute -> CharacterClassData +characterClass prereqs attribs = CharacterClassData prereqs attribs applyCharacterClass :: CharacterClass -> Creature -> Creature -applyCharacterClass character_class creature = - if (fst $ classInfo character_class) creature - then foldr applyCreatureAttribute creature (snd $ classInfo character_class) - else error "tried to applyCharacterClass with a creature that didn't meet prerequisites" +applyCharacterClass character_class creature = applyToCreature (character_class & character_class_attributes (classInfo character_class)) creature classInfo :: CharacterClass -> CharacterClassData @@ -65,48 +61,36 @@ -- ------------------------------------------------------------------------------- -classInfo Barbarian = characterClass Barbarian (prerequisites [mustHave Strength 15,mustHave Constitution 15]) - [ToughnessTrait,DamageReductionTrait,SpeedTrait,StatBonus Constitution,StatBonus Strength,AlignmentBonus Indifferent] +classInfo Barbarian = characterClass (prerequisites [mustHave Strength 15,mustHave Constitution 15]) $ + DamageReductionTrait Melee & DamageReductionTrait Ranged & DamageReductionTrait Unarmed & ToughnessTrait & Speed & Constitution & Strength & Indifferent -classInfo Consular = characterClass Consular (mustHave Charisma 20) - [StatBonus Charisma,AlignmentBonus Diplomatic] +classInfo Consular = characterClass (mustHave Charisma 20) $ + Charisma & Diplomatic -classInfo Engineer = characterClass Engineer (mustHave Intelligence 20) - [StatBonus Intelligence,AlignmentBonus Strategic] +classInfo Engineer = characterClass (mustHave Intellect 20) $ + Intellect & Strategic -classInfo ForceAdept = characterClass ForceAdept (prerequisites [mustHave Intelligence 15, mustHave Perception 15, mustHave Charisma 15, mustHave Mindfulness 15]) - [RangedDefenseSkill,MeleeDefenseSkill,MeleeAttackSkill,StatBonus Perception,StatBonus Mindfulness,AlignmentBonus Indifferent] +classInfo ForceAdept = characterClass (prerequisites [mustHave Intellect 15, mustHave Perception 15, mustHave Charisma 15, mustHave Mindfulness 15]) $ + DefenseSkill Ranged & DefenseSkill Melee & AttackSkill Melee & Speed & Perception & Mindfulness & Indifferent -classInfo Marine = characterClass Marine (prerequisites [mustHave Perception 15,mustHave Constitution 15]) - [RangedAttackSkill, - RangedDefenseSkill, - StatBonus Constitution, - StatBonus Dexterity, - StatBonus Perception, - StatBonus Mindfulness, - AlignmentBonus Tactical] +classInfo Marine = characterClass (prerequisites [mustHave Perception 15,mustHave Constitution 15]) $ + AttackSkill Ranged & DefenseSkill Ranged & Constitution & Speed & Perception & Mindfulness & Tactical -classInfo Ninja = characterClass Ninja (prerequisites [mustHave Dexterity 15,mustHave Perception 15]) - [HideSkill,MeleeDefenseSkill,RangedDefenseSkill,StatBonus Dexterity,AlignmentBonus Indifferent] +classInfo Ninja = characterClass (prerequisites [mustHave Speed 15,mustHave Perception 15]) $ + HideSkill & DefenseSkill Melee & DefenseSkill Ranged & Speed & Indifferent -classInfo Pirate = characterClass Pirate (prerequisites [mustHave Strength 10,mustHave Perception 10, mustHave Dexterity 10, mustHave Charisma 10]) - [RangedAttackSkill,ToughnessTrait,StatBonus Strength,StatBonus Dexterity] +classInfo Pirate = characterClass (prerequisites [mustHave Strength 10,mustHave Perception 10, mustHave Speed 10, mustHave Charisma 10]) $ + AttackSkill Ranged & ToughnessTrait & Strength & Speed -classInfo Scout = characterClass Scout (prerequisites [mustHave Perception 20]) - [SpotSkill,StatBonus Dexterity,StatBonus Perception,AlignmentBonus Tactical] +classInfo Scout = characterClass (prerequisites [mustHave Perception 20]) $ + SpotSkill & Speed & Perception & Tactical -classInfo Shepherd = characterClass Shepherd (prerequisites [mustHave Charisma 15,mustHave Mindfulness 15]) - [SpotSkill,StatBonus Perception,StatBonus Mindfulness,AlignmentBonus Indifferent] +classInfo Shepherd = characterClass (prerequisites [mustHave Charisma 15,mustHave Mindfulness 15]) $ + SpotSkill & TerrainAffinity Grass & Perception & Mindfulness & Indifferent -classInfo Thief = characterClass Thief (mustHave Perception 20) - [HideSkill,StatBonus Dexterity,StatBonus Charisma,StatBonus Perception,AlignmentBonus Tactical] +classInfo Thief = characterClass (mustHave Perception 20) $ + HideSkill & Speed & Charisma & Perception & Tactical -classInfo Warrior = characterClass Warrior (prerequisites [mustHave Strength 15,mustHave Dexterity 15]) - [MeleeAttackSkill, - MeleeDefenseSkill, - StatBonus Constitution, - StatBonus Strength, - StatBonus Dexterity, - StatBonus Mindfulness, - AlignmentBonus Tactical] +classInfo Warrior = characterClass (prerequisites [mustHave Strength 15,mustHave Speed 15]) $ + AttackSkill Melee & DefenseSkill Melee & Constitution & Strength & Speed & Mindfulness & Tactical diff --git a/src/CharacterData.hs b/src/CharacterData.hs --- a/src/CharacterData.hs +++ b/src/CharacterData.hs @@ -16,7 +16,7 @@ | Shepherd | Thief | Warrior - deriving (Eq,Enum,Bounded,Read,Show) + deriving (Eq,Enum,Bounded,Read,Show,Ord) all_character_classes :: [CharacterClass] all_character_classes = [minBound..maxBound] @@ -33,3 +33,4 @@ Shepherd, Thief, Warrior] + diff --git a/src/Combat.hs b/src/Combat.hs --- 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 Control.Monad.Error import Facing import Data.Maybe +import DeviceActivation +import Contact import Plane -import Dice -import Data.List -import Data.Ord -import Position -data RangedAttackOutcome = - RangedAttackMiss CreatureRef ToolRef - | RangedAttackHitCreature CreatureRef ToolRef CreatureRef Integer +data AttackModel = + RangedAttackModel CreatureRef ToolRef Device + | MeleeAttackModel CreatureRef ToolRef Device + | UnarmedAttackModel CreatureRef -dbResolveRangedAttack :: (DBReadable db) => CreatureRef -> Facing -> db RangedAttackOutcome -dbResolveRangedAttack attacker_ref face = - do m_defender_ref <- liftM listToMaybe $ dbFindRangedTargets attacker_ref face - tool_ref <- maybe (throwError $ DBErrorFlag "no-weapon-wielded") return =<< dbGetWielded attacker_ref - attack_roll <- dbRollRangedAttack attacker_ref - damage_roll <- dbRollRangedDamage attacker_ref tool_ref - case m_defender_ref of - Nothing -> return $ RangedAttackMiss attacker_ref tool_ref - Just defender_ref -> - do defense_roll <- dbRollRangedDefense attacker_ref defender_ref - injury_roll <- dbRollInjury defender_ref damage_roll - return $ case () of - () | attack_roll > defense_roll -> RangedAttackHitCreature attacker_ref tool_ref defender_ref injury_roll - () | otherwise -> RangedAttackMiss attacker_ref tool_ref +attacker :: AttackModel -> CreatureRef +attacker (RangedAttackModel attacker_ref _ _) = attacker_ref +attacker (MeleeAttackModel attacker_ref _ _) = attacker_ref +attacker (UnarmedAttackModel attacker_ref) = attacker_ref -data MeleeAttackOutcome = - UnarmedAttackHitCreature CreatureRef CreatureRef Integer - | UnarmedAttackMiss CreatureRef +weapon :: AttackModel -> Maybe ToolRef +weapon (RangedAttackModel _ weapon_ref _) = Just weapon_ref +weapon (MeleeAttackModel _ weapon_ref _) = Just weapon_ref +weapon (UnarmedAttackModel {}) = Nothing -dbResolveMeleeAttack :: (DBReadable db) => CreatureRef -> Facing -> db MeleeAttackOutcome -dbResolveMeleeAttack attacker_ref face = - do m_defender_ref <- liftM listToMaybe $ dbFindMeleeTargets attacker_ref face - attack_roll <- dbRollMeleeAttack attacker_ref - damage_roll <- dbRollMeleeDamage attacker_ref - case m_defender_ref of - Nothing -> return $ UnarmedAttackMiss attacker_ref - Just defender_ref -> - do defense_roll <- dbRollMeleeDefense attacker_ref defender_ref - injury_roll <- dbRollInjury defender_ref damage_roll - return $ case () of - () | attack_roll > defense_roll -> UnarmedAttackHitCreature attacker_ref defender_ref injury_roll - () | otherwise -> UnarmedAttackMiss attacker_ref +instance DeviceType AttackModel where + toPseudoDevice (RangedAttackModel _ _ d) = toPseudoDevice d + toPseudoDevice (MeleeAttackModel _ _ d) = toPseudoDevice d + toPseudoDevice (UnarmedAttackModel {}) = PseudoDevice 0 0 0 1 -dbExecuteRangedAttack :: RangedAttackOutcome -> DB () -dbExecuteRangedAttack (RangedAttackMiss attacker_ref tool_ref) = - do dbPushSnapshot (MissEvent attacker_ref (Just tool_ref)) -dbExecuteRangedAttack (RangedAttackHitCreature attacker_ref tool_ref defender_ref damage) = - do dbPushSnapshot (AttackEvent attacker_ref (Just tool_ref) defender_ref) - dbInjureCreature damage defender_ref - sweepDead =<< liftM getLocation (dbWhere attacker_ref) +interactionMode :: AttackModel -> CreatureInteractionMode +interactionMode (RangedAttackModel {}) = Ranged +interactionMode (MeleeAttackModel {}) = Melee +interactionMode (UnarmedAttackModel {}) = Unarmed -dbExecuteMeleeAttack :: MeleeAttackOutcome -> DB () -dbExecuteMeleeAttack (UnarmedAttackMiss attacker_ref) = - do dbPushSnapshot (MissEvent attacker_ref Nothing) -dbExecuteMeleeAttack (UnarmedAttackHitCreature attacker_ref defender_ref damage) = - do dbPushSnapshot (AttackEvent attacker_ref Nothing defender_ref) - dbInjureCreature damage defender_ref - sweepDead =<< liftM getLocation (dbWhere attacker_ref) +-- | Get the attack model for a creature, based on whatever tool the creature is holding. +-- This will fail if the creature is holding anything other than a weapon. +attackModel :: (DBReadable db) => CreatureRef -> db AttackModel +attackModel attacker_ref = + do m_tool_ref <- dbGetWielded attacker_ref + case m_tool_ref of + Nothing -> return $ UnarmedAttackModel attacker_ref + Just tool_ref -> + do tool <- dbGetTool tool_ref + case tool of + DeviceTool Gun device -> return $ RangedAttackModel attacker_ref tool_ref device + DeviceTool Sword device -> return $ MeleeAttackModel attacker_ref tool_ref device + _ -> throwError $ DBErrorFlag ToolIs_Innapropriate -dbRollRangedDamage :: (DBReadable db) => CreatureRef -> ToolRef -> db Integer -dbRollRangedDamage _ weapon_ref = - do tool <- dbGetTool weapon_ref - case tool of - GunTool g -> - do energy_released <- roll [0..gunEnergyOutput g] - energy_throughput <- roll [0..gunThroughput g] -- todo: overheats if energy_released > energy_throughput - return $ min energy_released energy_throughput +-- | Get an appropriate melee attack model for a creature, based on whatever tool the creature is holding. +-- This will fail if the creature is holding anything other than a suitable melee weapon (allows unarmed strike). +meleeAttackModel :: (DBReadable db) => CreatureRef -> db AttackModel +meleeAttackModel attacker_ref = + do attack_model <- attackModel attacker_ref + case interactionMode attack_model `elem` [Melee,Unarmed] of + True -> return attack_model + _ -> throwError $ DBErrorFlag ToolIs_Innapropriate -dbRollMeleeDamage :: (DBReadable db) => CreatureRef -> db Integer -dbRollMeleeDamage attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeDamage 0 attacker_ref +-- | Get an appropriate ranged attack model for a creature, based on whatever tool the creature is holding. +-- This will fail if the creature is holding anything other than a suitable ranged or splash weapon. +rangedAttackModel :: (DBReadable db) => CreatureRef -> db AttackModel +rangedAttackModel attacker_ref = + do attack_model <- attackModel attacker_ref + case interactionMode attack_model `elem` [Ranged,Splash] of + True -> return attack_model + _ -> throwError $ DBErrorFlag ToolIs_Innapropriate -dbRollRangedAttack :: (DBReadable db) => CreatureRef -> db Integer -dbRollRangedAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore RangedAttack 0 attacker_ref +data AttackOutcome = + AttackMiss CreatureRef (Maybe ToolRef) + | AttackMalfunction CreatureRef ToolRef Integer + | AttackExplodes CreatureRef ToolRef Integer + | AttackHit CreatureRef (Maybe ToolRef) CreatureRef Integer + | AttackDisarm CreatureRef CreatureRef ToolRef + | AttackSunder CreatureRef ToolRef CreatureRef ToolRef -dbRollMeleeAttack :: (DBReadable db) => CreatureRef -> db Integer -dbRollMeleeAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeAttack 0 attacker_ref +resolveAttack :: (DBReadable db) => AttackModel -> Facing -> db AttackOutcome +resolveAttack attack_model face = + do device_activation <- resolveDeviceActivation (AttackSkill $ interactionMode attack_model) + (DamageSkill $ interactionMode attack_model) + (ReloadSkill $ interactionMode attack_model) + (toPseudoDevice attack_model) + (attacker attack_model) + m_defender_ref <- liftM listToMaybe $ findContacts (contactMode $ interactionMode attack_model) (attacker attack_model) face + case (dao_outcome_type device_activation,m_defender_ref) of + (DeviceFailed, _) | Just tool_ref <- weapon attack_model -> + return $ AttackMalfunction (attacker attack_model) tool_ref (dao_energy device_activation) + (DeviceCriticalFailed, _) | Just tool_ref <- weapon attack_model -> + return $ AttackExplodes (attacker attack_model) tool_ref (dao_energy device_activation) + (DeviceActivated, Just defender_ref) -> + do defense_outcome <- resolveDefense (interactionMode attack_model) defender_ref + distance_squared <- liftM (fromMaybe 0) $ dbDistanceBetweenSquared (attacker attack_model) defender_ref + let isDisarmingBlow = dao_skill_roll device_activation > do_skill_roll defense_outcome + distance_squared && + dao_energy device_activation > do_damage_reduction defense_outcome + do_disarm_bonus defense_outcome + case () of + () | dao_skill_roll device_activation <= do_skill_roll defense_outcome + distance_squared -> + return $ AttackMiss (attacker attack_model) (weapon attack_model) + () | isDisarmingBlow && interactionMode attack_model == Unarmed, + Just defender_wield_ref <- do_defender_wield defense_outcome -> + return $ AttackDisarm (attacker attack_model) defender_ref defender_wield_ref + () | isDisarmingBlow && interactionMode attack_model == Melee, + Just weapon_ref <- weapon attack_model, + Just defender_wield_ref <- do_defender_wield defense_outcome -> + return $ AttackSunder (attacker attack_model) weapon_ref defender_ref defender_wield_ref + () -> return $ AttackHit (attacker attack_model) (weapon attack_model) defender_ref (max 0 $ dao_energy device_activation - do_damage_reduction defense_outcome) + _ -> return $ AttackMiss (attacker attack_model) (weapon attack_model) -dbRollRangedDefense :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Integer -dbRollRangedDefense attacker_ref x_defender_ref = - do distance <- liftM (fromMaybe (error "dbGetOpposedAttackRoll: defender and attacker are on different planes")) $ dbDistanceBetweenSquared attacker_ref x_defender_ref - case () of - () | Just defender_ref <- coerceReferenceTyped _creature x_defender_ref -> liftM actual_roll $ dbRollCreatureScore RangedDefense distance defender_ref - () | otherwise -> return distance - -dbRollMeleeDefense :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Integer -dbRollMeleeDefense _ x_defender_ref = - case () of - () | Just defender_ref <- coerceReferenceTyped _creature x_defender_ref -> liftM actual_roll $ dbRollCreatureScore MeleeDefense 0 defender_ref - () | otherwise -> return 1 +data DefenseOutcome = DefenseOutcome { + do_defender_wield :: Maybe ToolRef, + do_skill_roll :: Integer, + do_damage_reduction :: Integer, + do_disarm_bonus :: Integer } -dbFindRangedTargets :: (DBReadable db,ReferenceType x,GenericReference a S) => Reference x -> Facing -> db [a] -dbFindRangedTargets attacker_ref face = - do m_l <- liftM (fmap location) $ getPlanarLocation attacker_ref - flip (maybe $ return []) m_l $ \(plane_ref,pos) -> - liftM (mapMaybe fromLocation . - sortBy (comparing (distanceBetweenSquared pos . location)) . - filter ((/= generalizeReference attacker_ref) . entity) . - filter (isFacing (pos,face) . location)) $ - dbGetContents plane_ref +resolveDefense :: (DBReadable db) => CreatureInteractionMode -> CreatureRef -> db DefenseOutcome +resolveDefense interaction_mode defender_ref = + do m_tool_ref <- dbGetWielded defender_ref + m_tool <- maybe (return Nothing) (liftM Just . dbGetTool) m_tool_ref + disarm_bonus <- maybe (return 0) toolDurability m_tool_ref + let pdevice = case m_tool of + Just (DeviceTool Sword d) | interaction_mode `elem` [Melee,Unarmed] -> toPseudoDevice d + _ -> PseudoDevice 0 0 0 1 + device_activation <- resolveDeviceActivation (DefenseSkill interaction_mode) + (DamageReductionTrait interaction_mode) + InventorySkill + pdevice + defender_ref + return $ case dao_outcome_type device_activation of + DeviceActivated -> DefenseOutcome m_tool_ref (dao_skill_roll device_activation) (dao_energy device_activation) disarm_bonus + DeviceFailed -> DefenseOutcome m_tool_ref 0 0 disarm_bonus + DeviceCriticalFailed -> DefenseOutcome m_tool_ref 0 0 0 -dbFindMeleeTargets :: (DBReadable db,ReferenceType x,GenericReference a S) => Reference x -> Facing -> db [a] -dbFindMeleeTargets attacker_ref face = - do m_l <- liftM (fmap location) $ getPlanarLocation attacker_ref - flip (maybe $ return []) m_l $ \(plane_ref,pos) -> - liftM (mapMaybe fromLocation . - filter (\x -> (location x == (offsetPosition (facingToRelative face) pos) || location x == pos) && - generalizeReference attacker_ref /= entity x)) $ - dbGetContents plane_ref +executeAttack :: AttackOutcome -> DB () +executeAttack (AttackMiss attacker_ref m_tool_ref) = + do dbPushSnapshot $ MissEvent attacker_ref m_tool_ref +executeAttack (AttackHit attacker_ref m_tool_ref defender_ref damage) = + do injureCreature damage defender_ref + dbPushSnapshot $ AttackEvent attacker_ref m_tool_ref defender_ref +executeAttack (AttackMalfunction attacker_ref tool_ref damage) = + do injureCreature damage attacker_ref + _ <- dbMove dbDropTool tool_ref + dbPushSnapshot $ WeaponOverheatsEvent attacker_ref tool_ref + return () +executeAttack (AttackExplodes attacker_ref tool_ref damage) = + do injureCreature damage attacker_ref + dbPushSnapshot $ WeaponExplodesEvent attacker_ref tool_ref + deleteTool tool_ref +executeAttack (AttackDisarm attacker_ref defender_ref dropped_tool) = + do dbPushSnapshot $ DisarmEvent attacker_ref defender_ref dropped_tool + _ <- dbMove dbDropTool dropped_tool + return () +executeAttack (AttackSunder attacker_ref weapon_ref defender_ref sundered_tool) = + do dbPushSnapshot $ SunderEvent attacker_ref weapon_ref defender_ref sundered_tool + deleteTool sundered_tool + diff --git a/src/Creature.hs b/src/Creature.hs --- a/src/Creature.hs +++ b/src/Creature.hs @@ -1,86 +1,132 @@ {-# LANGUAGE PatternGuards #-} module Creature - (dbGenerateInitialPlayerCreature, - dbNewCreature, + (generateInitialPlayerCreature, + newCreature, Roll(..), - dbRollCreatureScore, + RollComponents(..), + rollCreatureAbilityScore, + getCurrentCreature, getCreatureFaction, - dbRollInjury, - dbInjureCreature, - dbGetDead, + injureCreature, + healCreature, + getCreatureHealth, + getCreatureMaxHealth, + getCreatureAbsoluteHealth, + getDead, deleteCreature, sweepDead) where -import Data.Maybe import CreatureData import DB import SpeciesData import Species -import DBData import FactionData import Control.Monad.Error -import Dice import Tool +import CreatureAttribute +import Data.Monoid +import Data.Ratio +import Facing +import Position +import Plane +import PlayerState -- | -- Generates a new Creature from the specified species. -- -dbGenerateCreature :: Faction -> Species -> DB Creature -dbGenerateCreature faction species = - do (stats,attribs,name) <- generateCreatureData species - random_id <- dbNextRandomInteger - return (Creature { creature_stats=stats, - creature_attribs=attribs, - creature_species_name=name, - creature_random_id=random_id, - creature_damage=0, - creature_faction=faction}) +generateCreature :: Faction -> Species -> DB Creature +generateCreature faction species = generateAttributes faction species $ mconcat $ species_starting_attributes $ speciesInfo species -- | -- During DBRaceSelectionState, generates a new Creature for the player character and sets it into the -- database's DBClassSelectionState. -- -dbGenerateInitialPlayerCreature :: Species -> DB () -dbGenerateInitialPlayerCreature species = - do newc <- dbGenerateCreature Player species +generateInitialPlayerCreature :: Species -> DB () +generateInitialPlayerCreature species = + do newc <- generateCreature Player species dbSetStartingRace species setPlayerState (ClassSelectionState newc) -- | -- Generates a new Creature from the specified Species and adds it to the database. -- -dbNewCreature :: (CreatureLocation l) => Faction -> Species -> l -> DB CreatureRef -dbNewCreature faction species loc = - do creature <- dbGenerateCreature faction species +newCreature :: (CreatureLocation l) => Faction -> Species -> l -> DB CreatureRef +newCreature faction species loc = + do creature <- generateCreature faction species dbAddCreature creature loc +data RollComponents = RollComponents { + component_base :: Integer, + component_other_situation_bonus :: Integer, + component_terrain_affinity_bonus :: Integer } + data Roll = Roll { - ideal_score :: Integer, - other_situation_bonus :: Integer, - actual_roll :: Integer } + roll_ideal :: Integer, + roll_actual :: Integer, + roll_ideal_components :: RollComponents, + roll_actual_components :: RollComponents, + roll_log :: Integer } -dbRollCreatureScore :: (DBReadable db) => Score -> Integer -> CreatureRef -> db Roll -dbRollCreatureScore score bonus creature_ref = - do ideal <- liftM ((+ bonus) . creatureScore score) $ dbGetCreature creature_ref - actual <- roll [0..ideal] - return $ Roll ideal bonus actual +rollCreatureAbilityScore :: (DBReadable db) => CreatureAbility -> Integer -> CreatureRef -> db Roll +rollCreatureAbilityScore score other_ideal creature_ref = + do raw_ideal <- liftM (creatureAbilityScore score) $ dbGetCreature creature_ref + terrain_ideal <- getTerrainAffinity creature_ref + let ideal = raw_ideal + other_ideal + terrain_ideal + actual <- linearRoll ideal + [raw_actual, other_actual, terrain_actual] <- fixedSumLinearRoll [raw_ideal, other_ideal, terrain_ideal] actual + logarithmic <- logRoll ideal + --trace (show $ (score,raw_ideal,other_ideal,terrain_ideal,raw_actual,other_actual,terrain_actual)) $ return () + return $ Roll ideal (if raw_actual == 0 then 0 else actual) + (RollComponents raw_ideal other_ideal terrain_ideal) + (RollComponents raw_actual other_actual terrain_actual) logarithmic +-- | Ability bonus based on being good at working on specific types of terrain. +getTerrainAffinity :: (DBReadable db) => CreatureRef -> db Integer +getTerrainAffinity creature_ref = + do l <- liftM (fmap location) $ getPlanarPosition creature_ref + terrain_affinity_points <- case l of + Nothing -> return 0 + Just (plane_ref,pos) -> liftM sum $ forM [minBound..maxBound] $ \face -> + do t <- terrainAt plane_ref $ offsetPosition (facingToRelative face) pos + liftM (creatureAbilityScore $ TerrainAffinity t) $ dbGetCreature creature_ref + return $ terrain_affinity_points `div` 4 + +-- | Get the current creature, if it belongs to the specified faction, based on the current playerState. +getCurrentCreature :: (DBReadable db) => Faction -> db (Maybe CreatureRef) +getCurrentCreature faction = + do m_who <- liftM creatureOf $ playerState + is_one_of_us <- maybe (return False) (liftM (== faction) . getCreatureFaction) m_who + return $ if is_one_of_us then m_who else Nothing + getCreatureFaction :: (DBReadable db) => CreatureRef -> db Faction getCreatureFaction = liftM creature_faction . dbGetCreature -dbRollInjury :: (DBReadable db) => CreatureRef -> Integer -> db Integer -dbRollInjury creature_ref damage_roll = - do damage_reduction <- liftM actual_roll $ dbRollCreatureScore DamageReduction 0 creature_ref - return $ max 0 $ damage_roll - damage_reduction - -dbInjureCreature :: Integer -> CreatureRef -> DB () -dbInjureCreature x = dbModCreature $ \c -> c { creature_damage = creature_damage c + x } +injureCreature :: Integer -> CreatureRef -> DB () +injureCreature x = dbModCreature $ \c -> c { creature_damage = max 0 $ creature_damage c + x } -dbGetDead :: (DBReadable db) => Reference a -> db [CreatureRef] -dbGetDead parent_ref = filterRO (liftM (\c -> creatureScore HitPoints c <= 0) . dbGetCreature) =<< dbGetContents parent_ref +healCreature :: Integer -> CreatureRef -> DB () +healCreature = injureCreature . negate +getCreatureMaxHealth :: (DBReadable db) => CreatureRef -> db Integer +getCreatureMaxHealth = liftM (creatureAbilityScore ToughnessTrait) . dbGetCreature + +-- | Injury difference from maximum health as an integer count of hit points. +getCreatureInjury :: (DBReadable db) => CreatureRef -> db Integer +getCreatureInjury = liftM creature_damage . dbGetCreature + +-- | Health as an integer count of hit points. +getCreatureAbsoluteHealth :: (DBReadable db) => CreatureRef -> db Integer +getCreatureAbsoluteHealth creature_ref = liftM (max 0) $ liftM2 (-) (getCreatureMaxHealth creature_ref) (getCreatureInjury creature_ref) + +-- | Health as a fraction of 1. +getCreatureHealth :: (DBReadable db) => CreatureRef -> db Rational +getCreatureHealth creature_ref = liftM2 (%) (getCreatureAbsoluteHealth creature_ref) (getCreatureMaxHealth creature_ref) + +getDead :: (DBReadable db) => Reference a -> db [CreatureRef] +getDead parent_ref = filterRO (liftM (<= 0) . getCreatureHealth) =<< dbGetContents parent_ref + deleteCreature :: CreatureRef -> DB () deleteCreature = dbUnsafeDeleteObject $ \l -> do m_dropped_loc <- maybe (return Nothing) (liftM Just . dbDropTool) $ coerceEntityTyped _tool l @@ -88,9 +134,10 @@ Just dropped_loc -> generalizeLocationRecord dropped_loc Nothing -> error "dbDeleteCreature: no case for this type of entity" +-- | Delete all dead creatures from the database. sweepDead :: Reference a -> DB () sweepDead ref = - do worst_to_best_critters <- sortByRO (liftM ideal_score . dbRollCreatureScore HitPoints 0) =<< dbGetDead ref + do worst_to_best_critters <- sortByRO getCreatureHealth =<< getDead ref flip mapM_ worst_to_best_critters $ \creature_ref -> do dbPushSnapshot (KilledEvent creature_ref) deleteCreature creature_ref diff --git a/src/CreatureAttribute.hs b/src/CreatureAttribute.hs new file mode 100644 --- /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 --- 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 +import Data.Monoid +import qualified Data.Map as Map +import qualified Data.Set as Set +import SpeciesData +import TerrainData -data Creature = Creature { creature_stats :: Stats, - creature_attribs :: [CreatureAttribute], - creature_species_name :: String, +data Creature = Creature { creature_aptitude :: Map.Map CreatureAptitude Integer, + creature_ability :: Map.Map CreatureAbility Integer, + creature_ethical :: Map.Map EthicalAlignment Integer, + creature_levels :: Map.Map CharacterClass Integer, + creature_favored_classes :: Set.Set CharacterClass, + creature_gender :: CreatureGender, + creature_species :: Species, creature_random_id :: Integer, -- random number attached to the creature, not unique creature_damage :: Integer, creature_faction :: Faction } deriving (Read,Show) -instance StatisticsBlock Creature where - str creature = strength $ creature_stats creature - dex creature = dexterity $ creature_stats creature - con creature = constitution $ creature_stats creature - int creature = intelligence $ creature_stats creature - per creature = perception $ creature_stats creature - cha creature = charisma $ creature_stats creature - mind creature = mindfulness $ creature_stats creature +-- | Creature having no attributes and undefined 'creature_species', 'creature_random_id', and 'creature_faction' +-- +empty_creature :: Creature +empty_creature = Creature { + creature_aptitude = Map.empty, + creature_ability = Map.empty, + creature_ethical = Map.empty, + creature_levels = Map.empty, + creature_favored_classes = Set.empty, + creature_gender = Neuter, + creature_species = error "empty_creature: undefined creature_species", + creature_random_id = error "empty_creature: undefined creature_random_id", + creature_damage = 0, + creature_faction = error "empty_creature: undefined creature_faction" } data CreatureGender = Male | Female | Neuter deriving (Eq,Read,Show) --- | --- A creature's attributes. --- -data CreatureAttribute = Gender CreatureGender - | ToughnessTrait -- extra hit points - | DamageReductionTrait -- subtracts from any damage inflicted - | MeleeAttackSkill -- increased melee accuracy - | MeleeDefenseSkill -- increase melee defense - | RangedAttackSkill -- increased ranged accuracy - | RangedDefenseSkill -- increase ranged defense - | SpeedTrait -- more turns per round - | HideSkill -- unit is harder to see - | SpotSkill -- unit can see farther away - | StatBonus Statistic -- +1 to any statistic - | AlignmentBonus EthicalAlignment -- represents the creature's tendency toward strategic, tactical, diplomatic, or indifferent thinking styles - | CharacterLevel CharacterClass -- record of a character class being applied to the creature, has no game effect - | FavoredClass CharacterClass -- creature is able to take the specified class without any prerequisites - deriving (Eq, Show, Read) +-- | Endomorphisms over a 'Creature'. These are types that contribute some feature to a 'Creature', so that 'Creature's can be defined concisely by those properties. +class CreatureEndo a where + applyToCreature :: a -> Creature -> Creature -data Score = MaxHitPoints - | HitPoints - | DamageReduction - | MeleeAttack - | MeleeDefense - | MeleeDamage - | RangedAttack - | RangedDefense - | Speed Statistic - | EffectiveLevel - | Spot - | Hide +-- | Primitive numeric properties of a Creature. +class CreatureScore s where + rawScore :: s -> Creature -> Integer --- | --- An example creature used for test cases. --- -exampleCreature1 :: Creature -exampleCreature1 = Creature - { creature_stats = Stats { strength=2, constitution=5, dexterity=1, intelligence=(-2), perception=4, charisma=(-1), mindfulness=(-1) }, - creature_attribs = [Gender Male, - ToughnessTrait, - ToughnessTrait, - ToughnessTrait, - MeleeAttackSkill, - MeleeDefenseSkill, - RangedDefenseSkill], - creature_species_name = "Example-Creature-1", - creature_random_id=0, - creature_damage = 0, - creature_faction = Monsters } +instance (CreatureEndo a,Integral i) => CreatureEndo (a,i) where + applyToCreature (_,i) | i <= 0 = id + applyToCreature (a,i) = applyToCreature (a,toInteger i - 1) . applyToCreature a -creatureScore :: Score -> Creature -> Integer -creatureScore MaxHitPoints = \c -> max 6 (str c + con c + dex c + mind c) + 2 * attributeCount ToughnessTrait c -creatureScore HitPoints = \c -> creatureScore MaxHitPoints c - creature_damage c -creatureScore DamageReduction = statPlusDouble Constitution DamageReductionTrait -creatureScore MeleeAttack = statPlusDouble Dexterity MeleeAttackSkill -creatureScore MeleeDefense = statPlusDouble Dexterity MeleeDefenseSkill -creatureScore MeleeDamage = getStatistic Strength -creatureScore RangedAttack = statPlusDouble Dexterity RangedAttackSkill -creatureScore RangedDefense = statPlusDouble Perception RangedDefenseSkill -creatureScore (Speed by_statistic) = \c -> max 1 $ getStatistic by_statistic c + attributeCount SpeedTrait c -creatureScore Spot = statPlusDouble Perception SpotSkill -creatureScore Hide = \c -> max 0 $ per c + attributeCount HideSkill c +instance (CreatureEndo a) => CreatureEndo [a] where + applyToCreature = appEndo . mconcat . map (Endo . applyToCreature) --- | --- The creature's effective level. --- --- This sums all of the ability scores and attributes that a creature has and determines --- -creatureScore EffectiveLevel = \c -> sum (map ($ c) [str,dex,con,int,per,cha,mind] ++ - map levelAdjustment (creature_attribs c)) +instance CreatureEndo CreatureGender where + applyToCreature g c = c { creature_gender = g } -attributeCount :: CreatureAttribute -> Creature -> Integer -attributeCount attrib creature = count attrib $ creature_attribs creature +-- | The seven aptitudes. +data CreatureAptitude = + Strength + | Speed + | Constitution + | Intellect + | Perception + | Charisma + | Mindfulness + deriving (Eq,Read,Show,Ord,Enum,Bounded) --- | --- The standard way to calculate any score is to add the relevant Statistic to twice the number of --- ranks in the relevant skill. --- -statPlusDouble :: Statistic -> CreatureAttribute -> Creature -> Integer -statPlusDouble statistic attrib creature = max 0 $ getStatistic statistic creature + 2 * attributeCount attrib creature +instance CreatureEndo CreatureAptitude where + applyToCreature aptitude c = c { creature_aptitude = Map.insertWith (+) aptitude 1 $ creature_aptitude c } --- | --- Answers the number of levels a Creature has taken in a particular CharacterClass. --- These might not be proportional to the value of creatureEffectiveLevel, taking a level --- in a CharacterClass sometimes increases it's effective level by more than one. --- -characterClassLevels :: CharacterClass -> Creature -> Integer -characterClassLevels character_class creature = count (CharacterLevel character_class) (creature_attribs creature) +instance CreatureScore CreatureAptitude where + rawScore aptitude c = fromMaybe 0 $ Map.lookup aptitude (creature_aptitude c) --- | --- The amount by which a creature's effective level should be adjusted --- based on a single occurance of the given CreatureAttribute. --- -levelAdjustment :: CreatureAttribute -> Integer -levelAdjustment ToughnessTrait = 1 -levelAdjustment MeleeAttackSkill = 1 -levelAdjustment MeleeDefenseSkill = 1 -levelAdjustment RangedAttackSkill = 1 -levelAdjustment RangedDefenseSkill = 1 -levelAdjustment SpeedTrait = 2 -levelAdjustment (StatBonus _) = 1 -levelAdjustment (Gender {}) = 0 -levelAdjustment DamageReductionTrait = 1 -levelAdjustment AlignmentBonus {} = 0 -levelAdjustment HideSkill = 1 -levelAdjustment SpotSkill = 1 -levelAdjustment FavoredClass {} = 0 -levelAdjustment CharacterLevel {} = 0 +-- | Combat modes: +-- Melee is armed close-quarters combat with bladed or blunt weapons +-- Ranged is combat with projectile weapons +-- Unarmed is close-quarters hand-to-hand +-- Splash represts diffuse damage caused by things like explosions or falling into lava. +data CreatureInteractionMode = Melee | Ranged | Unarmed | Splash + deriving (Eq,Read,Show,Ord) --- | --- Adds a CreatureAttribute to a Creature. The CreatureAttribute stacks with or replaces any other --- related attributes already applied to the creature, depending on the type of attribute. --- Includes some special handling for some CreatureAttributes. --- -applyCreatureAttribute :: CreatureAttribute -> Creature -> Creature -applyCreatureAttribute (StatBonus statistic) = incCreatureStat statistic -applyCreatureAttribute attrib = putCreatureAttribute attrib +data CreatureAbility = + ToughnessTrait + | AttackSkill CreatureInteractionMode + | DefenseSkill CreatureInteractionMode + | DamageSkill CreatureInteractionMode + | DamageReductionTrait CreatureInteractionMode + | ReloadSkill CreatureInteractionMode + | TerrainAffinity TerrainPatch + | HideSkill + | SpotSkill + | JumpSkill + | InventorySkill + deriving (Eq,Read,Show,Ord) --- | --- applyCreatureAttribute with no special handling. --- -putCreatureAttribute :: CreatureAttribute -> Creature -> Creature -putCreatureAttribute attrib creature = creature { creature_attribs = (attrib : (creature_attribs creature))} +instance CreatureEndo CreatureAbility where + applyToCreature ability c = c { creature_ability = Map.insertWith (+) ability 1 $ creature_ability c } -incCreatureStat :: Statistic -> Creature -> Creature -incCreatureStat statistic creature = - let sts = creature_stats creature - in creature { creature_stats = setStatistic statistic (succ $ getStatistic statistic sts) sts } +instance CreatureScore CreatureAbility where + rawScore ability c = fromMaybe 0 $ Map.lookup ability $ creature_ability c -genderOf :: CreatureAttribute -> Maybe CreatureGender -genderOf attrib = case attrib of - Gender gender -> Just gender - _ -> Nothing +instance CreatureEndo EthicalAlignment where + applyToCreature ethical c = c { creature_ethical = Map.insertWith (+) ethical 1 $ creature_ethical c } +instance CreatureScore EthicalAlignment where + rawScore ethical c = fromMaybe 0 $ Map.lookup ethical $ creature_ethical c + +instance CreatureEndo CharacterClass where + applyToCreature character_class c = c { creature_levels = Map.insertWith (+) character_class 1 $ creature_levels c } + +instance CreatureScore CharacterClass where + rawScore character_class c = fromMaybe 0 $ Map.lookup character_class $ creature_levels c + +newtype FavoredClass = FavoredClass CharacterClass + +instance CreatureEndo FavoredClass where + applyToCreature (FavoredClass favored_class) c = c { creature_favored_classes = Set.insert favored_class $ creature_favored_classes c } + +-- | Calculator to determine how many ranks a creature has in an ability. +-- Number of aptitude points plus n times number of ability points +figureAbility :: [CreatureAptitude] -> (CreatureAbility,Integer) -> Creature -> Integer +figureAbility aptitude (ability,n) c = sum (map (flip rawScore c) aptitude) + rawScore ability c * n + +creatureAbilityScore :: CreatureAbility -> Creature -> Integer +creatureAbilityScore ToughnessTrait = figureAbility [Strength,Speed,Constitution,Mindfulness] (ToughnessTrait,3) +creatureAbilityScore (AttackSkill Melee) = figureAbility [Strength] (AttackSkill Melee,2) +creatureAbilityScore (DefenseSkill Melee) = figureAbility [Strength] (DefenseSkill Melee,2) +creatureAbilityScore (DamageSkill Melee) = figureAbility [Strength] (DamageSkill Melee,2) +creatureAbilityScore (DamageReductionTrait Melee) = figureAbility [Constitution] (DamageReductionTrait Melee,1) +creatureAbilityScore (ReloadSkill Melee) = figureAbility [Speed] (ReloadSkill Melee,1) +creatureAbilityScore (AttackSkill Ranged) = figureAbility [Perception] (AttackSkill Ranged,2) +creatureAbilityScore (DefenseSkill Ranged) = figureAbility [Perception] (DefenseSkill Ranged,2) +creatureAbilityScore (DamageSkill Ranged) = figureAbility [Perception] (DamageSkill Ranged,2) +creatureAbilityScore (DamageReductionTrait Ranged) = figureAbility [Constitution] (DamageReductionTrait Ranged,1) +creatureAbilityScore (ReloadSkill Ranged) = figureAbility [Speed] (ReloadSkill Ranged,1) +creatureAbilityScore (AttackSkill Unarmed) = figureAbility [Speed] (AttackSkill Unarmed,2) +creatureAbilityScore (DefenseSkill Unarmed) = figureAbility [Speed] (DefenseSkill Unarmed,2) +creatureAbilityScore (DamageSkill Unarmed) = figureAbility [Speed] (DamageSkill Unarmed,2) +creatureAbilityScore (DamageReductionTrait Unarmed) = figureAbility [Constitution] (DamageReductionTrait Unarmed,1) +creatureAbilityScore (ReloadSkill Unarmed) = figureAbility [Speed] (ReloadSkill Unarmed,1) +creatureAbilityScore (AttackSkill Splash) = figureAbility [Intellect] (AttackSkill Splash,2) +creatureAbilityScore (DefenseSkill Splash) = figureAbility [Intellect] (DefenseSkill Splash,2) +creatureAbilityScore (DamageSkill Splash) = figureAbility [Intellect] (DamageSkill Splash,2) +creatureAbilityScore (DamageReductionTrait Splash) = figureAbility [Constitution] (DamageReductionTrait Splash,1) +creatureAbilityScore (ReloadSkill Splash) = figureAbility [Speed] (ReloadSkill Splash,1) +creatureAbilityScore (TerrainAffinity terrain_type) = figureAbility [] (TerrainAffinity terrain_type,1) +creatureAbilityScore HideSkill = figureAbility [Perception] (HideSkill,2) +creatureAbilityScore SpotSkill = figureAbility [Perception] (SpotSkill,2) +creatureAbilityScore JumpSkill = figureAbility [Strength] (JumpSkill,2) +creatureAbilityScore InventorySkill = figureAbility [Strength,Speed,Constitution] (InventorySkill,2) + -- | -- Answers the gender of this creature. -- creatureGender :: Creature -> CreatureGender -creatureGender creature = fromMaybe Neuter $ listToMaybe $ mapMaybe genderOf $ creature_attribs creature +creatureGender = creature_gender -- | -- Answers true if the specified class is a favored class for this creature. -- isFavoredClass :: CharacterClass -> Creature -> Bool -isFavoredClass character_class creature = (FavoredClass character_class) `elem` (creature_attribs creature) +isFavoredClass character_class creature = character_class `Set.member` (creature_favored_classes creature) + diff --git a/src/DB.hs b/src/DB.hs --- 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 @@ dbPeepOldestSnapshot, dbPopOldestSnapshot, dbHasSnapshot, - module DBData) + module DBData, + module DBErrorFlag, + module Random, + dbTrace) where import DBPrivate import DBData import CreatureData import PlaneData -import System.Time +import BuildingData import RNG import Data.Map as Map import Data.List as List @@ -59,40 +66,20 @@ import Control.Monad.State import Control.Monad.Error import Control.Monad.Reader +import Control.Applicative import TimeCoordinate import Data.Ord -import Control.Arrow (first) - -data PlayerState = - RaceSelectionState - | ClassSelectionState Creature - | PlayerCreatureTurn CreatureRef CreatureTurnMode - | SnapshotEvent SnapshotEvent - | GameOver - deriving (Read,Show) - -data CreatureTurnMode = - NormalMode - | PickupMode - | DropMode - | WieldMode - deriving (Read,Show) - -data SnapshotEvent = - AttackEvent { - attack_event_source_creature :: CreatureRef, - attack_event_source_weapon :: Maybe ToolRef, - attack_event_target_creature :: CreatureRef } - | MissEvent { - miss_event_creature :: CreatureRef, - miss_event_weapon :: Maybe ToolRef } - | KilledEvent { - killed_event_creature :: CreatureRef } - deriving (Read,Show) +import Control.Arrow (first,second) +import Control.Monad.Random as Random +import Random +import Debug.Trace +import PlayerState +import DBErrorFlag +import Control.Parallel.Strategies data DB_History = DB_History { db_here :: DB_BaseType, - db_random :: [[Integer]] } + db_random :: RNG } data DB_BaseType = DB_BaseType { db_player_state :: PlayerState, db_next_object_ref :: Integer, @@ -100,79 +87,88 @@ db_creatures :: Map CreatureRef Creature, db_planes :: Map PlaneRef Plane, db_tools :: Map ToolRef Tool, + db_buildings :: Map BuildingRef Building, db_hierarchy :: HierarchicalDatabase (Location S (Reference ()) ()), db_time_coordinates :: Map (Reference ()) TimeCoordinate, db_error_flag :: String, - db_prior_snapshot :: Maybe DB_BaseType} + db_prior_snapshot :: Maybe DB_BaseType, + db_action_count :: Integer } deriving (Read,Show) data DBError = DBError String - | DBErrorFlag String + | DBErrorFlag ErrorFlag deriving (Read,Show) instance Error DBError where strMsg = DBError -newtype DB a = DB (ErrorT DBError (State DB_History) a) +type DBResult r = Either DBError (r,DB_History) +data DB a = DB { cycleDB :: forall r. DB_History -> (a -> DB_History -> DBResult r) -> DBResult r } runDB :: DB a -> DB_BaseType -> IO (Either DBError (a,DB_BaseType)) -runDB (DB actionM) db = - do hist <- setupDBHistory db - return $ case runState (runErrorT actionM) hist of - (Right a,DB_History { db_here = db' }) -> Right (a,db') - (Left e,_) -> Left e +runDB dbAction database = + do hist <- setupDBHistory database + return $ (either Left (Right . second db_here)) $ cycleDB dbAction hist $ \a h -> Right (a,h) instance Monad DB where - (DB k) >>= m = DB $ k >>= (\x -> let DB n = m x in n) - return = DB . return - fail s = DB $ throwError $ DBError $ "engine-error: " ++ s + return a = DB $ \h f -> f a h + k >>= m = DB $ \h f -> cycleDB k h $ \a h' -> cycleDB (m a) h' f + fail = error +instance Functor DB where + fmap = liftM + +instance Applicative DB where + pure = return + (<*>) = ap + instance MonadState DB_BaseType DB where - get = liftM db_here $ DB get - put s = DB $ modify (\x -> x { db_here = s }) + get = DB $ \h f -> f (db_here h) h + put s = DB $ \h f -> f () $ modification h + where modification = \db -> db { db_here = s { db_action_count = succ $ db_action_count $ db_here db } } instance MonadReader DB_BaseType DB where - ask = liftM db_here $ DB get - local f actionM = - do s <- get - modify f + ask = get + local modification actionM = + do split_rng <- dbRandomSplit + s <- get + modify modification a <- catchError (liftM Right actionM) (return . Left) - put s + DB $ \h f -> f () $ h { db_here = s, db_random = split_rng } either throwError return a instance MonadError DBError DB where - throwError = DB . throwError - catchError (DB actionM) handlerM = DB $ catchError actionM (\e -> let DB n = handlerM e in n) + throwError e = DB $ \_ _ -> Left e + catchError actionM handlerM = DB $ \h f -> either (\err -> cycleDB (handlerM err) h f) Right $ cycleDB actionM h f -class (Monad db,MonadError DBError db,MonadReader DB_BaseType db) => DBReadable db where - dbNextRandomInteger :: db Integer - dbNextRandomIntegerStream :: db [Integer] +instance MonadRandom DB where + getRandom = dbRandom random + getRandoms = liftM randoms $ dbRandom Random.split + getRandomR min_max = dbRandom $ randomR min_max + getRandomRs min_max = liftM (randomRs min_max) $ dbRandom Random.split + +dbRandom :: (RNG -> (a,RNG)) -> DB a +dbRandom rgen = DB $ \h f -> let (x,g) = rgen (db_random h) in f x (h { db_random = g }) + +dbRandomSplit :: DB RNG +dbRandomSplit = DB $ \h f -> let (a,b) = Random.split (db_random h) in f a (h { db_random = b }) + +class (Monad db,MonadError DBError db,MonadReader DB_BaseType db,MonadRandom db,Applicative db) => DBReadable db where dbSimulate :: DB a -> db a dbPeepSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db (Maybe a) instance DBReadable DB where - dbNextRandomInteger = - do db <- DB get - let rngss0 = db_random db - (rngs0,rngss1) = (head rngss0, tail rngss0) - (result,rngs1) = (head rngs0, tail rngs0) - DB $ put db { db_random=(rngs1:rngss1) } - return (result) - dbNextRandomIntegerStream = - do db <- DB get - let rngss = db_random db - DB $ put db { db_random=(tail rngss) } - return (head rngss) dbSimulate = local id dbPeepSnapshot actionM = - do s <- DB $ gets db_here + do s <- DB $ \h f -> f (db_here h) h m_snapshot <- gets db_prior_snapshot case m_snapshot of Just snapshot -> - do DB $ modify $ \hist -> hist { db_here = snapshot } + do split_rng <- dbRandomSplit + DB $ \h f -> f () $ h { db_here = snapshot } a <- dbSimulate actionM - DB $ modify $ \hist -> hist { db_here = s } + DB $ \h f -> f () $ h { db_here = s, db_random = split_rng } return $ Just a Nothing -> return Nothing @@ -181,10 +177,10 @@ ro db = dbSimulate db filterRO :: (DBReadable db) => (forall m. DBReadable m => a -> m Bool) -> [a] -> db [a] -filterRO f xs = ro $ filterM f xs +filterRO f xs = liftM (`using` parList rwhnf) $ filterM (dbSimulate . f) xs mapRO :: (DBReadable db) => (forall m. DBReadable m => a -> m b) -> [a] -> db [b] -mapRO f xs = ro $ mapM f xs +mapRO f xs = liftM (`using` parList rwhnf) $ mapM (dbSimulate . f) xs sortByRO :: (DBReadable db,Ord b) => (forall m. DBReadable m => a -> m b) -> [a] -> db [a] sortByRO f xs = @@ -213,17 +209,19 @@ db_creatures = Map.fromList [], db_planes = Map.fromList [], db_tools = Map.fromList [], + db_buildings = Map.fromList [], db_hierarchy = HierarchicalDatabase.fromList [], db_error_flag = [], db_time_coordinates = Map.fromList [(generalizeReference the_universe, zero_time)], - db_prior_snapshot = Nothing } + db_prior_snapshot = Nothing, + db_action_count = 0 } setupDBHistory :: DB_BaseType -> IO DB_History setupDBHistory db = - do (TOD seconds picos) <- getClockTime + do rng <- randomIO return $ DB_History { db_here = db, - db_random = randomIntegerStreamStream (seconds + picos) } + db_random = rng } -- | -- Returns the DBState of the database. @@ -237,11 +235,14 @@ setPlayerState :: PlayerState -> DB () setPlayerState state = modify (\db -> db { db_player_state = state }) +dbActionCount :: (DBReadable db) => db Integer +dbActionCount = asks db_action_count + -- | -- Gets the next ObjectRef integer, after incrementing it. -- dbNextObjectRef :: DB Integer -dbNextObjectRef = do modify (\db -> db { db_next_object_ref = succ $ db_next_object_ref db }) +dbNextObjectRef = do modify $ \db -> db { db_next_object_ref = succ $ db_next_object_ref db } gets db_next_object_ref class (LocationType l) => CreatureLocation l where @@ -250,6 +251,12 @@ class (LocationType l) => ToolLocation l where toolLocation :: ToolRef -> l -> Location m ToolRef l +class (LocationType l) => BuildingLocation l where + buildingLocation :: BuildingRef -> l -> Location m BuildingRef l + +class (LocationType l) => PlaneLocation l where + planeLocation :: PlaneRef -> l -> Location m PlaneRef l + instance CreatureLocation Standing where creatureLocation a l = IsStanding (unsafeReference a) l @@ -262,6 +269,15 @@ instance ToolLocation Wielded where toolLocation a l = IsWielded (unsafeReference a) l +instance BuildingLocation Constructed where + buildingLocation a l = IsConstructed (unsafeReference a) l + +instance PlaneLocation TheUniverse where + planeLocation a _ = InTheUniverse a + +instance PlaneLocation Subsequent where + planeLocation a l = IsSubsequent a l + -- | -- Adds something to a map in the database using a new object reference. -- @@ -287,8 +303,8 @@ -- | -- Adds a new Plane to the database. -- -dbAddPlane :: Plane -> () -> DB PlaneRef -dbAddPlane = dbAddObjectComposable PlaneRef dbPutPlane (\a () -> InTheUniverse a) +dbAddPlane :: (PlaneLocation l) => Plane -> l -> DB PlaneRef +dbAddPlane = dbAddObjectComposable PlaneRef dbPutPlane planeLocation -- | -- Adds a new Tool to the database. @@ -297,6 +313,12 @@ dbAddTool = dbAddObjectComposable ToolRef dbPutTool toolLocation -- | +-- Adds a new Tool to the database. +-- +dbAddBuilding :: (BuildingLocation l) => Building -> l -> DB BuildingRef +dbAddBuilding = dbAddObjectComposable BuildingRef dbPutBuilding buildingLocation + +-- | -- This deletes an object, but leaves any of it's contents dangling. -- dbUnsafeDeleteObject :: (ReferenceType e) => @@ -306,7 +328,7 @@ Reference e -> DB () dbUnsafeDeleteObject f ref = - do dbMoveAllWithin f ref + do _ <- dbMoveAllWithin f ref modify $ \db -> db { db_creatures = Map.delete (unsafeReference ref) $ db_creatures db, db_planes = Map.delete (unsafeReference ref) $ db_planes db, @@ -343,31 +365,43 @@ dbPutTool = dbPutObjectComposable db_tools (\x db_base_type -> db_base_type { db_tools = x }) -- | +-- Puts a Building under an arbitrary BuildingRef +-- +dbPutBuilding :: BuildingRef -> Building -> DB () +dbPutBuilding = dbPutObjectComposable db_buildings (\x db_base_type -> db_base_type { db_buildings = x }) + +-- | -- Gets an object from the database using getter functions. -- -dbGetObjectComposable :: (DBReadable db,Ord a) => (DB_BaseType -> Map a b) -> a -> db b -dbGetObjectComposable get_fn ref = - asks (fromMaybe (error "dbGetObjectComposable: Nothing") . Map.lookup ref . get_fn) +dbGetObjectComposable :: (DBReadable db,Ord a,GenericReference a x) => String -> (DB_BaseType -> Map a b) -> a -> db b +dbGetObjectComposable type_info get_fn ref = + asks (fromMaybe (error $ "dbGetObjectComposable: Nothing. UID was " ++ show (toUID $ generalizeReference ref) ++ ", type info was " ++ type_info) . Map.lookup ref . get_fn) -- | -- Gets a Creature from a CreatureRef -- dbGetCreature :: (DBReadable m) => CreatureRef -> m Creature -dbGetCreature = dbGetObjectComposable db_creatures +dbGetCreature = dbGetObjectComposable "CreatureRef" db_creatures -- | -- Gets a Plane from a PlaneRef -- dbGetPlane :: (DBReadable m) => PlaneRef -> m Plane -dbGetPlane = dbGetObjectComposable db_planes +dbGetPlane = dbGetObjectComposable "PlaneRef" db_planes -- | -- Gets a Plane from a PlaneRef -- dbGetTool :: (DBReadable m) => ToolRef -> m Tool -dbGetTool = dbGetObjectComposable db_tools +dbGetTool = dbGetObjectComposable "ToolRef" db_tools -- | +-- Gets a Plane from a PlaneRef +-- +dbGetBuilding :: (DBReadable m) => BuildingRef -> m Building +dbGetBuilding = dbGetObjectComposable "BuildingRef" db_buildings + +-- | -- Modifies an Object based on an ObjectRef. -- dbModObjectComposable :: (Reference e -> DB e) -> (Reference e -> e -> DB ()) -> @@ -393,13 +427,22 @@ dbModTool = dbModObjectComposable dbGetTool dbPutTool -- | +-- Modifies a Tool based on a PlaneRef. +-- +dbModBuilding :: (Building -> Building) -> BuildingRef -> DB () +dbModBuilding = dbModObjectComposable dbGetBuilding dbPutBuilding + +-- | -- Set the location of an object. +-- This is where we handle making sure that a creature can only wield one tool, and +-- a Plane can point to only one subsequent Plane. -- dbSetLocation :: (LocationType e,LocationType t) => Location S e t -> DB () dbSetLocation loc = - do case (fmap location $ coerceLocationTyped _wielded loc) of - Just (Wielded c) -> dbUnwieldCreature c - Nothing -> return () + do case (fmap location $ coerceLocationTyped _wielded loc,fmap location $ coerceLocationTyped _subsequent loc) of + (Just (Wielded c),_) -> dbUnwieldCreature c + (_,Just (Subsequent b)) -> mapM_ (dbSetLocation . (InTheUniverse :: PlaneRef -> Location S PlaneRef TheUniverse)) =<< dbGetContents b + (_,_) -> return () modify (\db -> db { db_hierarchy=HierarchicalDatabase.insert (unsafeLocation loc) $ db_hierarchy db }) -- | @@ -412,7 +455,7 @@ -- Moves an object, returning the location of the object before and after -- the move. -- -dbMove :: (LocationType (Reference e),LocationType b) => +dbMove :: (ReferenceType e, LocationType (Reference e),LocationType b) => (forall m. DBReadable m => Location M (Reference e) () -> m (Location M (Reference e) b)) -> (Reference e) -> DB (Location S (Reference e) (),Location S (Reference e) b) @@ -420,6 +463,8 @@ do old <- dbWhere ref new <- ro $ moveF (unsafeLocation old) dbSetLocation $ generalizeLocationRecord $ unsafeLocation new + when (getLocation old =/= getLocation new) $ -- an entity arriving in a new container shouldn't act before, nor be suspended beyond, the next action of the container + dbSetTimeCoordinate ref =<< dbGetTimeCoordinate (getLocation new) return (unsafeLocation old, unsafeLocation new) dbMoveAllWithin :: (forall m. DBReadable m => @@ -476,8 +521,8 @@ -- | -- Advances the time of an object. -- -dbAdvanceTime :: (ReferenceType a) => Rational -> Reference a -> DB () -dbAdvanceTime t ref = dbSetTimeCoordinate ref =<< (return . (advanceTime t)) =<< dbGetTimeCoordinate ref +dbAdvanceTime :: (ReferenceType a) => Reference a -> Rational -> DB () +dbAdvanceTime ref t = dbSetTimeCoordinate ref =<< (return . (advanceTime t)) =<< dbGetTimeCoordinate ref -- | -- Finds the object whose turn is next, among a restricted group of objects. @@ -499,10 +544,10 @@ -- Sets the starting race. -- dbSetStartingRace :: Species -> DB () -dbSetStartingRace species = modify (\db -> db { db_starting_race = Just species }) +dbSetStartingRace the_species = modify (\db -> db { db_starting_race = Just the_species }) -- | --- Takes a snapshot of a DBEvent in progress. +-- Takes a snapshot of a SnapshotEvent in progress. -- dbPushSnapshot :: SnapshotEvent -> DB () dbPushSnapshot e = modify $ \db -> db { @@ -524,3 +569,10 @@ case isJust $ db_prior_snapshot =<< db_prior_snapshot db of False -> db { db_prior_snapshot = Nothing } True -> db { db_prior_snapshot = fmap popOldestSnapshot $ db_prior_snapshot db } + +-- | Print a debug/trace message from DB. +{-# NOINLINE dbTrace #-} +dbTrace :: (DBReadable db) => String -> db () +dbTrace s = + do db <- ask + trace ("trace (object count " ++ show (db_next_object_ref db) ++ ") : " ++ s) $ return () diff --git a/src/DBData.hs b/src/DBData.hs --- a/src/DBData.hs +++ b/src/DBData.hs @@ -6,9 +6,10 @@ CreatureRef, PlaneRef, ToolRef, + BuildingRef, TheUniverse(..), the_universe, - (=:=), + (=:=), (=/=), GenericReference(..), locationsOf, ReferenceType(..), @@ -19,18 +20,25 @@ Dropped(..), Inventory(..), Wielded(..), + Constructed(..), + Subsequent(..), _nullary, _creature, _tool, _plane, + _building, _standing, _dropped, _inventory, _wielded, + _constructed, + _subsequent, _position, + _multiposition, _facing, _the_universe, asLocationTyped, + asReferenceTyped, DBPrivate.S, location, entity, @@ -60,6 +68,7 @@ import ToolData import CreatureData import PlaneData +import BuildingData import Data.Maybe import Control.Monad import Position @@ -81,6 +90,9 @@ _plane :: Type PlaneRef _plane = Type $ error "_plane: undefined" +_building :: Type BuildingRef +_building = Type $ error "_building: undefined" + _standing :: Type Standing _standing = Type $ error "_standing: undefined" @@ -93,9 +105,18 @@ _wielded :: Type Wielded _wielded = Type $ error "_wielded: undefined" +_constructed :: Type Constructed +_constructed = Type $ error "_constructed: undefined" + +_subsequent :: Type Subsequent +_subsequent = Type $ error "_subsequent: undefined" + _position :: Type Position _position = Type $ error "_position: undefined" +_multiposition :: Type MultiPosition +_multiposition = Type $ error "_multiposition: undefined" + _facing :: Type Facing _facing = Type $ error "_facing: undefined" @@ -109,6 +130,13 @@ fromLocation :: (ReferenceType x) => Location m (Reference x) b -> Maybe a generalizeReference :: a -> Reference () +instance (GenericReference a m,GenericReference b m) => GenericReference (Either a b) m where + fromLocation x = case (fromLocation x,fromLocation x) of + (Just a,_) -> Just $ Left a + (_,Just b) -> Just $ Right b + _ | otherwise -> Nothing + generalizeReference = either generalizeReference generalizeReference + instance (ReferenceType a) => GenericReference (Reference a) m where fromLocation = coerceReference . entity generalizeReference = unsafeReference @@ -126,6 +154,9 @@ (=:=) :: (GenericReference a m,GenericReference b n) => a -> b -> Bool a =:= b = generalizeReference a == generalizeReference b +(=/=) :: (GenericReference a m,GenericReference b n) => a -> b -> Bool +a =/= b = not $ a =:= b + -- -- References -- @@ -157,6 +188,10 @@ coerceReference (CreatureRef ref) = Just $ CreatureRef ref coerceReference _ = Nothing +instance ReferenceType Building where + coerceReference (BuildingRef ref) = Just $ BuildingRef ref + coerceReference _ = Nothing + instance ReferenceType TheUniverse where coerceReference UniverseRef = Just UniverseRef coerceReference _ = Nothing @@ -178,18 +213,25 @@ getLocation (IsDropped _ d) = unsafeReference $ dropped_plane d getLocation (InInventory _ c) = unsafeReference $ inventory_creature c getLocation (IsWielded _ c) = unsafeReference $ wielded_creature c +getLocation (IsConstructed _ c) = unsafeReference $ constructed_plane c getLocation (InTheUniverse _) = unsafeReference UniverseRef +getLocation (IsSubsequent _ b) = unsafeReference $ subsequent_to b getEntity :: Location m e t -> Reference () getEntity (IsStanding r _) = unsafeReference r getEntity (IsDropped r _) = unsafeReference r getEntity (InInventory r _) = unsafeReference r getEntity (IsWielded r _) = unsafeReference r +getEntity (IsConstructed r _) = unsafeReference r getEntity (InTheUniverse r) = unsafeReference r +getEntity (IsSubsequent r _) = unsafeReference r asLocationTyped :: (LocationType e,LocationType t) => Type e -> Type t -> Location m e t -> Location m e t asLocationTyped _ _ = id +asReferenceTyped :: (LocationType e) => Type e -> e -> e +asReferenceTyped _ = id + coerceLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Maybe (Location m e t) coerceLocationTyped = const coerceLocation @@ -246,6 +288,21 @@ extractLocation _ = Nothing extractEntity = const Nothing +instance LocationType Constructed where + extractLocation (IsConstructed _ i) = Just i + extractLocation _ = Nothing + extractEntity = const Nothing + +instance LocationType TheUniverse where + extractLocation (InTheUniverse {}) = Just TheUniverse + extractLocation _ = Nothing + extractEntity = const Nothing + +instance LocationType Subsequent where + extractLocation (IsSubsequent _ i) = Just i + extractLocation _ = Nothing + extractEntity = const Nothing + instance LocationType () where extractLocation = const $ Just () extractEntity = const Nothing @@ -255,15 +312,24 @@ extractLocation (IsDropped _ d) = Just $ dropped_position d extractLocation (InInventory {}) = Nothing extractLocation (IsWielded {}) = Nothing + extractLocation (IsConstructed _ c) = Just $ constructed_position c extractLocation (InTheUniverse {}) = Nothing + extractLocation (IsSubsequent {}) = Nothing extractEntity = const Nothing +instance LocationType MultiPosition where + extractLocation (IsConstructed _ c) = Just $ multiPosition (constructed_position c) (buildingOccupies $ constructed_type c) + extractLocation x = fmap (toMultiPosition :: Position -> MultiPosition) $ extractLocation x + extractEntity = const Nothing + instance LocationType Facing where extractLocation (IsStanding _ s) = Just $ standing_facing s extractLocation (IsDropped {}) = Nothing extractLocation (InInventory {}) = Nothing extractLocation (IsWielded {}) = Nothing + extractLocation (IsConstructed {}) = Nothing extractLocation (InTheUniverse {}) = Nothing + extractLocation (IsSubsequent {}) = Nothing extractEntity = const Nothing instance ReferenceType a => LocationType (Reference a) where diff --git a/src/DBPrivate.hs b/src/DBPrivate.hs --- a/src/DBPrivate.hs +++ b/src/DBPrivate.hs @@ -13,10 +13,13 @@ Dropped(..), Inventory(..), Wielded(..), + Constructed(..), TheUniverse(..), + Subsequent(..), CreatureRef, ToolRef, - PlaneRef) + PlaneRef, + BuildingRef) where import HierarchicalDatabase @@ -24,6 +27,7 @@ import CreatureData import ToolData import PlaneData +import BuildingData import Position -- @@ -39,11 +43,12 @@ -- | -- Type representing the entire universe. -- -data TheUniverse = TheUniverse deriving (Read,Show) +data TheUniverse = TheUniverse deriving (Read,Show,Eq,Ord) type CreatureRef = Reference Creature type ToolRef = Reference Tool type PlaneRef = Reference Plane +type BuildingRef = Reference Building -- | -- A typesafe reference to any entity. @@ -51,6 +56,7 @@ data Reference a = CreatureRef { uid:: Integer } | PlaneRef { uid :: Integer } | ToolRef { uid :: Integer } + | BuildingRef { uid :: Integer } | UniverseRef deriving (Eq,Ord,Read,Show) @@ -58,6 +64,7 @@ unsafeReference (CreatureRef x) = CreatureRef x unsafeReference (PlaneRef x) = PlaneRef x unsafeReference (ToolRef x) = ToolRef x +unsafeReference (BuildingRef x) = BuildingRef x unsafeReference UniverseRef = UniverseRef toUID :: Reference a -> Integer @@ -82,6 +89,15 @@ deriving (Read,Show,Eq,Ord) -- | +-- The location of a Building constructed on a Plane. +-- +data Constructed = + Constructed { constructed_plane :: PlaneRef, + constructed_position :: Position, + constructed_type :: BuildingType } + deriving (Read,Show,Eq,Ord) + +-- | -- The location of a tool carried by a creature. -- data Inventory = @@ -94,21 +110,27 @@ data Wielded = Wielded { wielded_creature :: CreatureRef } deriving (Read,Show,Eq,Ord) + -- | +-- The location of a Plane linked to from another Plane, such as with a Stargate. +-- +data Subsequent = + Subsequent { subsequent_to :: PlaneRef } + deriving (Read,Show,Eq,Ord) + +-- | -- A relational data structure defining the location of any entity. -- All of the type variables of Location are phantom types. -- --- m represents the modification domain of the Location. For example, --- a Location M is the location of a moving entity. The goal of m --- is to ensure that the entity can not be changed when moving an entity, --- e.g. Robert can not turn into Susan by walking across the street. +-- m represents the modification domain of the Location. Location M is +-- a location of an moving entity, while Location S is the location of +-- a static entity. +-- +-- The M parameter ensures that the entity's identity can not be changed +-- when moving an entity, e.g. Robert can not turn into Susan by walking across the street. -- No function Location M e t -> Location M e t can be written that -- changes the what entity the location references. -- --- A Location S is the location of an still (unmoving) entity and may be --- mutilated at will, but the type checker ensures that no such --- mutilated Location may be used to move an entity. --- -- Thus, we accept functions of the type -- (Location M e a -> Location M e b) -> DB (), -- to move an object, a functions of the type @@ -127,7 +149,9 @@ | IsDropped ToolRef Dropped | InInventory ToolRef Inventory | IsWielded ToolRef Wielded + | IsConstructed BuildingRef Constructed | InTheUniverse PlaneRef + | IsSubsequent PlaneRef Subsequent deriving (Read,Show,Eq,Ord) unsafeLocation :: Location a b c -> Location d e f @@ -135,16 +159,22 @@ unsafeLocation (IsDropped a b) = IsDropped a b unsafeLocation (InInventory a b) = InInventory a b unsafeLocation (IsWielded a b) = IsWielded a b +unsafeLocation (IsConstructed a b) = IsConstructed a b unsafeLocation (InTheUniverse a) = InTheUniverse a +unsafeLocation (IsSubsequent a b) = IsSubsequent a b instance HierarchicalRelation (Location m e t) where parent (IsStanding _ t) = toUID $ standing_plane t parent (IsDropped _ t) = toUID $ dropped_plane t parent (InInventory _ t) = toUID $ inventory_creature t parent (IsWielded _ t) = toUID $ wielded_creature t + parent (IsConstructed _ t) = toUID $ constructed_plane t parent (InTheUniverse _) = toUID UniverseRef + parent (IsSubsequent _ t) = toUID $ subsequent_to t child (IsStanding e _) = toUID e child (IsDropped e _) = toUID e child (InInventory e _) = toUID e child (IsWielded e _) = toUID e + child (IsConstructed e _) = toUID e child (InTheUniverse e) = toUID e + child (IsSubsequent e _) = toUID e diff --git a/src/Dice.hs b/src/Dice.hs deleted file mode 100644 --- 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 --- a/src/Facing.hs +++ b/src/Facing.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE OverloadedStrings #-} module Facing (Facing(..), facingToRelative, @@ -12,6 +12,7 @@ import Position import Data.Ord import Data.List +import qualified Data.ByteString.Char8 as B data Facing = North | NorthEast @@ -29,7 +30,7 @@ -- The input string must be lower case. -- No form of "Here" is an acceptable input to this function. -- -stringToFacing :: String -> Maybe Facing +stringToFacing :: B.ByteString -> Maybe Facing stringToFacing "n" = Just North stringToFacing "ne" = Just NorthEast stringToFacing "e" = Just East @@ -80,8 +81,8 @@ -- | -- A test function to detect when one Position + Facing points directly at another Position. -- -isFacing :: (Position, Facing) -> Position -> Bool -isFacing ((Position a),face) (Position b) = f face a b +isFacing :: (PositionType a,PositionType b) => (a, Facing) -> b -> Bool +isFacing (as,face) bs = or $ map (\(a,b) -> f face (fromPosition a) (fromPosition b)) $ positionPairs as bs where f :: Facing -> (Integer,Integer) -> (Integer,Integer) -> Bool f North (x,y) (u,v) = x == u && v >= y f NorthEast (x,y) (u,v) = x - u == y - v && u >= x diff --git a/src/FactionData.hs b/src/FactionData.hs --- 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 @@ | 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 --- a/src/GridRayCaster.hs +++ b/src/GridRayCaster.hs @@ -9,7 +9,6 @@ import Data.List as List import Data.Ratio import Tests -import Data.Maybe -- | -- When casting large numbers of rays from the same point, castRays will try to do this in diff --git a/src/Grids.hs b/src/Grids.hs --- 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 +import Data.List as List +import Random +import Data.MemoCombinators +import Control.Arrow -data Grid a = CompletelyRandomGrid Integer ((Integer,Integer) -> Integer) [(Integer,a)] - | InterpolatedGrid Integer ((Integer,Integer) -> Integer) (Map (a,a) [(Integer,a)]) (Grid a) - | ArbitraryReplacementGrid Integer ((Integer,Integer) -> Integer) [(Rational,a)] [(Integer,a)] (Grid a) - | SpecificPlacementGrid (Map (Integer,Integer) a) (Grid a) - | CachedGrid ((Integer,Integer) -> a) (Grid a) +newtype SeededGrid = SeededGrid Integer deriving (Read,Show) +data StorableCachedGrid a = StorableCachedGrid (Grid a) ((Integer,Integer) -> a) -data Grid_Persistant a = CompletelyRandomGrid_Persistant Integer [(Integer,a)] - | InterpolatedGrid_Persistant Integer [((a,a),[(Integer,a)])] (Grid_Persistant a) - | ArbitraryReplacementGrid_Persistant Integer [(Rational,a)] [(Integer,a)] (Grid_Persistant a) - | SpecificPlacementGrid_Persistant [((Integer,Integer),a)] (Grid_Persistant a) - deriving (Read,Show) +instance (Show a) => Show (StorableCachedGrid a) where + show (StorableCachedGrid g _) = show g -toPersistant :: (Grid a) -> (Grid_Persistant a) -toPersistant (CompletelyRandomGrid x _ prob_list) = - CompletelyRandomGrid_Persistant x prob_list -toPersistant (InterpolatedGrid x _ prob_map grid) = - InterpolatedGrid_Persistant x (toList prob_map) (toPersistant grid) -toPersistant (ArbitraryReplacementGrid x _ sources replacements grid) = - ArbitraryReplacementGrid_Persistant x sources replacements $ toPersistant grid -toPersistant (SpecificPlacementGrid placement_map grid) = - SpecificPlacementGrid_Persistant (toList placement_map) (toPersistant grid) -toPersistant (CachedGrid _ grid) = toPersistant grid +instance (Read a,Ord a) => Read (StorableCachedGrid a) where + readsPrec = (List.map (first storableCachedGrid) .) . readsPrec -fromPersistant :: (Ord a) => (Grid_Persistant a) -> (Grid a) -fromPersistant (CompletelyRandomGrid_Persistant x prob_list) = - cachedGridOf $ CompletelyRandomGrid x (randomIntegerGrid x) prob_list -fromPersistant (InterpolatedGrid_Persistant x prob_map grid) = - cachedGridOf $ InterpolatedGrid x (randomIntegerGrid x) (fromList prob_map) (fromPersistant grid) -fromPersistant (ArbitraryReplacementGrid_Persistant x sources replacements grid) = - cachedGridOf $ ArbitraryReplacementGrid x (randomIntegerGrid x) sources replacements (fromPersistant grid) -fromPersistant (SpecificPlacementGrid_Persistant placement_map grid) = - cachedGridOf $ SpecificPlacementGrid (fromList placement_map) (fromPersistant grid) +storableCachedGrid :: (Ord a) => Grid a -> StorableCachedGrid a +storableCachedGrid g = StorableCachedGrid g $ pair integral integral $ gridAt g -fromPersistant_tupled :: (Ord a) => (Grid_Persistant a,String) -> (Grid a,String) -fromPersistant_tupled (x,y) = (fromPersistant x,y) +seededGrid :: Integer -> SeededGrid +seededGrid n = SeededGrid n -instance (Show a) => Show (Grid a) where - show grid = show $ toPersistant grid +seededLookup :: SeededGrid -> (Integer,Integer) -> Integer +seededLookup (SeededGrid n) (x,y) = toInteger $ fst $ next $ mkRNG $ + (fst $ next $ mkRNG (fromInteger $ x `mod` max_int)) + + (fst $ next $ mkRNG (fromInteger $ y `mod` max_int)) + + (fromInteger $ n `mod` max_int) + where max_int = toInteger (maxBound :: Int) -instance (Ord a, Read a) => Read (Grid a) where - readsPrec n = \x -> Prelude.map fromPersistant_tupled (readsPrec n x) +data Grid a = CompletelyRandomGrid { + _grid_seed :: SeededGrid, + _grid_weights :: [(Integer,a)] } + | InterpolatedGrid { + _grid_seed :: SeededGrid, + _grid_interpolation_weights :: Map (a,a) [(Integer,a)], + grid_next :: Grid a } + | ArbitraryReplacementGrid { + _grid_seed :: SeededGrid, + _grid_sources :: [(Rational,a)], + _grid_replacement_weights :: [(Integer,a)], + grid_next :: Grid a } + | SpecificPlacementGrid { + _grid_replacements :: Map (Integer,Integer) a, + grid_next :: Grid a } + | CachedGrid (StorableCachedGrid a) + deriving (Read,Show) -gridAt :: Ord a => Grid a -> (Integer,Integer) -> a -gridAt (CompletelyRandomGrid _ seedfn weights) at = weightedPick (seedfn at) weights -gridAt (InterpolatedGrid _ seedfn interpolation_map grid) at@(x,y) = +gridAt :: (Ord a) => Grid a -> (Integer,Integer) -> a +gridAt (CompletelyRandomGrid seeded weights) at = fst $ weightedPick weights (mkRNG $ seededLookup seeded at) +gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) = let here = gridAt grid (x `div` 2,y `div` 2) there = gridAt grid (x `div` 2 + 1,y `div` 2 + 1) there_x = gridAt grid (x `div` 2 + 1,y `div` 2) there_y = gridAt grid (x `div` 2,y `div` 2 + 1) - interpolate a1 a2 = weightedPick (seedfn at) (interpolation_map ! (a1,a2)) + interpolate a1 a2 = fst $ weightedPick (interpolation_map ! (a1,a2)) (mkRNG $ seededLookup seeded at) in case (even x,even y) of (True,True) -> here (True,False) -> (interpolate here there_y) (False,True) -> (interpolate here there_x) (False,False) -> (interpolate here there) -gridAt (ArbitraryReplacementGrid _ seedfn sources replacements grid) at = +gridAt (ArbitraryReplacementGrid seeded sources replacements grid) at = case fmap fst $ find ((== here) . snd) sources of - Just frequency | ((seedfn at) `mod` (denominator frequency) < (numerator frequency)) -> - weightedPick (seedfn at) replacements + Just frequency | (seededLookup seeded at `mod` denominator frequency < numerator frequency) -> + fst $ weightedPick replacements (mkRNG $ seededLookup seeded at) _ -> here where here = gridAt grid at gridAt (SpecificPlacementGrid rep_map grid) at = findWithDefault (gridAt grid at) at rep_map -gridAt (CachedGrid map_fn _) at = map_fn at +gridAt (CachedGrid (StorableCachedGrid _ f)) at = f at -cachedGridOf :: Ord a => Grid a -> Grid a -cachedGridOf already_cached_grid@(CachedGrid _ _) = already_cached_grid -cachedGridOf any_other_grid = CachedGrid (cachedAccessor2D (gridAt any_other_grid)) any_other_grid +cachedGridOf :: (Ord a) => Grid a -> Grid a +cachedGridOf already_cached_grid@(CachedGrid {}) = already_cached_grid +cachedGridOf any_other_grid = CachedGrid $ storableCachedGrid any_other_grid -- | -- Generates a random grid. The first Integer, smoothness, @@ -92,14 +91,32 @@ -- the map. generateGrid :: (Ord a) => [(Integer,a)] -> Map (a,a) [(Integer,a)] -> Integer -> [Integer] -> Grid a generateGrid weights _ 0 seeds = let seed = head seeds - in CompletelyRandomGrid seed (randomIntegerGrid seed) weights + in CompletelyRandomGrid (seededGrid seed) weights generateGrid weights interps n seeds = let seed = head seeds - in cachedGridOf $ InterpolatedGrid seed (randomIntegerGrid seed) interps $ - generateGrid weights interps (n-1) (tail seeds) + in optimizeGrid $ InterpolatedGrid (seededGrid seed) interps $ + generateGrid weights interps (n-1) (tail seeds) -- | -- Arbitrarily (randomly) replaces some elements of a grid with another. -- arbitraryReplaceGrid :: (Ord a) => [(Rational,a)] -> [(Integer,a)] -> Integer -> Grid a -> Grid a -arbitraryReplaceGrid sources replacements seed grid = cachedGridOf $ - ArbitraryReplacementGrid seed (randomIntegerGrid seed) sources replacements grid +arbitraryReplaceGrid sources replacements seed grid = optimizeGrid $ + ArbitraryReplacementGrid (seededGrid seed) sources replacements grid + +-- | +-- Replace a specific element of a grid. +-- +specificReplaceGrid :: (Integer,Integer) -> a -> Grid a -> Grid a +specificReplaceGrid position x (SpecificPlacementGrid m grid) = + SpecificPlacementGrid (Map.insert position x m) grid +specificReplaceGrid position x grid = specificReplaceGrid position x $ SpecificPlacementGrid (Map.empty) grid + +-- | +-- Strip the cache out of lower layers of the grid, but apply a cache to the top layer. +-- +optimizeGrid :: (Ord a) => Grid a -> Grid a +optimizeGrid = cachedGridOf . stripCache + where stripCache (CachedGrid (StorableCachedGrid g _)) = g + stripCache g@(CompletelyRandomGrid {}) = g + stripCache grid = grid { grid_next = stripCache $ grid_next grid } + diff --git a/src/HierarchicalDatabase.hs b/src/HierarchicalDatabase.hs --- a/src/HierarchicalDatabase.hs +++ b/src/HierarchicalDatabase.hs @@ -20,6 +20,7 @@ import Tests import Data.Maybe as Maybe +-- | A record that can be a component of a 'HierarchicalDatabase'. class HierarchicalRelation a where parent :: a -> Integer child :: a -> Integer @@ -28,6 +29,7 @@ parent = toInteger . snd child = toInteger . fst +-- | A tree or hierarchy based on records that represent parent-child relations. data HierarchicalDatabase a = HierarchicalDatabase { hd_children :: (Map Integer [Integer]), @@ -68,28 +70,32 @@ xsParent = parentOf x the_map -- | --- Answers the parent of an element, or nothing if the element --- is not listed as a child in this HierarchicalDatabase. +-- Answers the key of the parent of the given key, if any. -- parentOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe Integer parentOf x the_map = fmap parent $ Map.lookup x $ hd_parent the_map -- | --- Answers the parent relation and all children relations for a given key. +-- Answers the parent relation and all children relations of a given key. -- lookup :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> (Maybe a,[a]) lookup x the_map = (Map.lookup x $ hd_parent the_map, maybe [] (Maybe.mapMaybe (flip Map.lookup (hd_parent the_map))) $ Map.lookup x $ hd_children the_map) +-- | +-- Answers the child relations of a given key. +-- lookupChildren :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [a] lookupChildren x the_map = snd $ HierarchicalDatabase.lookup x the_map +-- | +-- Answers the parent relation of a given key, if any. +-- lookupParent :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe a lookupParent x the_map = fst $ HierarchicalDatabase.lookup x the_map -- | --- Answers a list of the children of an element, or the null list if the element is --- not listed as a parent in this HierarchicalDatabase. +-- Answers the keys of the children for a given key. -- childrenOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [Integer] childrenOf x the_map = maybe [] id $ Map.lookup x (hd_children the_map) diff --git a/src/HopList.hs b/src/HopList.hs deleted file mode 100644 --- 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 --- 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 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,19 +4,14 @@ import DB import System.Environment -import System.Random -import System.IO -import Data.List import Tests import HierarchicalDatabase -import Control.Monad import TerrainData -import HopList import Protocol import GridRayCaster roguestar_version_number :: String -roguestar_version_number = "0.2.2" +roguestar_version_number = "0.3" roguestar_program_name :: String roguestar_program_name = "roguestar-engine" @@ -31,7 +26,6 @@ runByArgs "tests" = do testsPassed <- runAllTests ([sampleTestCase] ++ insidenessTests ++ - hopListTests ++ gridRayCasterTests) if testsPassed then putStrLn "All tests passed." diff --git a/src/Perception.hs b/src/Perception.hs --- 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 @@ myFaction, Perception.getCreatureFaction, whereAmI, - myPosition, - whereIs, - Perception.roll) + localBiome, + compass) where import Control.Monad.Reader -import Control.Monad +import Data.Ord import DB import FactionData import Creature import PlaneVisibility +import PlaneData import Data.Maybe +import Data.List import Facing -import Dice +import Position +import TerrainData +import BuildingData +import Building newtype (DBReadable db) => DBPerception db a = DBPerception { fromPerception :: (ReaderT CreatureRef db a) } @@ -35,20 +39,39 @@ (DBPerception a) >>= m = DBPerception $ a >>= (\x -> case m x of {(DBPerception b) -> b}) return = DBPerception . return +instance (DBReadable db,MonadRandom db) => MonadRandom (DBPerception db) where + getRandom = liftDB getRandom + getRandoms = liftDB getRandoms + getRandomR min_max = liftDB $ getRandomR min_max + getRandomRs min_max = liftDB $ getRandomRs min_max + +-- | +-- 'liftDB' takes an action in DBReadable and lifts it to DBPerception. Obviously not exported, +-- or DBPerception wouldn't be limited. +-- liftDB :: (DBReadable db) => (forall m. DBReadable m => m a) -> DBPerception db a liftDB actionM = DBPerception $ lift actionM +-- | +-- A run of DBPerception is tied to the creature doing the percieving. 'whoAmI' answers that creature. +-- We will call this creature "me" or "I". +-- whoAmI :: (DBReadable db) => DBPerception db CreatureRef whoAmI = DBPerception $ ask +-- | +-- Run a DBPerception from the point-of-view of the given creature. +-- Note that if you pass any 'Reference' or 'Location' into the perception monad, +-- it will be able to cheat. Therefore, don't. +-- runPerception :: (DBReadable db) => CreatureRef -> (forall m. DBReadable m => DBPerception m a) -> db a runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref -visibleObjects :: (DBReadable db,LocationType a,LocationType b) => DBPerception db [Location S a b] -visibleObjects = +visibleObjects :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> DBPerception m Bool) -> DBPerception db [a] +visibleObjects filterF = do me <- whoAmI faction <- myFaction - liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction faction) =<< liftM extractLocation (dbWhere me) + liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction (\a -> runPerception me $ filterF a) faction) =<< liftM extractLocation (dbWhere me) myFaction :: (DBReadable db) => DBPerception db Faction myFaction = Perception.getCreatureFaction =<< whoAmI @@ -59,11 +82,24 @@ whereAmI :: (DBReadable db) => DBPerception db (Facing,Position) whereAmI = liftM (fromMaybe (error "whereAmI: I'm not on a plane") . extractLocation) $ whereIs =<< whoAmI -myPosition :: (DBReadable db) => DBPerception db Position -myPosition = liftM snd whereAmI +whatPlaneAmIOn :: (DBReadable db) => DBPerception db PlaneRef +whatPlaneAmIOn = liftM (fromMaybe (error "whatPlaneAmIOn: I'm not on a plane") . extractLocation) $ whereIs =<< whoAmI whereIs :: (DBReadable db) => Reference a -> DBPerception db (Location S (Reference a) ()) whereIs ref = liftDB $ dbWhere ref -roll :: (DBReadable db) => [a] -> DBPerception db a -roll xs = liftDB $ Dice.roll xs +localBiome :: (DBReadable db) => DBPerception db Biome +localBiome = + do plane_ref <- whatPlaneAmIOn + liftDB $ liftM plane_biome $ dbGetPlane plane_ref + +compass :: (DBReadable db) => DBPerception db Facing +compass = + do let signalling_building_types = [Portal,Monolith] + (_,pos) <- whereAmI + plane <- whatPlaneAmIOn + liftDB $ + do buildings <- liftM (sortBy $ comparing $ distanceBetweenSquared pos . location) $ filterM (liftM (`elem` signalling_building_types) . buildingType . entity) =<< + dbGetContents plane + return $ maybe Here (faceAt pos . location) $ listToMaybe buildings + diff --git a/src/Plane.hs b/src/Plane.hs --- 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 :: TerrainGenerationData -> DB PlaneRef -dbNewPlane tg_data = - do rns <- dbNextRandomIntegerStream - dbAddPlane (Plane { plane_terrain = generateTerrain tg_data rns }) () +dbNewPlane :: (PlaneLocation l) => Maybe B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef +dbNewPlane name tg_data l = + do rns <- getRandoms + random_id <- getRandomR (1,1000000) + random_name <- randomPlanetName PanGalacticTreatyOrganization + dbAddPlane (Plane { plane_biome = tg_biome tg_data, + plane_terrain = generateTerrain tg_data rns, + plane_random_id = random_id, + plane_planet_name = fromMaybe random_name name}) l +planetName :: (DBReadable db) => PlaneRef -> db B.ByteString +planetName = liftM plane_planet_name . dbGetPlane + +randomPlanetName :: (DBReadable db) => Faction -> db B.ByteString +randomPlanetName faction = + do planet_number <- getRandomR (1000 :: Integer,9999) + return $ factionPrefix faction `B.append` "-" `B.append` B.pack (show planet_number) + -- | -- If this object is anywhere on a plane (such as carried by a creature who is on the plane), -- returns the position of this object on that plane. -- -getPlanarLocation :: (DBReadable db,ReferenceType a) => Reference a -> db (Maybe (Location S (Reference ()) (PlaneRef,Position))) -getPlanarLocation ref = +getPlanarPosition :: (DBReadable db,ReferenceType a,LocationType p) => Reference a -> db (Maybe (Location S (Reference ()) p)) +getPlanarPosition ref = liftM (listToMaybe . mapMaybe coerceLocationRecord) $ dbGetAncestors ref -- | --- Distance between two entities. +-- Distance between two entities. If the entities are not on the same plane, or for some other reason it doesn't make +-- sense to ask their distance, the Nothing. -- dbDistanceBetweenSquared :: (DBReadable db,ReferenceType a,ReferenceType b) => Reference a -> Reference b -> db (Maybe Integer) dbDistanceBetweenSquared a_ref b_ref = - do m_a <- liftM (fmap location) $ getPlanarLocation a_ref - m_b <- liftM (fmap location) $ getPlanarLocation b_ref + do m_a <- liftM (fmap location) $ getPlanarPosition a_ref + m_b <- liftM (fmap location) $ getPlanarPosition b_ref return $ - do (p_a,a) <- m_a - (p_b,b) <- m_b + do (p_a :: PlaneRef,a :: MultiPosition) <- m_a + (p_b,b :: MultiPosition) <- m_b guard $ p_a == p_b return $ distanceBetweenSquared a b @@ -48,18 +70,7 @@ -- Gets the current plane of interest based on whose turn it is. -- dbGetCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef) -dbGetCurrentPlane = - do state <- playerState - case state of - PlayerCreatureTurn creature_ref _ -> - liftM (fmap $ fst . location) $ getPlanarLocation creature_ref - SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> - liftM (fmap $ fst . location) $ getPlanarLocation attacker_ref - SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> - liftM (fmap $ fst . location) $ getPlanarLocation attacker_ref - SnapshotEvent (KilledEvent killed_ref) -> - liftM (fmap $ fst . location) $ getPlanarLocation killed_ref - _ -> return Nothing +dbGetCurrentPlane = liftM (fmap location) $ maybe (return Nothing) getPlanarPosition . creatureOf =<< playerState -- | -- Selects sites at random until one seems reasonably clear. It begins at @@ -68,30 +79,74 @@ -- -- A site is considered clear if there are no objects at all within object_clear squares, and -- only appropriate terrain (as defined by a predicate) within terrain_clear squares. +-- Distance is chessboard distance. -- --- This function will return an unsuitable site if it can't find a suitable one. --- Such a site may have unsuitable terrain around it or it may be outside of --- the search_radius (it is never impossible to find an area free of objects, since --- terrain is infinite and objects are not). +-- This function will expand the search radius liberally if encounters the slightest +-- difficulty finding a qualifying position. The search radius parameter is strictly advisory. -- -pickRandomClearSite :: Integer -> Integer -> Integer -> Position -> (TerrainPatch -> Bool) -> PlaneRef -> DB Position -pickRandomClearSite search_radius object_clear terrain_clear (Position (start_x,start_y)) terrainPredicate plane_ref = +-- This function can take an optional timeout parameter (pickRandomClearSite_withTimeout). When used +-- without a timeout parameter, it may not terminate. The only possible cause of non-termination is that no +-- site satisfies the terrain predicate. +-- +-- The timeout value should be a small integer greater or equal to one, since this function is exponential in the timeout value. +-- +pickRandomClearSite :: (DBReadable db) => + Integer -> Integer -> Integer -> + Position -> (TerrainPatch -> Bool) -> PlaneRef -> + db Position +pickRandomClearSite search_radius object_clear terrain_clear p terrainPredicate plane_ref = liftM (fromMaybe $ error "pickRandomClearSite: impossible") $ + pickRandomClearSite_withTimeout Nothing search_radius object_clear terrain_clear p terrainPredicate plane_ref + +pickRandomClearSite_withTimeout :: (DBReadable db) => + Maybe Integer -> Integer -> Integer -> Integer -> + Position -> (TerrainPatch -> Bool) -> PlaneRef -> + db (Maybe Position) +pickRandomClearSite_withTimeout (Just x) _ _ _ _ _ _ | x <= 0 = return Nothing +pickRandomClearSite_withTimeout timeout search_radius object_clear terrain_clear (Position (start_x,start_y)) terrainPredicate plane_ref = do xys <- liftM2 (\a b -> map Position $ zip a b) - (mapM (\x -> liftM (+start_x) $ roll [-x..x]) [1..search_radius]) - (mapM (\x -> liftM (+start_y) $ roll [-x..x]) [1..search_radius]) + (mapM (\x -> liftM (+start_x) $ getRandomR (-x,x)) [1..search_radius]) + (mapM (\x -> liftM (+start_y) $ getRandomR (-x,x)) [1..search_radius]) terrain <- liftM plane_terrain $ dbGetPlane plane_ref - clutter_locations <- locationsOf $ dbGetContents plane_ref + (clutter_locations :: [MultiPosition]) <- locationsOf $ dbGetContents plane_ref let terrainIsClear (Position (x,y)) = all terrainPredicate $ concat [[gridAt terrain (x',y') | x' <- [x-terrain_clear..x+terrain_clear]] | y' <- [y-terrain_clear..y+terrain_clear]] - let clutterIsClear (Position (x,y)) = not $ any (\(Position (x',y')) -> abs (x' - x) <= object_clear && y' - y <= object_clear) clutter_locations - maybe (pickRandomClearSite (search_radius + 1) - object_clear - (max 0 $ terrain_clear - 1) - (Position (start_x,start_y)) - terrainPredicate - plane_ref) - return $ - find (\p -> terrainIsClear p && clutterIsClear p) xys + let clutterIsClear here = not $ any (\p -> distanceBetweenChessboard here p <= object_clear) clutter_locations + let m_result = find (\p -> terrainIsClear p && clutterIsClear p) xys + case m_result of + Just result -> return $ Just result + Nothing -> pickRandomClearSite_withTimeout + (fmap (subtract 1) timeout) + (search_radius*2 + 1) + object_clear + (max 0 $ terrain_clear - 1) + (Position (start_x,start_y)) + terrainPredicate + plane_ref + +terrainAt :: (DBReadable db) => PlaneRef -> Position -> db TerrainPatch +terrainAt plane_ref (Position (x,y)) = + do terrain <- liftM plane_terrain $ dbGetPlane plane_ref + return $ gridAt terrain (x,y) + +setTerrainAt :: PlaneRef -> Position -> TerrainPatch -> DB () +setTerrainAt plane_ref (Position pos) patch = dbModPlane (\p -> p { plane_terrain = specificReplaceGrid pos patch $ plane_terrain p }) plane_ref + +-- | Lists all of the entities that are on a specific spot, not including nested entities. +-- Typically this is zero or one creatures, and zero or more tools. +whatIsOccupying :: (DBReadable db,GenericReference a S) => PlaneRef -> Position -> db [a] +whatIsOccupying plane_ref position = + liftM (mapMaybe fromLocation . filter ((== 0) . (distanceBetweenChessboard position) . location) . map (asLocationTyped _nullary _multiposition)) $ dbGetContents plane_ref + +-- | Answers True iff a creature may walk or swim or drop objects at the position. +-- Lava is considered passable, but trees are not. +isTerrainPassable :: (DBReadable db) => PlaneRef -> CreatureRef -> Position -> db Bool +isTerrainPassable plane_ref creature_ref position = + do (critters :: [Either BuildingRef CreatureRef]) <- liftM (filter (=/= creature_ref)) $ whatIsOccupying plane_ref position + terrain <- terrainAt plane_ref position + return $ not (terrain `elem` [RockFace,Forest,DeepForest]) && null critters + +getBiome :: (DBReadable db) => PlaneRef -> db Biome +getBiome = liftM plane_biome . dbGetPlane diff --git a/src/PlaneData.hs b/src/PlaneData.hs --- a/src/PlaneData.hs +++ b/src/PlaneData.hs @@ -4,7 +4,11 @@ where import TerrainData +import qualified Data.ByteString.Char8 as B data Plane = Plane - { plane_terrain :: TerrainMap } + { plane_biome :: Biome, + plane_terrain :: TerrainGrid, + plane_random_id :: Integer, + plane_planet_name :: B.ByteString } deriving (Read,Show) diff --git a/src/PlaneVisibility.hs b/src/PlaneVisibility.hs --- 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 PlaneData import Control.Monad import CreatureData -import Data.Maybe import Data.List import Grids import GridRayCaster import VisibilityData import Facing import Data.Ratio +import Building +import Position +import Control.Applicative dbGetSeersForFaction :: (DBReadable db) => Faction -> PlaneRef -> db [CreatureRef] dbGetSeersForFaction faction plane_ref = - filterRO (filterByFaction faction) =<< dbGetContents plane_ref + filterM (filterByFaction faction) =<< dbGetContents plane_ref -- | -- Returns a list of all terrain patches that are visible to any creature belonging @@ -39,7 +41,7 @@ -- dbGetVisibleTerrainForCreature :: (DBReadable db) => CreatureRef -> db [(TerrainPatch,Position)] dbGetVisibleTerrainForCreature creature_ref = - do loc <- liftM (fmap location) $ getPlanarLocation creature_ref + do loc <- liftM (fmap location) $ getPlanarPosition creature_ref spot_check <- dbGetSpotCheck creature_ref case loc of Just (plane_ref,creature_at) -> liftM (visibleTerrain creature_at spot_check . plane_terrain) $ dbGetPlane plane_ref @@ -47,61 +49,65 @@ -- | -- Returns a list of all objects that are visible to any creature belonging --- to the specified faction on the specified plane. +-- to the specified faction on the specified plane. Accepts a filter to +-- determine what kinds of objects will be tested.. -- -dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => Faction -> PlaneRef -> db [a] -dbGetVisibleObjectsForFaction faction plane_ref = +dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> Faction -> PlaneRef -> db [a] +dbGetVisibleObjectsForFaction filterF faction plane_ref = do critters <- dbGetSeersForFaction faction plane_ref - liftM (nubBy (=:=) . concat) $ mapM dbGetVisibleObjectsForCreature critters + liftM (nubBy (=:=) . concat) $ mapRO (dbGetVisibleObjectsForCreature filterF) critters -- | -- Returns a list of all objects that are visible to the specified creature. +-- Accepts a filter to determine what kinds of objects will be tested. -- -dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => CreatureRef -> db [a] -dbGetVisibleObjectsForCreature creature_ref = - do loc <- liftM (fmap location) $ getPlanarLocation creature_ref +dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> CreatureRef -> db [a] +dbGetVisibleObjectsForCreature filterF creature_ref = + do (loc :: Maybe PlaneRef) <- liftM (fmap location) $ getPlanarPosition creature_ref case loc of - Just (plane_ref,_) -> filterRO (dbIsPlanarVisibleTo creature_ref . generalizeReference) =<< dbGetContents plane_ref + Just plane_ref -> filterRO (\a -> (&&) <$> filterF a <*> (dbIsPlanarVisible creature_ref $ generalizeReference a)) =<< dbGetContents plane_ref Nothing -> return [] -- | --- dbIsPlanarVisibleTo (a creature) (some object) is true if the creature can see the object. +-- dbIsPlanarVisible (a creature) (some object) is true if the creature can see the object. -- -dbIsPlanarVisibleTo :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool -dbIsPlanarVisibleTo creature_ref obj_ref | creature_ref =:= obj_ref = return True -dbIsPlanarVisibleTo creature_ref obj_ref = - do creature_loc <- liftM (fmap location) $ getPlanarLocation creature_ref - obj_loc <- liftM (fmap location) $ getPlanarLocation obj_ref +dbIsPlanarVisible :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool +dbIsPlanarVisible creature_ref obj_ref | creature_ref =:= obj_ref = return True +dbIsPlanarVisible creature_ref obj_ref = + do (creature_loc :: Maybe (PlaneRef,Position)) <- liftM (fmap location) $ getPlanarPosition creature_ref + (obj_loc :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap location) $ getPlanarPosition obj_ref spot_check <- dbGetOpposedSpotCheck creature_ref obj_ref case (creature_loc,obj_loc) of (Nothing,_) -> return False (_,Nothing) -> return False (Just (c_plane,_),Just (o_plane,_)) | c_plane /= o_plane -> return False --never see objects on different planes - (Just (_,Position (cx,cy)),Just (_,Position (ox,oy))) | abs (cx-ox) <= 1 && abs (cy-oy) <= 1 -> return True --automatically see 8-adjacent objects - (Just (_,Position (cx,cy)),Just (_,Position (ox,oy))) | (ox-cx)^2+(oy-cy)^2 > (maximumRangeForSpotCheck spot_check)^2 -> return False --cull objects that are too far away to ever be seen - (Just (c_plane,Position (cx,cy)),Just (_,Position (ox,oy))) -> - do let delta_at = (ox-cx,oy-cy) - terrain <- liftM plane_terrain $ dbGetPlane c_plane -- falling through all other tests, cast a ray for visibility - return $ castRay (cx,cy) (ox,oy) (spot_check - distanceCostForSight Here delta_at) (terrainOpacity . gridAt terrain) + (Just (_,cp),Just (_,ops)) | distanceBetweenChessboard cp ops <= 1 -> return True --automatically see 8-adjacent objects + (Just (_,cp),Just (_,ops)) | distanceBetweenSquared cp ops > (maximumRangeForSpotCheck spot_check)^2 -> return False --cull objects that are too far away to ever be seen + (Just (c_plane,cp),Just (_,ops)) -> liftM or $ forM (positionPairs cp ops) $ + \(Position (cx,cy),Position (ox,oy)) -> + do let delta_at = (ox-cx,oy-cy) + terrain <- liftM plane_terrain $ dbGetPlane c_plane -- falling through all other tests, cast a ray for visibility + return $ castRay (cx,cy) (ox,oy) (spot_check - distanceCostForSight Here delta_at) (terrainOpacity . gridAt terrain) dbGetOpposedSpotCheck :: (DBReadable db) => CreatureRef -> Reference a -> db Integer dbGetOpposedSpotCheck creature_ref object_ref = do spot <- dbGetSpotCheck creature_ref hide <- dbGetHideCheck object_ref - return $ spot * (round $ min 1 $ spot % hide) + return $ round $ (spot%1) * opposedLinearPowerRatio spot hide dbGetSpotCheck :: (DBReadable db) => CreatureRef -> db Integer -dbGetSpotCheck creature_ref = liftM (creatureScore Spot) $ dbGetCreature creature_ref +dbGetSpotCheck creature_ref = liftM (creatureAbilityScore SpotSkill) $ dbGetCreature creature_ref dbGetHideCheck :: (DBReadable db) => Reference a -> db Integer -dbGetHideCheck ref | Just creature_ref <- coerceReferenceTyped _creature ref = liftM (creatureScore Hide) $ dbGetCreature creature_ref -dbGetHideCheck _ = return 1 +dbGetHideCheck ref | Just creature_ref <- coerceReferenceTyped _creature ref = liftM (creatureAbilityScore HideSkill) $ dbGetCreature creature_ref +dbGetHideCheck ref | Just building_ref <- coerceReferenceTyped _building ref = liftM negate $ buildingSize building_ref +dbGetHideCheck _ | otherwise = return 1 -- | -- visibleTerrain (creature's location) (spot check) (the terrain map) gives -- a list of visible terrain patches from that location with that spot check. -- -visibleTerrain :: Position -> Integer -> TerrainMap -> [(TerrainPatch,Position)] +visibleTerrain :: Position -> Integer -> TerrainGrid -> [(TerrainPatch,Position)] visibleTerrain (Position (creature_at@(creature_x,creature_y))) spot_check terrain = let max_range = maximumRangeForSpotCheck spot_check in map (\(x,y) -> (gridAt terrain (x,y),Position (x,y))) $ diff --git a/src/Position.hs b/src/Position.hs --- 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] } -distanceBetweenSquared :: Position -> Position -> Integer -distanceBetweenSquared (Position (x,y)) (Position (u,v)) = (x - u)^2 + (y - v)^2 +instance Eq MultiPosition where + (==) (MultiPosition as) (MultiPosition bs) = Set.fromList as == Set.fromList bs -distanceBetweenChessboard :: Position -> Position -> Integer -distanceBetweenChessboard (Position (x,y)) (Position (u,v)) = max (abs $ u - x) (abs $ v - y) +instance Ord MultiPosition where + compare (MultiPosition as) (MultiPosition bs) = Set.fromList as `compare` Set.fromList bs + +class PositionType p where + toMultiPosition :: p -> MultiPosition + offsetPosition :: (Integer,Integer) -> p -> p + +instance PositionType Position where + toMultiPosition p = MultiPosition [p] + offsetPosition (x,y) (Position (u,v)) = Position (x+u,y+v) + +instance PositionType MultiPosition where + toMultiPosition = id + offsetPosition xy (MultiPosition ps) = MultiPosition $ map (offsetPosition xy) ps + +-- | Construct a 'MultiPosition' from a base position and a list of offsets. +-- The base position always counts as part of the MultiPosition. +multiPosition :: Position -> [(Integer,Integer)] -> MultiPosition +multiPosition (Position xy) xys = MultiPosition $ nub $ Position xy : map (offsetPosition xy . Position) xys + +-- | Pythagorean distance, squared. +-- For multi-positions, measures the minimal distance. +distanceBetweenSquared :: (PositionType a,PositionType b) => a -> b -> Integer +distanceBetweenSquared as bs = minimum $ + do Position (x,y) <- fromMultiPosition $ toMultiPosition as + Position (u,v) <- fromMultiPosition $ toMultiPosition bs + return $ (x - u)^2 + (y - v)^2 + +-- | Number of squares you would have to move (as a queen on a chessboard) to arrive from the first position to the second. +-- For multi-positions, measures the minimal distance. +distanceBetweenChessboard :: (PositionType a,PositionType b) => a -> b -> Integer +distanceBetweenChessboard as bs = minimum $ + do Position (x,y) <- fromMultiPosition $ toMultiPosition as + Position (u,v) <- fromMultiPosition $ toMultiPosition bs + return $ max (abs $ u - x) (abs $ v - y) + +-- | List all pairs of positions between two MutiPositions. +positionPairs :: (PositionType a,PositionType b) => a -> b -> [(Position,Position)] +positionPairs as bs = + do a <- fromMultiPosition $ toMultiPosition as + b <- fromMultiPosition $ toMultiPosition bs + return (a,b) diff --git a/src/Protocol.hs b/src/Protocol.hs --- a/src/Protocol.hs +++ b/src/Protocol.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, PatternSignatures #-} +{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, OverloadedStrings #-} module Protocol (mainLoop) @@ -9,41 +9,120 @@ import CreatureData import Creature import Character -import StatsData import DB -import DBData import System.Exit -import Races import System.IO import BeginGame import Data.Maybe import Plane +import PlaneData +import Building +import BuildingData import Tool import FactionData import PlaneVisibility import Facing import ToolData import Control.Monad.Error -import Numeric import Turns -import Data.IORef +import SpeciesData +import Species +import Data.Ord +import Combat +import Substances +import PlayerState +import Make +import Control.Concurrent +import Control.Monad.STM +import Control.Concurrent.STM.TVar +import Control.Exception +import WorkCluster +import qualified Data.ByteString.Char8 as B +import qualified Perception -- Don't call dbBehave, use dbPerformPlayerTurn import Behavior hiding (dbBehave) -- We need to construct References based on UIDs, so we cheat a little: -import DBPrivate (Reference(..)) +import DBPrivate (Reference(ToolRef)) mainLoop :: DB_BaseType -> IO () -mainLoop db0 = - do db <- newIORef db0 - forever $ - do next_command <- getLine - writeIORef db =<< ioDispatch (words $ map toLower next_command) =<< readIORef db - putStrLn "over" - hFlush stdout +mainLoop db_init = + do db_var <- newMVar db_init + input_chan <- newChan + output_chan <- newChan + query_count <- newTVarIO (Just 0) -- Just (the number of running queries) or Nothing (a non-query action is in progress) + wait_quit <- newEmptyMVar + work_cluster <- newWorkCluster + replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var + let foreverLoopThenQuit = flip finally (putMVar wait_quit ()) . forever + _ <- forkIO $ foreverLoopThenQuit $ writeChan input_chan =<< B.getLine + _ <- forkIO $ foreverLoopThenQuit $ + do next_line <- liftM (B.map toLower . B.unlines . B.lines) (readChan output_chan) + when (B.length next_line > 0) $ + do B.putStrLn next_line + B.putStrLn "over" + hFlush stdout + _ <- forkIO $ foreverLoopThenQuit $ + do next_command <- readChan input_chan + case (B.words $ B.map toLower next_command) of + ["quit"] -> exitWith ExitSuccess + ["reset"] -> stopping query_count $ modifyMVar_ db_var (const $ return initial_db) + ("game":"query":args) -> + do querrying query_count $ + do result <- workRequest work_cluster (Query, args) + complete Nothing output_chan result + ("game":"action":args) -> + do result <- workRequest work_cluster (Action, args) + stopping query_count $ complete (Just db_var) output_chan result + querrying query_count $ complete Nothing output_chan result -- print the result as a query, this will ensure errors get printed + replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var + ("noop":_) -> return () + failed -> + do _ <- forkIO $ complete Nothing output_chan $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ B.unpack (B.unwords failed) ++ "`" + return () + takeMVar wait_quit -- "park" the main function -done :: DB String -done = return "done" +-- | Evaluate a 'GameDirective' and return it from a remote thread via an 'MVar'. +evaluateGame :: DB_BaseType -> WorkRequest -> IO WorkResult +evaluateGame db0 (Query, ["snapshot"]) = (runDB $ ro $ liftM (\b -> "answer: snapshot " `B.append` if b then "yes" else "no") dbHasSnapshot) db0 +evaluateGame db0 (Query, args) = (runDB $ ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0 +evaluateGame db0 (Action, args) = runDB (liftM (const "") $ dbDispatchAction args) db0 +-- | Wait for currently running queries to finish, and stop processing incomming queries while we mutate the database. +stopping :: TVar (Maybe Integer) -> IO () -> IO () +stopping query_count actionM = bracket + (atomically $ do maybe retry (\x -> when (x /= 0) retry) =<< readTVar query_count + writeTVar query_count $ Nothing) + (const $ atomically $ writeTVar query_count (Just 0)) + (const actionM) + +-- | Process a querry concurrently with other queries. +querrying :: TVar (Maybe Integer) -> IO () -> IO () +querrying query_count actionM = + do atomically $ writeTVar query_count =<< liftM Just . (maybe retry $ return . (+1)) =<< readTVar query_count + _ <- forkIO $ finally (atomically $ do writeTVar query_count =<< liftM (fmap (subtract 1)) (readTVar query_count)) actionM + return () + +-- | Complete a querry or action. If a database variable is provided, it will be modified according to the result of the action. +-- The result of the action will be printed to the output_chan. +complete :: Maybe (MVar DB_BaseType) -> Chan B.ByteString -> Either DBError (B.ByteString,DB_BaseType) -> IO () +complete m_db_var output_chan result = + do case m_db_var of + Just db_var -> + do modifyMVar_ db_var $ \db0 -> return $ case result of + Right (_,db1) -> db1 + Left (DBErrorFlag errflag) -> db0 { db_error_flag = show errflag } + Left (DBError _) -> db0 + writeChan output_chan "done" + Nothing -> + do case result of + Right (outstr,_) -> + do _ <- evaluate outstr + writeChan output_chan outstr + Left (DBErrorFlag _) -> return () -- client will query this explicitly (if it cares) + Left (DBError errstr) -> + do writeChan output_chan $ "error: " `B.append` B.pack errstr + B.hPutStrLn stderr $ "DBError: " `B.append` B.pack errstr + dbOldestSnapshotOnly :: (DBReadable db) => db () dbOldestSnapshotOnly = do b <- dbHasSnapshot @@ -53,199 +132,266 @@ -- Perform an action assuming the database is in the DBRaceSelectionState, -- otherwise returns an error message. -- -dbRequiresRaceSelectionState :: (DBReadable db) => db String -> db String +dbRequiresRaceSelectionState :: (DBReadable db) => db a -> db a dbRequiresRaceSelectionState action = do dbOldestSnapshotOnly state <- playerState case state of RaceSelectionState -> action - _ -> return $ "protocol-error: not in race selection state (" ++ show state ++ ")" + _ -> throwError $ DBError $ "protocol-error: not in race selection state (" ++ show state ++ ")" -- | -- Perform an action assuming the database is in the DBClassSelectionState, -- otherwise returns an error message. -- -dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db String) -> db String +dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db a) -> db a dbRequiresClassSelectionState action = do dbOldestSnapshotOnly state <- playerState case state of ClassSelectionState creature -> action creature - _ -> return $ "protocol-error: not in class selection state (" ++ show state ++ ")" + _ -> throwError $ DBError $ "protocol-error: not in class selection state (" ++ show state ++ ")" -- | -- Perform an action that operates on the player creature (not in any context). -- The states that work for this are: -- --- DBClassSelectionState --- DBPlayerCreatureTurn +-- * ClassSelectionState +-- * PlayerCreatureTurn -- -dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db String) -> db String +dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db a) -> db a dbRequiresPlayerCenteredState action = do dbOldestSnapshotOnly state <- playerState case state of ClassSelectionState creature -> action creature PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref - _ -> return $ "protocol-error: not in player-centered state (" ++ show state ++ ")" + _ -> throwError $ DBError $ "protocol-error: not in player-centered state (" ++ show state ++ ")" -- | -- Perform an action that works during any creature's turn in a planar environment. -- The states that work for this are: -- --- DBPlayerCreaturePickupMode --- DBEvent +-- * PlayerCreatureTurn +-- * SnapshotEvent -- -dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String +dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a dbRequiresPlanarTurnState action = do dbOldestSnapshotOnly state <- playerState - case state of - PlayerCreatureTurn creature_ref _ -> action creature_ref - SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> action attacker_ref - SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> action attacker_ref - SnapshotEvent (KilledEvent killed_ref) -> action killed_ref - _ -> return $ "protocol-error: not in planar turn state (" ++ show state ++ ")" + maybe (throwError $ DBError $ "protocol-error: not in planar turn state (" ++ show state ++ ")") action $ creatureOf state -- | -- Perform an action that works only during a player-character's turn. -- The states that work for this are: -- --- DBPlayerCreatureTurn +-- PlayerCreatureTurn -- -dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String +dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a dbRequiresPlayerTurnState action = do dbOldestSnapshotOnly state <- playerState case state of PlayerCreatureTurn creature_ref _ -> action creature_ref - _ -> return $ "protocol-error: not in player turn state (" ++ show state ++ ")" - -ioDispatch :: [String] -> DB_BaseType -> IO DB_BaseType - -ioDispatch ["quit"] _ = exitWith ExitSuccess - -ioDispatch ["reset"] _ = do putStrLn "done" - return initial_db - -ioDispatch ("game":game) db0 = - do a <- case game of - ["query","snapshot"] -> runDB (ro $ liftM (\b -> "answer: snapshot " ++ if b then "yes" else "no") $ dbHasSnapshot) db0 - ("query":args) -> runDB (ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0 - ("action":args) -> runDB (dbDispatchAction args) db0 - _ -> return $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ unwords game ++ "`" - case a of - Right (outstr,db1) -> - do putStrLn (map toLower outstr) - return db1 - Left (DBErrorFlag errstr) -> - do putStrLn "done" - return $ db0 { db_error_flag = errstr } - Left (DBError errstr) -> - do putStrLn (map toLower errstr ++ "\n") - return db0 - -ioDispatch ("save":_) db0 = do putStrLn "engine-error: save not implemented" - return db0 - -ioDispatch ("load":_) db0 = do putStrLn "engine-error: load not implemented" - return db0 + _ -> throwError $ DBError $ "protocol-error: not in player turn state (" ++ show state ++ ")" -ioDispatch ("noop":_) db0 = return db0 +-- | +-- For arbitrary-length menu selections, get the current index into the menu, if any. +-- +menuState :: (DBReadable db) => db (Maybe Integer) +menuState = liftM menuIndex playerState -ioDispatch unknown_command db0 = do putStrLn ("protocol-error: unknown command " ++ (unwords unknown_command)) - return db0 +-- | +-- For arbitrary-length menu selections, modify the current index into the menu. If there is no menu index +-- in the current state, this has no effect. +-- +modifyMenuState :: (Integer -> Integer) -> DB () +modifyMenuState f_ = + do number_of_tools <- liftM genericLength toolMenuElements + let f = (\x -> if number_of_tools == 0 then 0 else x `mod` number_of_tools) . f_ + setPlayerState . modifyMenuIndex f =<< playerState -dbDispatchQuery :: (DBReadable db) => [String] -> db String +dbDispatchQuery :: (DBReadable db) => [B.ByteString] -> db B.ByteString dbDispatchQuery ["state"] = do state <- playerState return $ case state of RaceSelectionState -> "answer: state race-selection" ClassSelectionState {} -> "answer: state class-selection" PlayerCreatureTurn _ NormalMode -> "answer: state player-turn" - PlayerCreatureTurn _ PickupMode -> "answer: state pickup" - PlayerCreatureTurn _ DropMode -> "answer: state drop" - PlayerCreatureTurn _ WieldMode -> "answer: state wield" - SnapshotEvent (AttackEvent {}) -> "answer: state attack" - SnapshotEvent (MissEvent {}) -> "answer: state miss" - SnapshotEvent (KilledEvent {}) -> "answer: state killed" + PlayerCreatureTurn _ MoveMode -> "answer: state move" + PlayerCreatureTurn _ (PickupMode {}) -> "answer: state pickup" + PlayerCreatureTurn _ (DropMode {}) -> "answer: state drop" + PlayerCreatureTurn _ (WieldMode {}) -> "answer: state wield" + PlayerCreatureTurn _ AttackMode -> "answer: state attack" + PlayerCreatureTurn _ FireMode -> "answer: state fire" + PlayerCreatureTurn _ JumpMode -> "answer: state jump" + PlayerCreatureTurn _ TurnMode -> "answer: state turn" + PlayerCreatureTurn _ (MakeMode _ make_prep) | isFinished make_prep -> "answer: state make-finished" + PlayerCreatureTurn _ (MakeMode _ make_prep) | needsKind make_prep -> "answer: state make-what" + PlayerCreatureTurn _ (MakeMode {}) -> "answer: state make" + PlayerCreatureTurn _ ClearTerrainMode -> "answer: state clear-terrain" + SnapshotEvent (AttackEvent {}) -> "answer: state attack-event" + SnapshotEvent (MissEvent {}) -> "answer: state miss-event" + SnapshotEvent (KilledEvent {}) -> "answer: state killed-event" + SnapshotEvent (WeaponOverheatsEvent {}) -> "answer: state weapon-overheats-event" + SnapshotEvent (WeaponExplodesEvent {}) -> "answer: state weapon-explodes-event" + SnapshotEvent (DisarmEvent {}) -> "answer: state disarm-event" + SnapshotEvent (SunderEvent {}) -> "answer: state sunder-event" + SnapshotEvent (TeleportEvent {}) -> "answer: state teleport-event" + SnapshotEvent (HealEvent {}) -> "answer: state heal-event" + SnapshotEvent (ExpendToolEvent {}) -> "answer: state expend-tool-event" GameOver -> "answer: state game-over" +dbDispatchQuery ["action-count"] = + do n <- dbActionCount + return $ "answer: action-count " `B.append` (B.pack $ show n) + +dbDispatchQuery ["menu-state"] = + do m_state <- menuState + return $ case m_state of + Nothing -> "answer: menu-state 0" + Just state -> "answer: menu-state " `B.append` (B.pack $ show state) + dbDispatchQuery ["who-attacks"] = do state <- playerState return $ case state of - SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " ++ (show $ toUID attacker_ref) - SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " ++ (show $ toUID attacker_ref) + SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref) + SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref) + SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref) + SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref) + SnapshotEvent (DisarmEvent { disarm_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref) + SnapshotEvent (SunderEvent { sunder_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref) _ -> "answer: who-attacks 0" dbDispatchQuery ["who-hit"] = do state <- playerState return $ case state of - SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " ++ (show $ toUID target_ref) + SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref) + SnapshotEvent (DisarmEvent { disarm_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref) + SnapshotEvent (SunderEvent { sunder_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref) _ -> "answer: who-hit 0" +dbDispatchQuery ["tool-used"] = + do state <- playerState + return $ case state of + SnapshotEvent (ExpendToolEvent { expend_tool_event_tool = tool_ref }) -> "answer: tool-used " `B.append` (B.pack $ show $ toUID tool_ref) + _ -> "answer: tool-used 0" + dbDispatchQuery ["weapon-used"] = do state <- playerState return $ case state of - SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref) - SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref) + SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref) + SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref) + SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref) + SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref) + SnapshotEvent (SunderEvent { sunder_event_source_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref) _ -> "answer: weapon-used 0" +dbDispatchQuery ["tool-hit"] = + do state <- playerState + return $ case state of + SnapshotEvent (DisarmEvent { disarm_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref) + SnapshotEvent (SunderEvent { sunder_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref) + _ -> "answer: tool-hit 0" + dbDispatchQuery ["who-killed"] = do state <- playerState return $ case state of - SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " ++ (show $ toUID killed_ref) + SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " `B.append` (B.pack $ show $ toUID killed_ref) _ -> "answer: who-killed 0" +dbDispatchQuery ["who-event"] = + do state <- playerState + return $ case state of + SnapshotEvent event -> "answer: who-event " `B.append` fromMaybe "0" (fmap (B.pack . show . toUID) $ subjectOf event) + _ -> "answer: who-event 0" + dbDispatchQuery ["player-races","0"] = - return ("begin-table player-races 0 name\n" ++ - unlines player_race_names ++ + return ("begin-table player-races 0 name\n" `B.append` + B.unlines (map B.pack player_race_names) `B.append` "end-table") dbDispatchQuery ["visible-terrain","0"] = do maybe_plane_ref <- dbGetCurrentPlane terrain_map <- maybe (return []) (dbGetVisibleTerrainForFaction Player) maybe_plane_ref - return ("begin-table visible-terrain 0 x y terrain-type\n" ++ - (unlines $ map (\(terrain_type,Position (x,y)) -> unwords [show x, show y, show terrain_type]) terrain_map) ++ + return ("begin-table visible-terrain 0 x y terrain-type\n" `B.append` + (B.unlines $ map (\(terrain_type,Position (x,y)) -> B.unwords $ map B.pack [show x, show y, show terrain_type]) terrain_map) `B.append` "end-table") +dbDispatchQuery ["who-player"] = return "answer: who-player 2" + dbDispatchQuery ["visible-objects","0"] = do maybe_plane_ref <- dbGetCurrentPlane - (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref + (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref table_rows <- mapM (dbObjectToTableRow . entity) objects - return ("begin-table visible-objects 0 object-unique-id x y facing\n" ++ - (unlines $ table_rows) ++ + return ("begin-table visible-objects 0 object-unique-id x y facing\n" `B.append` + (B.unlines $ table_rows) `B.append` "end-table") where dbObjectToTableRow obj_ref = do l <- dbWhere obj_ref return $ case (extractLocation l,extractLocation l) of - (Just (Position (x,y)),maybe_face) -> unwords [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face] + (Just (Position (x,y)),maybe_face) -> B.unwords $ map B.pack $ [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face] _ -> "" -dbDispatchQuery ["object-details",_] = ro $ +dbDispatchQuery ["object-details",uid] = ro $ do maybe_plane_ref <- dbGetCurrentPlane - (visibles :: [Reference ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref + (visibles :: [Reference ()]) <- maybe + (return []) + (flip dbGetVisibleObjectsForFaction Player $ \ref -> + do let f = (== uid) . B.pack . show . toUID + let m_wielder = coerceReference ref + m_wield <- maybe (return Nothing) dbGetWielded m_wielder + return $ maybe False f m_wield || f ref) + maybe_plane_ref let creature_refs = mapMaybe (coerceReferenceTyped _creature) visibles wielded <- liftM catMaybes $ mapM dbGetWielded creature_refs let tool_refs = mapMaybe (coerceReferenceTyped _tool) visibles ++ wielded + let building_refs = mapMaybe (coerceReferenceTyped _building) visibles creatures <- liftM (zip creature_refs) $ mapRO dbGetCreature creature_refs - tools <- liftM (zip tool_refs)$ mapRO dbGetTool tool_refs - return $ unlines $ (map creatureToTableData creatures ++ - map toolToTableData tools) - where objectTableWrapper obj_ref table_data = - ("begin-table object-details " ++ - (show $ toUID obj_ref) ++ - " property value\n" ++ - table_data ++ - "end-table") - creatureToTableData :: (CreatureRef,Creature) -> String - creatureToTableData (ref,creature) = objectTableWrapper ref $ - "object-type creature\n" ++ - (concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ creatureStatsData creature) - toolToTableData :: (ToolRef,Tool) -> String - toolToTableData (ref,tool) = objectTableWrapper ref $ - "object-type tool\n" ++ - (concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ toolData tool) + tools <- liftM (zip tool_refs) $ mapRO dbGetTool tool_refs + buildings <- liftM (zip building_refs) $ mapRO dbGetBuilding building_refs + liftM B.unlines $ liftM3 (\a b c -> concat [a,b,c]) + (mapM creatureToTableData creatures) + (mapM toolToTableData tools) + (mapM buildingToTableData buildings) + where objectTableWrapper :: (DBReadable db) => + Reference a -> + db B.ByteString -> + db B.ByteString + objectTableWrapper obj_ref tableDataF = + do table_data <- tableDataF + return $ + "begin-table object-details " `B.append` + (B.pack $ show $ toUID obj_ref) `B.append` + " property value\n" `B.append` + table_data `B.append` + "end-table" + creatureToTableData :: (DBReadable db) => + (CreatureRef,Creature) -> + db B.ByteString + creatureToTableData (ref,creature) = objectTableWrapper ref $ + do fac <- getCreatureFaction ref + hp <- getCreatureAbsoluteHealth ref + maxhp <- getCreatureMaxHealth ref + return $ + "object-type creature\n" `B.append` + "species " `B.append` (B.pack $ show $ creature_species creature) `B.append` "\n" `B.append` + "random-id " `B.append` (B.pack $ show $ creature_random_id creature) `B.append` "\n" `B.append` + "faction " `B.append` B.pack (show fac) `B.append` "\n" `B.append` + (if fac == Player then + "hp " `B.append` B.pack (show hp) `B.append` "\n" `B.append` + "maxhp " `B.append` B.pack (show maxhp) `B.append` "\n" + else "") + toolToTableData :: (DBReadable db) => (ToolRef,Tool) -> db B.ByteString + toolToTableData (ref,tool) = objectTableWrapper ref $ return $ + "object-type tool\n" `B.append` + "tool-type " `B.append` toolType tool `B.append` "\n" `B.append` + "tool " `B.append` toolName tool `B.append` "\n" + buildingToTableData :: (DBReadable db) => (BuildingRef,Building) -> db B.ByteString + buildingToTableData (ref,Building) = objectTableWrapper ref $ + do building_type <- buildingType ref + return $ "object-type building\n" `B.append` + "building-type " `B.append` B.pack (show building_type) `B.append` "\n" dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats @@ -254,32 +400,66 @@ dbDispatchQuery ["base-classes","0"] = dbRequiresClassSelectionState dbQueryBaseClasses dbDispatchQuery ["pickups","0"] = dbRequiresPlayerTurnState $ \creature_ref -> - do pickups <- dbAvailablePickups creature_ref - return $ "begin-table pickups 0 uid\n" ++ - unlines (map (show . toUID) pickups) ++ - "end-table" + liftM (showToolMenuTable "pickups" "0") $ toolsToMenuTable =<< dbAvailablePickups creature_ref dbDispatchQuery ["inventory","0"] = dbRequiresPlayerTurnState $ \creature_ref -> - do (inventory :: [ToolRef]) <- dbGetContents creature_ref - return $ "begin-table inventory 0 uid\n" ++ - unlines (map (show . toUID) inventory) ++ - "end-table" + liftM (showToolMenuTable "inventory" "0") $ toolsToMenuTable =<< dbGetContents creature_ref +dbDispatchQuery ["menu","0"] = + liftM (showToolMenuTable "menu" "0") $ toolsToMenuTable =<< toolMenuElements + +dbDispatchQuery ["menu",s] | Just window_size <- readNumber s = + do n <- liftM (fromMaybe 0) menuState + let half_window = window_size `div` 2 + let windowF (x,_,_) = abs (x - (max half_window n)) <= half_window + liftM (showToolMenuTable "menu" s . filter windowF) $ toolsToMenuTable =<< toolMenuElements + dbDispatchQuery ["wielded-objects","0"] = do m_plane_ref <- dbGetCurrentPlane - creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction Player) m_plane_ref + creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) m_plane_ref wielded_tool_refs <- mapM dbGetWielded creature_refs - let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe String - wieldedPairToTable creature_ref = fmap (\tool_ref -> (show $ toUID tool_ref) ++ " " ++ (show $ toUID creature_ref)) - return $ "begin-table wielded-objects 0 uid creature\n" ++ - unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) ++ + let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe B.ByteString + wieldedPairToTable creature_ref = fmap (\tool_ref -> (B.pack $ show $ toUID tool_ref) `B.append` " " `B.append` (B.pack $ show $ toUID creature_ref)) + return $ "begin-table wielded-objects 0 uid creature\n" `B.append` + B.unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) `B.append` "end-table" -dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" ++ unwords unrecognized ++ "`" +dbDispatchQuery ["biome"] = + do m_plane_ref <- dbGetCurrentPlane + biome_name <- case m_plane_ref of + Nothing -> return "nothing" + Just plane_ref -> liftM (show . plane_biome) $ dbGetPlane plane_ref + return $ "answer: biome " `B.append` B.pack biome_name -dbDispatchAction :: [String] -> DB String -dbDispatchAction ["continue"] = dbPopOldestSnapshot >> done +dbDispatchQuery ["current-plane"] = + do m_plane_ref <- dbGetCurrentPlane + return $ case m_plane_ref of + Nothing -> "answer: current-plane 0" + Just plane_ref -> "answer: current-plane " `B.append` (B.pack $ show $ toUID plane_ref) +dbDispatchQuery ["plane-random-id"] = + do m_plane_ref <- dbGetCurrentPlane + case m_plane_ref of + Nothing -> return "answer: plane-random-id 0" + Just plane_ref -> liftM (("answer: plane-random-id " `B.append`) . B.pack . show . plane_random_id) $ dbGetPlane plane_ref + +dbDispatchQuery ["planet-name"] = + do m_plane_ref <- dbGetCurrentPlane + case m_plane_ref of + Nothing -> return "answer: planet-name nothing" + Just plane_ref -> liftM ("answer: planet-name " `B.append`) $ planetName plane_ref + +dbDispatchQuery ["compass"] = + do m_player_ref <- getCurrentCreature Player + case m_player_ref of + Nothing -> return "answer: compass nothing" + Just player_ref -> Perception.runPerception player_ref $ liftM (("answer: compass " `B.append`) . B.pack . show) Perception.compass + +dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" `B.append` B.unwords unrecognized `B.append` "`" + +dbDispatchAction :: [B.ByteString] -> DB () +dbDispatchAction ["continue"] = dbPopOldestSnapshot + dbDispatchAction ["select-race",race_name] = dbRequiresRaceSelectionState $ dbSelectPlayerRace race_name @@ -289,149 +469,272 @@ dbDispatchAction ["select-class",class_name] = dbRequiresClassSelectionState $ dbSelectPlayerClass class_name +dbDispatchAction [direction] | isJust $ stringToFacing direction = + do state <- playerState + case state of + PlayerCreatureTurn _ player_mode -> case player_mode of + JumpMode -> dbDispatchAction ["jump",direction] + TurnMode -> dbDispatchAction ["turn",direction] + AttackMode -> dbDispatchAction ["attack",direction] + FireMode -> dbDispatchAction ["fire",direction] + MoveMode -> dbDispatchAction ["move",direction] + ClearTerrainMode -> dbDispatchAction ["clear-terrain",direction] + _ -> dbDispatchAction ["normal",direction] + _ -> throwError $ DBError $ "protocol-error: not in player turn state" + +dbDispatchAction ["normal"] = + dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref NormalMode) + +dbDispatchAction ["normal",direction] | Just face <- stringToFacing direction = + dbRequiresPlayerTurnState $ \creature_ref -> + do behavior <- facingBehavior creature_ref face + dbPerformPlayerTurn behavior creature_ref + +dbDispatchAction ["move"] = + dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref MoveMode) + dbDispatchAction ["move",direction] | isJust $ stringToFacing direction = - dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref >> done) + dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref) +dbDispatchAction ["jump"] = + dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref JumpMode) + +dbDispatchAction ["jump",direction] | isJust $ stringToFacing direction = + dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Behavior.Jump $ fromJust $ stringToFacing direction) creature_ref) + +dbDispatchAction ["turn"] = + dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref TurnMode) + dbDispatchAction ["turn",direction] | isJust $ stringToFacing direction = - dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref >> done) + dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref +dbDispatchAction ["clear-terrain"] = + dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref ClearTerrainMode) + +dbDispatchAction ["clear-terrain",direction] | isJust $ stringToFacing direction = + dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (ClearTerrain $ fromJust $ stringToFacing direction) creature_ref + +dbDispatchAction ["next"] = modifyMenuState (+1) + +dbDispatchAction ["prev"] = modifyMenuState (subtract 1) + +dbDispatchAction ["select-menu"] = + do state <- playerState + i <- menuState + tool_table <- toolsToMenuTable =<< toolMenuElements + let selection = maybe "0" (\(_,tool_ref,_) -> B.pack $ show $ toUID tool_ref) $ find (\(n,_,_) -> Just n == i) tool_table + case state of + PlayerCreatureTurn _ player_mode -> case player_mode of + PickupMode {} -> dbDispatchAction ["pickup",selection] + DropMode {} -> dbDispatchAction ["drop",selection] + WieldMode {} -> dbDispatchAction ["wield",selection] + MakeMode {} -> dbDispatchAction ["make-with",selection] + _ -> throwError $ DBError $ "protocol-error: not in menu selection state" + _ -> throwError $ DBError $ "protocol-error: not in player turn state" + +dbDispatchAction ["make-begin"] = dbRequiresPlayerTurnState $ \creature_ref -> + setPlayerState (PlayerCreatureTurn creature_ref (MakeMode 0 prepare_make)) + +dbDispatchAction ["make-what",what] | (Just device_kind) <- readDeviceKind what = + do state <- playerState + case state of + PlayerCreatureTurn c (MakeMode n make_prep) -> (setPlayerState $ PlayerCreatureTurn c $ MakeMode n (make_prep `makeWith` device_kind)) + _ -> throwError $ DBError $ "protocol-error: not in make or make-what state" + +dbDispatchAction ["make-with",tool_uid] = + do tool_ref <- readUID ToolRef tool_uid + tool <- dbGetTool tool_ref + state <- playerState + case state of + PlayerCreatureTurn c (MakeMode _ make_prep) -> case (hasChromalite tool, hasMaterial tool, hasGas tool) of + (Just ch,_,_) | needsChromalite make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (ch,tool_ref)) + (_,Just m,_) | needsMaterial make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (m,tool_ref)) + (_,_,Just g) | needsGas make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (g,tool_ref)) + _ | otherwise -> throwError $ DBError "error: tool doesn't have needed substance" + _ -> throwError $ DBError "protocol-error: not in make or make-what state" + +dbDispatchAction ["make-end"] = + do state <- playerState + case state of + PlayerCreatureTurn c (MakeMode _ make_prep) | isFinished make_prep -> dbPerformPlayerTurn (Make make_prep) c + PlayerCreatureTurn _ (MakeMode {}) -> throwError $ DBError "protocol-error: make isn't complete" + _ -> throwError $ DBError "protocol-error: not in make or make-what state" + dbDispatchAction ["pickup"] = dbRequiresPlayerTurnState $ \creature_ref -> do pickups <- dbAvailablePickups creature_ref case pickups of [tool_ref] -> dbPerformPlayerTurn (Pickup tool_ref) creature_ref >> return () - [] -> throwError $ DBErrorFlag "nothing-there" - _ -> setPlayerState (PlayerCreatureTurn creature_ref PickupMode) - done + [] -> throwError $ DBErrorFlag NothingAtFeet + _ -> setPlayerState (PlayerCreatureTurn creature_ref (PickupMode 0)) dbDispatchAction ["pickup",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref -> do tool_ref <- readUID ToolRef tool_uid dbPerformPlayerTurn (Pickup tool_ref) creature_ref - done dbDispatchAction ["drop"] = dbRequiresPlayerTurnState $ \creature_ref -> do inventory <- dbGetContents creature_ref case inventory of [tool_ref] -> dbPerformPlayerTurn (Drop tool_ref) creature_ref >> return () - [] -> throwError $ DBErrorFlag "nothing-in-inventory" - _ -> setPlayerState (PlayerCreatureTurn creature_ref DropMode) - done + [] -> throwError $ DBErrorFlag NothingInInventory + _ -> setPlayerState (PlayerCreatureTurn creature_ref (DropMode 0)) dbDispatchAction ["drop",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref -> do tool_ref <- readUID ToolRef tool_uid dbPerformPlayerTurn (Drop tool_ref) creature_ref - done dbDispatchAction ["wield"] = dbRequiresPlayerTurnState $ \creature_ref -> - do inventory <- dbGetContents creature_ref - case inventory of + do available <- availableWields creature_ref + case available of [tool_ref] -> dbPerformPlayerTurn (Wield tool_ref) creature_ref >> return () - [] -> throwError $ DBErrorFlag "nothing-in-inventory" - _ -> setPlayerState (PlayerCreatureTurn creature_ref WieldMode) - done + [] -> throwError $ DBErrorFlag NothingInInventory + _ -> setPlayerState (PlayerCreatureTurn creature_ref (WieldMode 0)) dbDispatchAction ["wield",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref -> do tool_ref <- readUID ToolRef tool_uid dbPerformPlayerTurn (Wield tool_ref) creature_ref - done -dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref >> done +dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref -dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref >> done +dbDispatchAction ["fire"] = + dbRequiresPlayerTurnState $ \creature_ref -> rangedAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref FireMode) -dbDispatchAction unrecognized = return ("protocol-error: unrecognized action `" ++ (unwords unrecognized) ++ "`") +dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref -dbSelectPlayerRace :: String -> DB String -dbSelectPlayerRace race_name = case (selectPlayerRace race_name) - of - Nothing -> return ("protocol-error: unrecognized race '" ++ race_name ++ "'") - Just species -> do dbGenerateInitialPlayerCreature species - done +dbDispatchAction ["attack"] = + dbRequiresPlayerTurnState $ \creature_ref -> meleeAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref AttackMode) -dbSelectPlayerClass :: String -> Creature -> DB String +dbDispatchAction ["attack",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Attack $ fromJust $ stringToFacing direction) creature_ref + +dbDispatchAction ["activate"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Activate creature_ref + +dbDispatchAction unrecognized = throwError $ DBError $ ("protocol-error: unrecognized action `" ++ (B.unpack $ B.unwords unrecognized) ++ "`") + +dbSelectPlayerRace :: B.ByteString -> DB () +dbSelectPlayerRace race_name = + case find (\s -> B.map toLower (B.pack $ show s) == race_name) player_species of + Nothing -> throwError $ DBError $ "protocol-error: unrecognized race '" ++ B.unpack race_name ++ "'" + Just species -> generateInitialPlayerCreature species + +dbSelectPlayerClass :: B.ByteString -> Creature -> DB () dbSelectPlayerClass class_name creature = let eligable_base_classes = getEligableBaseCharacterClasses creature - in case find (\x -> (map toLower . show) x == class_name) eligable_base_classes of - Nothing -> return ("protocol-error: unrecognized or invalid class '" ++ class_name ++ "'") - Just the_class -> do dbBeginGame creature the_class - done + in case find (\x -> (B.map toLower . B.pack . show) x == class_name) eligable_base_classes of + Nothing -> throwError $ DBError $ "protocol-error: unrecognized or invalid class '" ++ B.unpack class_name ++ "'" + Just the_class -> dbBeginGame creature the_class -dbRerollRace :: Creature -> DB String +dbRerollRace :: Creature -> DB () dbRerollRace _ = do starting_race <- dbGetStartingRace - dbGenerateInitialPlayerCreature $ fromJust starting_race - done + generateInitialPlayerCreature $ fromJust starting_race -dbQueryPlayerStats :: (DBReadable db) => Creature -> db String +dbQueryPlayerStats :: (DBReadable db) => Creature -> db B.ByteString dbQueryPlayerStats creature = return $ playerStatsTable creature -- | --- Information about player creatures (for which the player should have almost all available information.) +-- Generate a list of tools, e.g. for an inventory list or pickup list. +-- The data source is selected on a context-sensitive basis. -- -playerStatsTable :: Creature -> String -playerStatsTable c = - "begin-table player-stats 0 property value\n" ++ - "str " ++ (show $ str c) ++ "\n" ++ - "dex " ++ (show $ dex c) ++ "\n" ++ - "con " ++ (show $ con c) ++ "\n" ++ - "int " ++ (show $ int c) ++ "\n" ++ - "per " ++ (show $ per c) ++ "\n" ++ - "cha " ++ (show $ cha c) ++ "\n" ++ - "mind " ++ (show $ mind c) ++ "\n" ++ - "hp " ++ (show $ creatureScore HitPoints c) ++ "\n" ++ - "maxhp " ++ (show $ creatureScore MaxHitPoints c) ++ "\n" ++ - "species " ++ (creature_species_name c) ++ "\n" ++ - "random-id " ++ (show $ creature_random_id c) ++ "\n" ++ - "effective-level " ++ (show $ creatureScore EffectiveLevel c) ++ "\n" ++ - "gender " ++ (show $ creatureGender c) ++ "\n" ++ - "end-table" +toolMenuElements :: (DBReadable db) => db [ToolRef] +toolMenuElements = + do state <- playerState + case state of + PlayerCreatureTurn c (PickupMode {}) -> dbAvailablePickups c + PlayerCreatureTurn c (WieldMode {}) -> availableWields c + PlayerCreatureTurn c (MakeMode _ make_prep) | needsChromalite make_prep -> filterM (liftM (isJust . hasChromalite) . dbGetTool) =<< availableWields c + PlayerCreatureTurn c (MakeMode _ make_prep) | needsMaterial make_prep -> filterM (liftM (isJust . hasMaterial) . dbGetTool) =<< availableWields c + PlayerCreatureTurn c (MakeMode _ make_prep) | needsGas make_prep -> filterM (liftM (isJust . hasGas) . dbGetTool) =<< availableWields c + PlayerCreatureTurn c _ -> dbGetContents c + _ -> return [] -- | --- Information about non-player creatures (for which there are very strict limits on what information --- the player can have). The result is in (Property,Value) form so that the result can easily be --- manipulated by the caller. +-- Convert a list of tool menu elements into table row entries. +-- The result entries consist of an index incrementing from zero, ToolRef, and name of the tool. -- -creatureStatsData :: Creature -> [(String,String)] -creatureStatsData c = [("percent-hp",show $ (creatureScore HitPoints c * 100) `div` creatureScore MaxHitPoints c), - ("species",creature_species_name c), - ("random-id",show $ creature_random_id c)] +toolsToMenuTable :: (DBReadable db) => [ToolRef] -> db [(Integer,ToolRef,B.ByteString)] +toolsToMenuTable raw_uids = + do let uids = sortBy (comparing toUID) raw_uids + tool_names <- mapM (liftM toolName . dbGetTool) uids + return $ zip3 [0..] uids tool_names -- | --- Information about non-owned tools. +-- Generate a tool menu table in text form, with the specified name and element list. -- -toolData :: Tool -> [(String,String)] -toolData g@(GunTool {}) = [("tool-type","gun"), - ("tool",toolName g)] +showToolMenuTable :: B.ByteString -> B.ByteString -> [(Integer,ToolRef,B.ByteString)] -> B.ByteString +showToolMenuTable table_name table_id tool_table = + "begin-table " `B.append` table_name `B.append` " " `B.append` table_id `B.append` " n uid name" `B.append` "\n" `B.append` + B.unlines (map (\(n,uid,tool_name) -> B.unwords [B.pack $ show n,B.pack $ show $ toUID uid,tool_name]) tool_table) `B.append` + "end-table" -dbQueryBaseClasses :: (DBReadable db) => Creature -> db String +-- | +-- Information about player creatures (for which the player should have almost all available information.) +-- +playerStatsTable :: Creature -> B.ByteString +playerStatsTable c = + "begin-table player-stats 0 property value\n" `B.append` + "str " `B.append` (B.pack $ show $ rawScore Strength c) `B.append` "\n" `B.append` + "spd " `B.append` (B.pack $ show $ rawScore Speed c) `B.append` "\n" `B.append` + "con " `B.append` (B.pack $ show $ rawScore Constitution c) `B.append` "\n" `B.append` + "int " `B.append` (B.pack $ show $ rawScore Intellect c) `B.append` "\n" `B.append` + "per " `B.append` (B.pack $ show $ rawScore Perception c) `B.append` "\n" `B.append` + "cha " `B.append` (B.pack $ show $ rawScore Charisma c) `B.append` "\n" `B.append` + "mind " `B.append` (B.pack $ show $ rawScore Mindfulness c) `B.append` "\n" `B.append` + "maxhp " `B.append` (B.pack $ show $ creatureAbilityScore ToughnessTrait c) `B.append` "\n" `B.append` + "species " `B.append` (B.pack $ show $ creature_species c) `B.append` "\n" `B.append` + "random-id " `B.append` (B.pack $ show $ creature_random_id c) `B.append` "\n" `B.append` + "gender " `B.append` (B.pack $ show $ creatureGender c) `B.append` "\n" `B.append` + "end-table" + +toolName :: Tool -> B.ByteString +toolName (DeviceTool _ d) = deviceName d +toolName (Sphere s) = prettySubstance s + +toolType :: Tool -> B.ByteString +toolType (DeviceTool Gun _) = "gun" +toolType (DeviceTool Sword _) = "sword" +toolType (Sphere (GasSubstance _)) = "sphere-gas" +toolType (Sphere (MaterialSubstance _)) = "sphere-material" +toolType (Sphere (ChromaliteSubstance _)) = "sphere-chromalite" + +dbQueryBaseClasses :: (DBReadable db) => Creature -> db B.ByteString dbQueryBaseClasses creature = return $ baseClassesTable creature -baseClassesTable :: Creature -> String +baseClassesTable :: Creature -> B.ByteString baseClassesTable creature = - "begin-table base-classes 0 class\n" ++ - (unlines $ map show $ getEligableBaseCharacterClasses creature) ++ + "begin-table base-classes 0 class\n" `B.append` + (B.unlines $ map (B.pack . show) $ getEligableBaseCharacterClasses creature) `B.append` "end-table" -dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db String +dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db B.ByteString dbQueryCenterCoordinates creature_ref = do l <- dbWhere creature_ref case (extractLocation l,extractLocation l :: Maybe Facing) of (Just (Position (x,y)),Nothing) -> - return (begin_table ++ - "x " ++ show x ++ "\n" ++ - "y " ++ show y ++ "\n" ++ + return (begin_table `B.append` + "x " `B.append` B.pack (show x) `B.append` "\n" `B.append` + "y " `B.append` B.pack (show y) `B.append` "\n" `B.append` "end-table") (Just (Position (x,y)),Just face) -> - return (begin_table ++ - "x " ++ show x ++ "\n" ++ - "y " ++ show y ++ "\n" ++ - "facing " ++ show face ++ "\n" ++ + return (begin_table `B.append` + "x " `B.append` B.pack (show x) `B.append` "\n" `B.append` + "y " `B.append` B.pack (show y) `B.append` "\n" `B.append` + "facing " `B.append` B.pack (show face) `B.append` "\n" `B.append` "end-table") - _ -> return (begin_table ++ "end-table") + _ -> return (begin_table `B.append` "end-table") where begin_table = "begin-table center-coordinates 0 axis coordinate\n" -readUID :: (Integer -> Reference a) -> String -> DB (Reference a) +readUID :: (Integer -> Reference a) -> B.ByteString -> DB (Reference a) readUID f x = - do let m_uid = fmap fst $ listToMaybe $ filter (null . snd) $ readDec x + do let m_uid = readNumber x ok <- maybe (return False) (dbVerify . f) m_uid - when (not ok) $ throwError $ DBError $ "protocol-error: " ++ x ++ " is not a valid uid." + when (not ok) $ throwError $ DBError $ "protocol-error: " ++ B.unpack x ++ " is not a valid uid." return $ f $ fromJust m_uid - + +readNumber :: B.ByteString -> Maybe Integer +readNumber = fmap fst . B.readInteger + +readDeviceKind :: B.ByteString -> Maybe DeviceKind +readDeviceKind "pistol" = Just Pistol +readDeviceKind "carbine" = Just Carbine +readDeviceKind "rifle" = Just Rifle +readDeviceKind "fleuret" = Just Fleuret +readDeviceKind "sabre" = Just Sabre +readDeviceKind _ = Nothing diff --git a/src/RNG.hs b/src/RNG.hs --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 +import CreatureAttribute +import Data.Monoid +import TerrainData --- --- Randomly generates a new creature. --- -generateCreatureData :: Species -> DB CreatureGenerationData -generateCreatureData species = do new_stats <- generateStats (averages species) (distributions species) - new_attribs <- generateAttributes (attribute_generator species) - return ( new_stats, new_attribs, (species_name species) ) +player_race_names :: [String] +player_race_names = map (map toLower . show) player_species + +data SpeciesData = SpeciesData { + species_recurring_attributes :: CreatureAttribute, + species_starting_attributes :: [CreatureAttributeGenerator] } + +-- | Give a minimum and maximum ability score, along with a list of special aptitudes that are doubled. +aptitudeBlock :: Integer -> Integer -> [CreatureAptitude] -> CreatureAttributeGenerator +aptitudeBlock minimal maximal special = mconcat $ + map (\a -> attributeMinMax (minimal,maximal) a) [minBound..maxBound :: CreatureAptitude] ++ + map (\a -> attributeMinMax (minimal,maximal) a) special + +-- | Low probability, large magnitude bonuses to aptitude scores. +surpriseAptitudes :: CreatureAttributeGenerator +surpriseAptitudes = mconcat $ map (\a -> attributeChoice 0.05 [attributeMinMax (1,30) a] []) [minBound..maxBound :: CreatureAptitude] + +speciesInfo :: Species -> SpeciesData + +speciesInfo Anachronid = SpeciesData (Speed & Mindfulness & SpotSkill) [ + gender 0.8 + [aptitudeBlock 1 10 [Speed,Mindfulness], + attributeStatic 2 SpotSkill] + [aptitudeBlock 10 25 [Speed,Mindfulness], + attributeStatic 15 SpotSkill, + surpriseAptitudes], + attributeStatic 1 $ FavoredClass Barbarian, + attributeStatic 1 $ FavoredClass Pirate] + +speciesInfo Androsynth = SpeciesData (Strength & Intellect) [ + aptitudeBlock 12 17 [Strength,Intellect], + attributeStatic 1 $ FavoredClass Engineer] + +speciesInfo Ascendant = SpeciesData (Strength & Mindfulness) [ + gender 0.45 [] [], + aptitudeBlock 5 15 [Strength,Mindfulness], + surpriseAptitudes, + attributeStatic 10 JumpSkill, + attributeStatic 1 $ FavoredClass Shepherd, + attributeStatic 1 $ FavoredClass ForceAdept] + +speciesInfo Caduceator = SpeciesData (Strength & Charisma) [ + gender 0.6 [] [], + aptitudeBlock 5 15 [Strength,Charisma], + surpriseAptitudes, + attributeStatic 1 $ FavoredClass Consular] + +speciesInfo Encephalon = SpeciesData (Constitution & Intellect) [ + gender 0.95 [] [], + aptitudeBlock 3 20 [Constitution,Intellect], + attributeStatic 1 $ FavoredClass Engineer] + +speciesInfo Hellion = SpeciesData (Strength & Perception) [ + gender 0.5 [] [], + aptitudeBlock 5 15 [Strength,Perception], + surpriseAptitudes, + attributeStatic 5 $ HideSkill, + attributeStatic 1 $ FavoredClass Scout, + attributeStatic 1 $ FavoredClass Marine, + attributeStatic 1 $ FavoredClass Thief, + attributeStatic 1 $ FavoredClass Pirate] + +speciesInfo Goliath = SpeciesData (Constitution & Perception) [ + gender 0.55 [] [], + aptitudeBlock 3 20 [Constitution,Perception], + surpriseAptitudes, + attributeStatic 4 $ DamageReductionTrait Melee, + attributeStatic 4 $ DamageReductionTrait Ranged, + attributeStatic 4 $ DamageReductionTrait Unarmed, + attributeStatic 1 $ FavoredClass Barbarian, + attributeStatic 1 $ FavoredClass Warrior, + attributeStatic 1 $ FavoredClass Scout] + +speciesInfo Kraken = SpeciesData (Constitution & Charisma) [ + gender 0.5 [] [], + aptitudeBlock 3 20 [Constitution,Charisma], + attributeStatic 1 $ TerrainAffinity Water, + surpriseAptitudes, + attributeStatic 1 $ FavoredClass Consular] + +speciesInfo Myrmidon = SpeciesData (Speed & Intellect) [ + gender 0.0 [] [], + aptitudeBlock 5 15 [Speed,Intellect], + surpriseAptitudes, + attributeStatic 1 $ FavoredClass Barbarian, + attributeStatic 1 $ FavoredClass Engineer, + attributeStatic 1 $ FavoredClass Warrior, + attributeStatic 5 $ AttackSkill Melee, + attributeStatic 5 $ DefenseSkill Melee] + +speciesInfo Perennial = SpeciesData (Constitution & Mindfulness) [ + aptitudeBlock 1 25 [Constitution, Mindfulness], + attributeStatic 1 $ TerrainAffinity Forest, + attributeStatic 1 $ TerrainAffinity DeepForest, + surpriseAptitudes, + attributeStatic 1 $ FavoredClass Barbarian, + attributeStatic 1 $ FavoredClass Engineer, + attributeStatic 1 $ FavoredClass Consular, + attributeStatic 1 $ FavoredClass Shepherd] + +speciesInfo Recreant = SpeciesData (Speed & Perception) [ + aptitudeBlock 2 5 [Speed,Perception], + surpriseAptitudes, surpriseAptitudes, + attributeStatic 5 $ AttackSkill Ranged, + attributeStatic 5 $ DamageSkill Ranged, + attributeStatic 1 $ FavoredClass Marine, + attributeStatic 1 $ FavoredClass Scout] + +speciesInfo Reptilian = SpeciesData (Speed & Charisma) [ + gender 0.35 [] [], + aptitudeBlock 5 15 [Speed,Charisma], + surpriseAptitudes, + attributeStatic 5 $ AttackSkill Unarmed, + attributeStatic 5 $ DefenseSkill Unarmed, + attributeStatic 1 $ FavoredClass Warrior, + attributeStatic 1 $ FavoredClass Consular] + diff --git a/src/SpeciesData.hs b/src/SpeciesData.hs --- 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 --- a/src/Substances.hs +++ b/src/Substances.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE OverloadedStrings #-} module Substances (Gas(..), Material(..), @@ -6,11 +6,16 @@ Solid(..), materialValue, MaterialValue(..), - Substance, + Substance(..), + SubstanceType(toSubstance), + coerceSubstance, + isGas, + isMaterial, + isChromalite, substances, prettySubstance, printSubstances, - gasWeight, + gasValue, chromaliteAlignment, chromalitePotency) where @@ -18,6 +23,8 @@ import Alignment import Data.List import Data.Ord +import Data.Maybe +import qualified Data.ByteString.Char8 as B data Substance = GasSubstance Gas @@ -30,20 +37,21 @@ map MaterialSubstance [minBound..maxBound] ++ map ChromaliteSubstance [minBound..maxBound] -prettySubstance :: Substance -> String -prettySubstance (GasSubstance x) = show x -prettySubstance (MaterialSubstance x) = show x -prettySubstance (ChromaliteSubstance x) = show x +prettySubstance :: Substance -> B.ByteString +prettySubstance (GasSubstance x) = B.pack $ show x +prettySubstance (MaterialSubstance x) = B.pack $ show x +prettySubstance (ChromaliteSubstance x) = B.pack $ show x printSubstances :: IO () -printSubstances = putStrLn $ unlines $ map (\(x,y) -> prettySubstance y ++ ": " ++ show x) $ sortBy (comparing fst) $ map (\x -> (substanceValue x,x)) substances +printSubstances = B.putStrLn $ B.unlines $ map (\(x,y) -> prettySubstance y `B.append` ": " `B.append` B.pack (show x)) $ sortBy (comparing fst) $ map (\x -> (substanceValue x,x)) substances data Solid = MaterialSolid Material | ChromaliteSolid Chromalite deriving (Read,Show,Eq,Ord) data Gas = - Hydrogen + Water + | Hydrogen | Helium | Oxygen | Nitrogen @@ -53,6 +61,9 @@ | Krypton | Xenon | Radon + | Methane + | Ammonia + | Iodine | Chlorine deriving (Eq,Enum,Ord,Show,Read,Bounded) data Material = @@ -76,6 +87,8 @@ | Carbon | Wood | Plastic + | Silicon + | Nickel deriving (Eq,Enum,Ord,Show,Read,Bounded) -- @@ -104,45 +117,51 @@ | Bectonite -- radiant black Chromalite deriving (Eq,Enum,Ord,Show,Read,Bounded) +gasValue :: Gas -> Integer +gasValue Water = 2 +gasValue Hydrogen = 4 +gasValue Helium = 6 +gasValue Nitrogen = 7 +gasValue Oxygen = 10 +gasValue Flourine = 12 +gasValue Neon = 20 +gasValue Ammonia = 21 +gasValue Methane = 24 +gasValue Chlorine = 30 +gasValue Argon = 40 +gasValue Krypton = 42 +gasValue Xenon = 60 +gasValue Radon = 70 +gasValue Iodine = 100 + data MaterialValue = MaterialValue { material_construction_value :: Integer, -- value of material for constructing buildings, pipes, casings for gadgets, etc material_critical_value :: Integer, -- value of material for critical purposes, such as miniature electronic components - material_scarcity :: Integer } -- how rare the material is in nature and by synthesis - -gasWeight :: Gas -> Integer -gasWeight Hydrogen = 1 -gasWeight Helium = 4 -gasWeight Oxygen = 16 -gasWeight Nitrogen = 14 -gasWeight Flourine = 19 -gasWeight Neon = 20 -gasWeight Argon = 40 -gasWeight Krypton = 84 -gasWeight Xenon = 131 -gasWeight Radon = 222 -gasWeight Chlorine = 35 + material_scarcity :: Integer } -- scarcity of material materialValue :: Material -> MaterialValue -materialValue Aluminum = MaterialValue 10 10 10 -materialValue Titanium = MaterialValue 15 10 20 -materialValue Palladium = MaterialValue 2 150 5 -materialValue Molybdenum = MaterialValue 1 50 3 -materialValue Lead = MaterialValue 3 20 2 -materialValue Copper = MaterialValue 8 80 15 -materialValue Iron = MaterialValue 5 10 2 -materialValue Cobalt = MaterialValue 3 60 7 -materialValue Zirconium = MaterialValue 2 40 10 -materialValue Gold = MaterialValue 4 20 50 -materialValue Silver = MaterialValue 3 30 20 -materialValue Platinum = MaterialValue 1 100 70 -materialValue Zinc = MaterialValue 6 50 4 -materialValue Uranium = MaterialValue 1 300 40 -materialValue Plutonium = MaterialValue 1 500 100 -materialValue Thorium = MaterialValue 2 200 4 -materialValue Diamond = MaterialValue 40 20 15 -materialValue Carbon = MaterialValue 2 20 1 -materialValue Wood = MaterialValue 3 0 2 -materialValue Plastic = MaterialValue 4 0 2 +materialValue Aluminum = MaterialValue 50 20 6 +materialValue Titanium = MaterialValue 70 15 15 +materialValue Palladium = MaterialValue 30 30 65 +materialValue Molybdenum = MaterialValue 18 55 40 +materialValue Lead = MaterialValue 15 7 31 +materialValue Copper = MaterialValue 40 40 18 +materialValue Iron = MaterialValue 25 15 10 +materialValue Cobalt = MaterialValue 30 35 30 +materialValue Zirconium = MaterialValue 12 50 23 +materialValue Gold = MaterialValue 20 35 83 +materialValue Silver = MaterialValue 10 20 80 +materialValue Platinum = MaterialValue 22 40 81 +materialValue Zinc = MaterialValue 35 25 26 +materialValue Uranium = MaterialValue 5 90 37 +materialValue Plutonium = MaterialValue 1 100 100 +materialValue Thorium = MaterialValue 20 80 33 +materialValue Diamond = MaterialValue 100 100 90 +materialValue Carbon = MaterialValue 60 20 20 +materialValue Wood = MaterialValue 25 1 3 +materialValue Plastic = MaterialValue 30 10 1 +materialValue Silicon = MaterialValue 25 50 5 +materialValue Nickel = MaterialValue 25 45 25 chromaliteAlignment :: Chromalite -> Alignment chromaliteAlignment Rutilium = (Chaotic,Strategic) @@ -163,32 +182,53 @@ chromaliteAlignment Bectonite = (Evil,Indifferent) class SubstanceType a where - substanceValue :: a -> Integer toSubstance :: a -> Substance + fromSubstance :: Substance -> Maybe a +coerceSubstance :: (SubstanceType a,SubstanceType b) => a -> Maybe b +coerceSubstance = fromSubstance . toSubstance + +isGas :: (SubstanceType a) => a -> Bool +isGas = isJust . (`asTypeOf` (undefined :: Maybe Gas)) . coerceSubstance + +isMaterial :: (SubstanceType a) => a -> Bool +isMaterial = isJust . (`asTypeOf` (undefined :: Maybe Material)) . coerceSubstance + +isChromalite :: (SubstanceType a) => a -> Bool +isChromalite = isJust . (`asTypeOf` (undefined :: Maybe Chromalite)) . coerceSubstance + +substanceValue :: (SubstanceType a) => a -> Integer +substanceValue a = case toSubstance a of + GasSubstance x -> gasValue x + 10 + MaterialSubstance x -> (nom + crit) * scarce + where MaterialValue nom crit scarce = materialValue x + ChromaliteSubstance x -> 1000 + 2 * chromalitePotency x ^ 2 + instance SubstanceType Gas where - substanceValue x = gasWeight x ^ 2 - gasWeight x toSubstance x = GasSubstance x + fromSubstance (GasSubstance x) = Just x + fromSubstance _ = Nothing instance SubstanceType Material where - substanceValue x = nom * crit * scarce + nom + crit + scarce - where MaterialValue nom crit scarce = materialValue x toSubstance x = MaterialSubstance x + fromSubstance (MaterialSubstance x) = Just x + fromSubstance _ = Nothing instance SubstanceType Chromalite where - substanceValue x = 10 * chromalitePotency x ^ 2 + 100 * chromalitePotency x toSubstance x = ChromaliteSubstance x + fromSubstance (ChromaliteSubstance x) = Just x + fromSubstance _ = Nothing instance SubstanceType Substance where - substanceValue (GasSubstance x) = substanceValue x - substanceValue (MaterialSubstance x) = substanceValue x - substanceValue (ChromaliteSubstance x) = substanceValue x toSubstance x = x + fromSubstance = Just instance SubstanceType Solid where - substanceValue = substanceValue . toSubstance toSubstance (MaterialSolid x) = toSubstance x toSubstance (ChromaliteSolid x) = toSubstance x + fromSubstance (MaterialSubstance x) = Just $ MaterialSolid x + fromSubstance (ChromaliteSubstance x) = Just $ ChromaliteSolid x + fromSubstance _ = Nothing chromalitePotency :: Chromalite -> Integer chromalitePotency = alignmentPotency . chromaliteAlignment diff --git a/src/Terrain.hs b/src/Terrain.hs deleted file mode 100644 --- 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 --- 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 @@ deriving (Read,Show,Eq,Ord,Enum,Bounded) -- | --- All static terrain elements are members of TerrainMap +-- All static terrain elements are members of TerrainGrid -- -- The only difference between "Deasert" and "Sand" is that where -- "Deasert" and "Water" touch, the map generator will produce @@ -43,7 +44,7 @@ -- data TerrainPatch = RockFace | Rubble - | Ore Solid + | Ore | RockyGround | Dirt | Grass @@ -71,7 +72,7 @@ placement_seed :: Integer } deriving (Read,Show) -placeTerrain :: TerrainPlacement -> TerrainMap -> TerrainMap +placeTerrain :: TerrainPlacement -> TerrainGrid -> TerrainGrid placeTerrain terrain_placement = arbitraryReplaceGrid (placement_sources terrain_placement) (placement_replacements terrain_placement) @@ -97,8 +98,15 @@ -- or for constructing buildings. -- difficult_terrains :: [TerrainPatch] -difficult_terrains = [RockFace,Forest,DeepForest,Water,DeepWater,Ice,Lava,RecreantFactory] +difficult_terrains = impassable_terrains ++ + [Water,DeepWater,Ice,Lava,RecreantFactory] +-- | +-- A list of TerrainPatches that are considered "impassable" for traveling. +-- +impassable_terrains :: [TerrainPatch] +impassable_terrains = [RockFace,Forest,DeepForest] + terrainFrequencies :: Biome -> [(Integer,TerrainPatch)] terrainFrequencies RockBiome = [(15,RockFace),(15,Rubble),(55,RockyGround),(15,Sand)] terrainFrequencies IcyRockBiome = [(10,RockFace),(10,Rubble),(20,RockyGround),(60,Ice)] @@ -144,7 +152,7 @@ interps = List.map terrainInterpFn terrain_patch_pairs in fromList (zip terrain_patch_pairs interps) -type TerrainMap = Grid TerrainPatch +type TerrainGrid = Grid TerrainPatch -- | -- Generates a random terrain map. The Biome indicates determines what TerrainPatches @@ -152,7 +160,7 @@ -- generated terrain. Finally, a random Integer stream is needed to provide the random data -- to generate the terrain. -- -generateTerrain :: TerrainGenerationData -> [Integer] -> TerrainMap +generateTerrain :: TerrainGenerationData -> [Integer] -> TerrainGrid generateTerrain tg rands = flip (foldr placeTerrain) (tg_placements tg) $ generateGrid (terrainFrequencies (tg_biome tg)) terrainInterpMap @@ -162,7 +170,7 @@ terrainPatchToASCII :: TerrainPatch -> Char terrainPatchToASCII RockFace = '#' terrainPatchToASCII Rubble = '*' -terrainPatchToASCII (Ore _) = '$' +terrainPatchToASCII Ore = '$' terrainPatchToASCII RockyGround = ':' terrainPatchToASCII Dirt = '.' terrainPatchToASCII Grass = ',' @@ -183,10 +191,10 @@ tg_biome = ForestBiome, tg_placements = [] } -generateExampleTerrain :: Integer -> TerrainMap -generateExampleTerrain seed = generateTerrain exampleTerrainGenerator (randomIntegerStream seed) +generateExampleTerrain :: Integer -> TerrainGrid +generateExampleTerrain seed = generateTerrain exampleTerrainGenerator (randoms $ mkRNG seed) -prettyPrintTerrain :: ((Integer,Integer),(Integer,Integer)) -> TerrainMap -> [String] +prettyPrintTerrain :: ((Integer,Integer),(Integer,Integer)) -> TerrainGrid -> [String] prettyPrintTerrain ((left_bound,right_bound),(top_bound,bottom_bound)) terrain_map = [[terrainPatchToASCII $ gridAt terrain_map (x,y) | x <- [left_bound..right_bound]] diff --git a/src/Tool.hs b/src/Tool.hs --- 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 @@ 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 --- 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 Tool = DeviceTool DeviceFunction Device + | Sphere Substance + deriving (Read,Show,Eq) -data GunSize = Pistol - | Carbine - | Rifle - | Cannon - | Launcher - deriving (Read,Show,Eq) +-- | Get the substance type of a material sphere, if it is one. +fromSphere :: Tool -> Maybe Substance +fromSphere (Sphere s) = Just s +fromSphere _ = Nothing -data Gun = Gun { - gun_name :: String, - gun_power_cell :: Chromalite, - gun_substrate :: Material, - gun_casing :: Material, - gun_medium :: Gas, - gun_size :: GunSize } +sphere :: (SubstanceType a) => a -> Tool +sphere = Sphere . toSubstance + +data DeviceFunction = Gun | Sword + deriving (Read,Show,Eq) + +data DeviceKind = + Pistol + | Carbine + | Rifle + | Fleuret + | Sabre + deriving (Read,Show,Eq) + +kindToFunction :: DeviceKind -> (DeviceFunction,Integer) +kindToFunction Pistol = (Gun,1) +kindToFunction Carbine = (Gun,3) +kindToFunction Rifle = (Gun,5) +kindToFunction Fleuret = (Sword,2) +kindToFunction Sabre = (Sword,4) + +-- | Any kind of device that is constructed from a power cell, materal, and gas medium, +-- using the various device rules to determine it's power. +data Device = Device { + device_name :: B.ByteString, + device_chromalite :: Chromalite, + device_material :: Material, + device_gas :: Gas, + device_size :: Integer } deriving (Eq,Read,Show) +-- | Anything that operates like a device, but isn't. For example, an unarmed attack. +data PseudoDevice = PseudoDevice { + pdevice_accuracy :: Integer, + pdevice_output :: Integer, + pdevice_speed :: Integer, + pdevice_size :: Integer } + +class DeviceType d where + toPseudoDevice :: d -> PseudoDevice + +instance DeviceType Device where + toPseudoDevice d = let chromalite = chromalitePotency $ device_chromalite d + gas = gasValue $ device_gas d + material = material_critical_value $ materialValue $ device_material d + size = device_size d + in PseudoDevice { + pdevice_accuracy = min chromalite material + chromalite, + pdevice_output = min chromalite gas + chromalite, + pdevice_speed = gas + material, + pdevice_size = size } + +instance DeviceType PseudoDevice where + toPseudoDevice = id + +device :: B.ByteString -> DeviceKind -> Chromalite -> Material -> Gas -> Tool +device s dk c m g = DeviceTool func (Device s c m g size) + where (func,size) = kindToFunction dk + +improvised :: DeviceKind -> Chromalite -> Material -> Gas -> Tool +improvised dk c m g = device ("improvised_" `B.append` B.pack (show dk)) dk c m g + phase_pistol :: Tool -phase_pistol = GunTool $ Gun "phase_pistol" Pteulanium Palladium Zinc Argon Pistol +phase_pistol = device "phase_pistol" Pistol Caerulite Zinc Flourine -gunEnergyOutput :: Gun -> Integer -gunEnergyOutput g = gunSizeClass g * (chromalitePotency $ gun_power_cell g) +phaser :: Tool +phaser = device "phaser" Carbine Caerulite Zinc Flourine -gunThroughput :: Gun -> Integer -gunThroughput g = ((material_critical_value $ materialValue $ gun_substrate g) + 1) * - (gasWeight $ gun_medium g) +phase_rifle :: Tool +phase_rifle = device "phase_rifle" Rifle Caerulite Zinc Flourine -gunEndurance :: Gun -> Integer -gunEndurance g = 10 * (material_construction_value $ materialValue $ gun_casing g)^2 +kinetic_fleuret :: Tool +kinetic_fleuret = device "kinetic_fleuret" Fleuret Ionidium Aluminum Nitrogen -gunSizeClass :: Gun -> Integer -gunSizeClass (Gun { gun_size = Pistol }) = 1 -gunSizeClass (Gun { gun_size = Carbine}) = 3 -gunSizeClass (Gun { gun_size = Rifle}) = 4 -gunSizeClass (Gun { gun_size = Cannon}) = 7 -gunSizeClass (Gun { gun_size = Launcher}) = 10 +kinetic_sabre :: Tool +kinetic_sabre = device "kinetic_sabre" Sabre Ionidium Aluminum Nitrogen -toolName :: Tool -> String -toolName (GunTool (Gun { gun_name = s })) = s +deviceName :: Device -> B.ByteString +deviceName = device_name + +deviceDurability :: Device -> Integer +deviceDurability d = device_size d * (material_construction_value $ materialValue $ device_material d) + +deviceOutput :: (DeviceType d) => d -> Integer +deviceOutput = pdevice_output . toPseudoDevice + +deviceAccuracy :: (DeviceType d) => d -> Integer +deviceAccuracy = pdevice_accuracy . toPseudoDevice + +deviceSpeed :: (DeviceType d) => d -> Integer +deviceSpeed = pdevice_speed . toPseudoDevice + +deviceSize :: (DeviceType d) => d -> Integer +deviceSize = pdevice_size . toPseudoDevice + +deviceChromalite :: Device -> Chromalite +deviceChromalite = device_chromalite + +deviceMaterial :: Device -> Material +deviceMaterial = device_material + +deviceGas :: Device -> Gas +deviceGas = device_gas diff --git a/src/Town.hs b/src/Town.hs new file mode 100644 --- /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 --- 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 ()) @@ -27,4 +35,43 @@ turnCreature :: (DBReadable db) => Facing -> Location m CreatureRef () -> db (Location m CreatureRef ()) turnCreature face = walkCreature face (0,0) + +------------------------------------------------------------------------------------------------------------- +-- Teleportation/Jumping +------------------------------------------------------------------------------------------------------------- + +-- | +-- Try to teleport the creature to the specified Position. The teleport attempt can be automatically retried a number of times, and the most accurate attempt will be used. +-- If the retries are negative, the teleport will be made artificially innacurate. +-- +randomTeleportLanding :: (DBReadable db) => Integer -> PlaneRef -> Position -> Position -> db Position +randomTeleportLanding retries plane_ref source_destination goal_destination = + do landings <- replicateM (fromInteger $ max 1 retries) $ (pickRandomClearSite 3) 0 0 goal_destination (not . (`elem` impassable_terrains)) plane_ref + return $ minimumBy (comparing $ \p -> distanceBetweenSquared goal_destination p ^ 2 * distanceBetweenSquared source_destination p) landings + +data TeleportJumpOutcome = + TeleportJumpGood CreatureRef Standing + | TeleportJumpFailed + +-- | +-- Teleport jump a creature about 7 units in the specified direction. +-- +resolveTeleportJump :: (DBReadable db) => CreatureRef -> Facing -> db TeleportJumpOutcome +resolveTeleportJump creature_ref face = liftM (fromMaybe TeleportJumpFailed) $ runMaybeT $ + do start_location <- lift $ dbWhere creature_ref + jump_roll <- liftM roll_log $ lift $ rollCreatureAbilityScore JumpSkill 0 (entity start_location) + standing_location <- MaybeT $ return $ extractLocation start_location + landing_position <- lift $ randomTeleportLanding jump_roll (standing_plane standing_location) (standing_position standing_location) $ + offsetPosition (facingToRelative7 face) $ standing_position standing_location + case () of + () | jump_roll <= 0 -> return TeleportJumpFailed + () | otherwise -> return $ TeleportJumpGood (entity start_location) $ standing_location { standing_position = landing_position, standing_facing = face } + +-- | Execute a resolved teleport jump. +executeTeleportJump :: TeleportJumpOutcome -> DB () +executeTeleportJump TeleportJumpFailed = return () +executeTeleportJump (TeleportJumpGood creature_ref standing_location) = + do _ <- dbMove (return . toStanding standing_location) creature_ref + dbPushSnapshot $ TeleportEvent creature_ref + return () diff --git a/src/Turns.hs b/src/Turns.hs --- 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 @@ import Control.Monad.Maybe import Control.Monad.Trans import DB -import DBData import FactionData -import Races +import SpeciesData import Plane import Control.Monad import Creature import Data.Ratio import Facing -import Dice import TerrainData import Data.Maybe import Behavior import qualified Perception as P import Position +import PlayerState dbPerformPlayerTurn :: Behavior -> CreatureRef -> DB () dbPerformPlayerTurn beh creature_ref = @@ -36,7 +35,8 @@ dbFinishPlanarAITurns :: PlaneRef -> DB () dbFinishPlanarAITurns plane_ref = - do (all_creatures_on_plane :: [CreatureRef]) <- dbGetContents plane_ref + do sweepDead plane_ref + (all_creatures_on_plane :: [CreatureRef]) <- dbGetContents plane_ref any_players_left <- liftM (any (== Player)) $ mapM getCreatureFaction all_creatures_on_plane next_turn <- dbNextTurn $ map generalizeReference all_creatures_on_plane ++ [generalizeReference plane_ref] case next_turn of @@ -55,25 +55,35 @@ return () _ -> error "dbFinishPlanarAITurns: impossible case" +planar_turn_frequency :: Integer +planar_turn_frequency = 100 + dbPerform1PlanarAITurn :: PlaneRef -> DB () dbPerform1PlanarAITurn plane_ref = do creature_locations <- dbGetContents plane_ref player_locations <- filterRO (liftM (== Player) . getCreatureFaction . entity) creature_locations native_locations <- filterRO (liftM (/= Player) . getCreatureFaction . entity) creature_locations - when (length native_locations < length player_locations * 2) $ - do p <- roll $ map location player_locations - spawn_position <- pickRandomClearSite 5 0 0 p (== RecreantFactory) plane_ref - dbNewCreature Pirates recreant (Standing plane_ref spawn_position Here) - return () - dbAdvanceTime (1%100) plane_ref + should_randomly_generate_monster <- liftM (<= 10) $ linearRoll planar_turn_frequency + when (length native_locations < length player_locations * 2 && should_randomly_generate_monster) $ + do p <- pickM $ map location player_locations + m_spawn_position <- pickRandomClearSite_withTimeout (Just 2) 7 0 0 p (== RecreantFactory) plane_ref + maybe (return () ) + (\spawn_position -> newCreature Pirates Recreant (Standing plane_ref spawn_position Here) >> return ()) $ + m_spawn_position + dbAdvanceTime plane_ref (1%planar_turn_frequency) dbPerform1CreatureAITurn :: CreatureRef -> DB () dbPerform1CreatureAITurn creature_ref = atomic $ liftM (flip dbBehave creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $ - do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects - my_position <- lift P.myPosition + do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects (return . const True) + (rand_x :: Integer) <- lift $ getRandomR (1,100) + rand_face <- lift $ pickM [minBound..maxBound] + (_,my_position) <- lift P.whereAmI let face_to_player = faceAt my_position (location player) return $ case distanceBetweenChessboard my_position (location player) of - 1 -> Attack $ face_to_player - _ -> Step $ face_to_player + _ | rand_x < 5 -> Wait -- if AI gets stuck, this will make sure they waste time so the game doesn't hang + _ | rand_x < 20 -> Step rand_face + 1 -> Attack face_to_player + -- x | x >= 10 -> Jump face_to_player -- disable this until we can handle non-player teleporting sanely + _ -> Step face_to_player