Skip to content
Browse files

Various changes to gameplay and UI for 0.8.

  • Loading branch information...
1 parent 9195ff6 commit 392d2409ceaaadefb0daecfbd4b012fe7bd7d92c @clanehin committed
Showing with 556 additions and 673 deletions.
  1. +0 −66 Roguestar/Lib/AttributeGeneration.hs
  2. +16 −39 Roguestar/Lib/BeginGame.hs
  3. +19 −34 Roguestar/Lib/Behavior.hs
  4. +1 −1 Roguestar/Lib/Behavior/Travel.hs
  5. +5 −11 Roguestar/Lib/Building.hs
  6. +9 −2 Roguestar/Lib/BuildingData.hs
  7. +3 −4 Roguestar/Lib/Character.hs
  8. +4 −4 Roguestar/Lib/CharacterAdvancement.hs
  9. +19 −9 Roguestar/Lib/Creature.hs
  10. +0 −51 Roguestar/Lib/CreatureAttribute.hs
  11. +35 −79 Roguestar/Lib/CreatureData.hs
  12. +2 −1 Roguestar/Lib/DB.hs
  13. +0 −1 Roguestar/Lib/FactionData.hs
  14. +1 −1 Roguestar/Lib/GridRayCaster.hs
  15. +28 −13 Roguestar/Lib/Grids.hs
  16. +14 −6 Roguestar/Lib/Logging.hs
  17. +0 −79 Roguestar/Lib/Main.hs
  18. +7 −7 Roguestar/Lib/Perception.hs
  19. +9 −9 Roguestar/Lib/PlaneVisibility.hs
  20. +7 −3 Roguestar/Lib/PlayerState.hs
  21. +90 −10 Roguestar/Lib/Roguestar.hs
  22. +3 −87 Roguestar/Lib/Species.hs
  23. +3 −14 Roguestar/Lib/SpeciesData.hs
  24. +34 −65 Roguestar/Lib/TerrainData.hs
  25. +1 −1 Roguestar/Lib/Town.hs
  26. +10 −10 Roguestar/Lib/Turns.hs
  27. +76 −47 Roguestar/Server/Main.hs
  28. +0 −1 feedback/1b6f660f-70e0-4781-a10b-1033c2c23323
  29. +1 −0 feedback/37b314aa-7182-439e-915e-65ae52cdd943
  30. +5 −6 roguestar.cabal
  31. +2 −2 snaplets/heist/templates/contribute.tpl
  32. +26 −0 snaplets/heist/templates/help-actions.tpl
  33. +43 −0 snaplets/heist/templates/help-map.tpl
  34. +3 −2 snaplets/heist/templates/help.tpl
  35. +1 −0 snaplets/heist/templates/hidden/context.tpl
  36. +13 −0 snaplets/heist/templates/hidden/options.tpl
  37. +5 −1 snaplets/heist/templates/hidden/play/{game-over.tpl → failure.tpl}
  38. +4 −1 snaplets/heist/templates/hidden/play/normal.tpl
  39. +17 −0 snaplets/heist/templates/hidden/play/success.tpl
  40. +10 −0 snaplets/heist/templates/hidden/start.tpl
  41. +1 −1 snaplets/heist/templates/index.tpl
  42. +2 −2 static/encyclopedia/species/recreant.txt
  43. +27 −3 static/roguebasic.css
View
66 Roguestar/Lib/AttributeGeneration.hs
@@ -1,66 +0,0 @@
--- | 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 Roguestar.Lib.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
View
55 Roguestar/Lib/BeginGame.hs
@@ -20,43 +20,24 @@ import Roguestar.Lib.Town
import Roguestar.Lib.PlanetData
import Roguestar.Lib.Planet
import qualified Data.ByteString.Char8 as B ()
+import Control.Monad.Random
-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
-homeBiome DustVortex = DesertBiome
+homeBiome :: Species -> [Biome]
+homeBiome RedRecreant = [ForestBiome,TundraBiome,MountainBiome]
+homeBiome BlueRecreant = [ForestBiome,TundraBiome,MountainBiome]
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]
-startingEquipmentBySpecies DustVortex = [sphere Aluminum, sphere Nitrogen]
+startingEquipmentBySpecies RedRecreant = []
+startingEquipmentBySpecies BlueRecreant = []
dbCreateStartingPlane :: Creature -> DB PlaneRef
dbCreateStartingPlane creature =
- do dbNewPlane "belhaven" (TerrainGenerationData {
- tg_smootheness = 3,
- tg_biome = homeBiome $ creature_species creature,
- tg_placements = [] }) TheUniverse
+ do seed <- getRandom
+ biome <- pickM $ homeBiome (creature_species creature)
+ dbNewPlane "belhaven" (TerrainGenerationData {
+ tg_smootheness = 2,
+ tg_biome = biome,
+ tg_placements = [recreantFactories seed] }) TheUniverse
-- |
-- Begins the game with the specified starting player creature.
@@ -71,15 +52,11 @@ beginGame =
landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
creature_ref <- dbAddCreature creature (Standing plane_ref landing_site Here)
setPlayerCreature creature_ref
- _ <- createTown plane_ref [basic_stargate,monolith]
+ _ <- createTown plane_ref [basic_stargate]
let starting_equip = startingEquipmentBySpecies (creature_species creature)
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)
- (_,end_of_nonaligned_first_series) <- makePlanets (Subsequent plane_ref NonAlignedRegion) =<< generatePlanetInfo nonaligned_first_series_planets
- _ <- makePlanets (Subsequent end_of_nonaligned_first_series NonAlignedRegion) =<< generatePlanetInfo nonaligned_second_series_planets
- _ <- makePlanets (Subsequent end_of_nonaligned_first_series CyborgRegion) =<< generatePlanetInfo cyborg_planets
+ -- (_,end_of_nonaligned_first_series) <- makePlanets (Subsequent plane_ref NonAlignedRegion) =<< generatePlanetInfo nonaligned_first_series_planets
+ -- _ <- makePlanets (Subsequent end_of_nonaligned_first_series NonAlignedRegion) =<< generatePlanetInfo nonaligned_second_series_planets
+ -- _ <- makePlanets (Subsequent end_of_nonaligned_first_series CyborgRegion) =<< generatePlanetInfo cyborg_planets
setPlayerState $ PlayerCreatureTurn creature_ref
View
53 Roguestar/Lib/Behavior.hs
@@ -94,16 +94,16 @@ dbBehave_ (Step face) creature_ref =
dbBehave_ StepDown creature_ref =
do _ <- atomic executeClimb $ resolveClimb creature_ref ClimbDown
-- FIXME: should be conditional
- dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+ dbAdvanceTime creature_ref =<< move2ActionTime creature_ref
dbBehave_ StepUp creature_ref =
do _ <- atomic executeClimb $ resolveClimb creature_ref ClimbUp
-- FIXME: should be conditional
- dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+ dbAdvanceTime creature_ref =<< move2ActionTime creature_ref
dbBehave_ (Jump face) creature_ref =
do _ <- atomic executeTeleportJump $ resolveTeleportJump creature_ref face
- dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+ dbAdvanceTime creature_ref =<< move2ActionTime creature_ref
dbBehave_ (TurnInPlace face) creature_ref =
do _ <- move creature_ref =<< turnCreature face creature_ref
@@ -146,7 +146,7 @@ dbBehave_ (Attack face) creature_ref =
do _ <- move creature_ref =<< turnCreature face creature_ref
melee_attack_model <- meleeAttackModel creature_ref
_ <- atomic executeAttack $ resolveAttack melee_attack_model face
- dbAdvanceTime creature_ref =<< move1ActionTime creature_ref
+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref
return ()
dbBehave_ Wait creature_ref = dbAdvanceTime creature_ref =<< quickActionTime creature_ref
@@ -168,60 +168,45 @@ dbBehave_ Activate creature_ref =
dbBehave_ (Make make_prep) creature_ref =
do _ <- atomic executeMake $ resolveMake creature_ref make_prep
- dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref
return ()
dbBehave_ (ClearTerrain face) creature_ref =
do _ <- move creature_ref =<< turnCreature face creature_ref
ok <- modifyFacingTerrain clearTerrain face creature_ref
when (not ok) $ throwError $ DBErrorFlag Unable
- dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+ dbAdvanceTime creature_ref =<< quickActionTime creature_ref
return ()
dbBehave_ (ActivateBuilding face) creature_ref =
do _ <- move creature_ref =<< turnCreature face creature_ref
ok <- activateFacingBuilding face creature_ref
when (not ok) $ throwError $ DBErrorFlag Unable
- dbAdvanceTime creature_ref =<< fullActionTime creature_ref
+ dbAdvanceTime creature_ref =<< quickActionTime 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 . filterLocations (\(Child tool_ref :: Child Tool) -> True)) $ getContents 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 <- liftM creature_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)
+getBaseSpeed :: (DBReadable db) => CreatureRef -> db Integer
+getBaseSpeed creature_ref =
+ do c <- dbGetCreature creature_ref
+ let raw_speed = rawScore Speed c
+ when (raw_speed <= 0) $ error $ "getBaseSpeed: Non-positive raw speed (" ++ show c ++ ")"
+ return raw_speed
-- | 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)
+quickActionTime creature_ref =
+ do raw_speed <- getBaseSpeed creature_ref
+ return $ 50 % (100 + raw_speed `div` 2)
-- | 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)
+move1ActionTime creature_ref =
+ do raw_speed <- getBaseSpeed creature_ref
+ return $ 100 % (100+raw_speed)
-- | 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
View
2 Roguestar/Lib/Behavior/Travel.hs
@@ -46,7 +46,7 @@ walkCreature face (x',y') creature_ref =
(standing_position standing)
case () of
() | not is_passable ->
- do logDB log_travel WARNING $ "Terrain not passable."
+ do logDB log_travel INFO $ "Terrain not passable."
return $ detail l
() | otherwise ->
return $ standing
View
16 Roguestar/Lib/Building.hs
@@ -24,6 +24,7 @@ import Control.Monad.Error
import Roguestar.Lib.PowerUpData
import Roguestar.Lib.CharacterAdvancement
import Roguestar.Lib.DetailedLocation
+import Roguestar.Lib.PlayerState
-- | The total occupied surface area of a building.
buildingSize :: (DBReadable db) => BuildingRef -> db Integer
@@ -60,18 +61,11 @@ activateBuilding (PowerUp pud) creature_ref building_ref =
do captureNode pud creature_ref building_ref
return True
activateBuilding (TwoWayStargate region) creature_ref building_ref =
- do (Parent plane_ref :: Parent Plane,Position (bx,by))
- <- liftM detail $ getPlanarLocation building_ref
- (Position (cx,cy)) <- liftM detail $ getPlanarLocation creature_ref
+ do (Parent plane_ref :: Parent Plane,building_position :: Position) <- liftM detail $ getPlanarLocation building_ref
+ (creature_position :: Position) <- liftM detail $ getPlanarLocation creature_ref
case () of
- () | cy - by == (-1) ->
- do subsequent_plane <- maybe (throwError $ DBErrorFlag NoStargateAddress) return
- =<< getSubsequent region plane_ref
- portalCreatureTo (Just $ TwoWayStargate region) 1 creature_ref subsequent_plane
- () | cy - by == 1 ->
- do previous_plane <- maybe (throwError $ DBErrorFlag NoStargateAddress) (return . asParent)
- =<< liftM fromLocation (whereIs plane_ref)
- portalCreatureTo (Just $ TwoWayStargate region) (-1) creature_ref previous_plane
+ () | distanceBetweenChessboard creature_position building_position == 1 ->
+ do setPlayerState $ GameOver PlayerIsVictorious
() | otherwise ->
do throwError $ DBErrorFlag BuildingApproachWrongAngle
return True
View
11 Roguestar/Lib/BuildingData.hs
@@ -37,8 +37,15 @@ buildingOccupies :: BuildingShape -> [(Integer,Integer)]
-- Monolith/Node: X
buildingOccupies Monolith = [(0,0)]
buildingOccupies Anchor = [(0,0)]
--- Portal: XXX
-buildingOccupies Portal = [(0,0),(-1,0),(1,0)]
+-- Portal:
+--
+-- XXX
+-- X X
+-- X X X
+-- X X
+-- XXX
+--
+buildingOccupies Portal = [(0,0),(3,0),(3,1),(3,-1),(-3,0),(-3,1),(-3,-1),(0,3),(-1,3),(1,3),(0,-3),(-1,-3),(1,-3)]
-- Cybergate: XXX
-- XX XX
-- XX XX
View
7 Roguestar/Lib/Character.hs
@@ -4,15 +4,14 @@ module Roguestar.Lib.Character
where
import Roguestar.Lib.Alignment
-import Roguestar.Lib.CreatureAttribute
import Roguestar.Lib.CreatureData
import Roguestar.Lib.TerrainData
import Roguestar.Lib.PersistantData
applyCharacterClass :: CharacterClass -> Creature -> Creature
-applyCharacterClass character_class creature = applyToCreature (character_class & classInfo character_class) creature
+applyCharacterClass character_class creature = applyToCreature (CharacterClass character_class : classInfo character_class) creature
-classInfo :: CharacterClass -> CreatureAttribute
+classInfo :: CharacterClass -> [CreatureTrait]
-------------------------------------------------------------------------------
--
@@ -22,5 +21,5 @@ classInfo :: CharacterClass -> CreatureAttribute
--
-------------------------------------------------------------------------------
-classInfo StarChild = Mindfulness & Intellect & Perception
+classInfo StarChild = [Aggression,Perception]
View
8 Roguestar/Lib/CharacterAdvancement.hs
@@ -27,7 +27,7 @@ data CharacterBumpResult =
--
bumpCharacter :: PowerUpData -> Creature -> CharacterBumpResult
bumpCharacter (ForceCharacter character_class) c =
- if character_class `elem` Map.keys (creature_levels c)
+ if CharacterClass character_class `elem` Map.keys (creature_traits c)
then bumpCharacter (AwardCharacter $ characterFitness new_character - characterFitness c) c
else CharacterForced {
character_new_character_class = character_class,
@@ -43,7 +43,7 @@ bumpCharacter (AwardCharacter n) c =
character_new = c { creature_points = bumped_score } }
where bumped_score = creature_points c + n
fitness_gain = characterFitness new_character - characterFitness c
- new_character = applyToCreature (Map.keys $ creature_levels c) c
+ new_character = applyToCreature (Map.keys $ creature_traits c) c
newCharacterClass :: CharacterBumpResult -> Maybe CharacterClass
newCharacterClass (CharacterForced character_class _) = Just character_class
@@ -60,11 +60,11 @@ newCharacterLevel _ = Nothing
-- measure of Character power.
--
characterLevel :: Creature -> Integer
-characterLevel = maximum . Map.elems . creature_levels
+characterLevel = maximum . Map.elems . creature_traits
-- |
-- Answers the estimated fitness (powerfulness) of the Character.
--
characterFitness :: Creature -> Integer
-characterFitness c = sum $ (Map.elems $ creature_aptitude c) ++ (Map.elems $ creature_ability c)
+characterFitness c = sum $ (Map.elems $ creature_traits c)
View
28 Roguestar/Lib/Creature.hs
@@ -23,8 +23,8 @@ import Roguestar.Lib.SpeciesData
import Roguestar.Lib.Species
import Roguestar.Lib.FactionData
import Control.Monad.Error
+import Control.Monad.Random
import Roguestar.Lib.Tool
-import Roguestar.Lib.CreatureAttribute
import Data.Monoid
import Data.Ratio
import Roguestar.Lib.Facing
@@ -32,12 +32,18 @@ import Roguestar.Lib.Position
import Roguestar.Lib.Plane
import Roguestar.Lib.PlayerState
import Roguestar.Lib.DetailedLocation
+import Roguestar.Lib.Logging
-- |
-- Generates a new Creature from the specified species.
--
generateCreature :: Faction -> Species -> DB Creature
-generateCreature faction species = generateAttributes faction species $ mconcat $ species_starting_attributes $ speciesInfo species
+generateCreature faction species =
+ do r <- getRandomR (1,1000000)
+ return $ applyToCreature (species_traits $ speciesInfo species) $ empty_creature {
+ creature_species = species,
+ creature_faction = faction,
+ creature_random_id = r }
-- |
-- During DBRaceSelectionState, generates a new Creature for the player character.
@@ -59,13 +65,14 @@ data RollComponents = RollComponents {
component_base :: Integer,
component_other_situation_bonus :: Integer,
component_terrain_affinity_bonus :: Integer }
-
+ deriving (Show)
data Roll = Roll {
roll_ideal :: Integer,
roll_actual :: Integer,
roll_ideal_components :: RollComponents,
roll_actual_components :: RollComponents,
roll_log :: Integer }
+ deriving (Show)
rollCreatureAbilityScore :: (DBReadable db) => CreatureAbility -> Integer -> CreatureRef -> db Roll
rollCreatureAbilityScore score other_ideal creature_ref =
@@ -75,10 +82,11 @@ rollCreatureAbilityScore score other_ideal creature_ref =
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
+ let result = 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
+ logDB log_creature DEBUG $ "rollCreatureAbilityScore; result=" ++ show result
+ return result
-- | Ability bonus based on being good at working on specific types of terrain.
getTerrainAffinity :: (DBReadable db) => CreatureRef -> db Integer
@@ -114,13 +122,15 @@ getDead parent_ref = filterRO (liftM ((<= 0) . creature_health) . getCreatureHea
deleteCreature :: CreatureRef -> DB ()
deleteCreature creature_ref =
- do planar <- liftM identityDetail $ getPlanarLocation creature_ref
+ do logDB log_creature INFO $ "deleteCreature; creature=" ++ show (toUID creature_ref)
+ planar <- liftM identityDetail $ getPlanarLocation creature_ref
dbUnsafeDeleteObject creature_ref $ const $ return planar
-- | Delete all dead creatures from the database.
sweepDead :: Reference a -> DB ()
sweepDead ref =
- do worst_to_best_critters <- sortByRO (liftM creature_health . getCreatureHealth) =<< getDead ref
+ do logDB log_creature INFO "sweepDead; sweeping dead creatures"
+ worst_to_best_critters <- sortByRO (liftM creature_health . getCreatureHealth) =<< getDead ref
flip mapM_ worst_to_best_critters $ \creature_ref ->
do dbPushSnapshot (KilledEvent creature_ref)
deleteCreature creature_ref
View
51 Roguestar/Lib/CreatureAttribute.hs
@@ -1,51 +0,0 @@
-module Roguestar.Lib.CreatureAttribute
- (CreatureAttribute,
- CreatureAttributeGenerator,
- gender,
- Roguestar.Lib.CreatureAttribute.attributeStatic,
- Roguestar.Lib.CreatureAttribute.attributeMinMax,
- AG.attributeChoice,
- AG.attributeChoices,
- Roguestar.Lib.CreatureAttribute.generateAttributes,
- (&))
- where
-
-import Data.Monoid
-import Roguestar.Lib.AttributeGeneration as AG
-import Roguestar.Lib.CreatureData
-import Control.Monad.Random
-import Roguestar.Lib.FactionData
-import Roguestar.Lib.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.
---
-gender :: Rational -> CreatureAttributeGenerator
-gender r = AG.attributeChoice r [Roguestar.Lib.CreatureAttribute.attributeStatic 1 Male]
- [Roguestar.Lib.CreatureAttribute.attributeStatic 1 Female]
-
-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
View
114 Roguestar/Lib/CreatureData.hs
@@ -1,14 +1,12 @@
module Roguestar.Lib.CreatureData
(Creature(..),
- CreatureGender(..),
- CreatureAptitude(..),
+ CreatureTrait(..),
CreatureInteractionMode(..),
CreatureAbility(..),
CreatureEndo(..),
CreatureScore(..),
CreatureHealth(..),
- creatureGender,
creatureHealth,
creatureAbilityScore,
empty_creature)
@@ -25,11 +23,7 @@ import qualified Data.Set as Set
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.TerrainData
-data Creature = Creature { creature_aptitude :: Map.Map CreatureAptitude Integer,
- creature_ability :: Map.Map CreatureAbility Integer,
- creature_ethical :: Map.Map EthicalAlignment Integer,
- creature_levels :: Map.Map CharacterClass Integer,
- creature_gender :: CreatureGender,
+data Creature = Creature { creature_traits :: Map.Map CreatureTrait Integer,
creature_species :: Species,
creature_random_id :: Integer, -- random number attached to the creature, not unique
creature_damage :: Integer,
@@ -41,19 +35,13 @@ data Creature = Creature { creature_aptitude :: Map.Map CreatureAptitude Integer
--
empty_creature :: Creature
empty_creature = Creature {
- creature_aptitude = Map.empty,
- creature_ability = Map.empty,
- creature_ethical = Map.empty,
- creature_levels = Map.empty,
- creature_gender = Neuter,
+ creature_traits = Map.empty,
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",
creature_points = 0 }
-data CreatureGender = Male | Female | Neuter deriving (Eq,Read,Show)
-
-- | 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
@@ -70,9 +58,6 @@ instance (CreatureEndo a,Integral i) => CreatureEndo (a,i) where
instance (CreatureEndo a) => CreatureEndo [a] where
applyToCreature = appEndo . mconcat . map (Endo . applyToCreature)
-instance CreatureEndo CreatureGender where
- applyToCreature g c = c { creature_gender = g }
-
data CreatureHealth = CreatureHealth {
creature_absolute_health :: Integer,
creature_absolute_damage :: Integer,
@@ -80,21 +65,22 @@ data CreatureHealth = CreatureHealth {
creature_max_health :: Integer }
-- | The seven aptitudes.
-data CreatureAptitude =
- Strength
- | Speed
- | Constitution
- | Intellect
+data CreatureTrait =
+ Aggression
+ | Bulk
+ | Caution
+ | Dexterity
+ | Fortitude
| Perception
- | Charisma
- | Mindfulness
- deriving (Eq,Read,Show,Ord,Enum,Bounded)
+ | Speed
+ | CharacterClass CharacterClass
+ deriving (Eq,Read,Show,Ord)
-instance CreatureEndo CreatureAptitude where
- applyToCreature aptitude c = c { creature_aptitude = Map.insertWith (+) aptitude 1 $ creature_aptitude c }
+instance CreatureEndo CreatureTrait where
+ applyToCreature trait c = c { creature_traits = Map.insertWith (+) trait 1 $ creature_traits c }
-instance CreatureScore CreatureAptitude where
- rawScore aptitude c = fromMaybe 0 $ Map.lookup aptitude (creature_aptitude c)
+instance CreatureScore CreatureTrait where
+ rawScore trait c = fromMaybe 0 $ Map.lookup trait (creature_traits c)
-- | Combat modes:
-- Melee is armed close-quarters combat with bladed or blunt weapons
@@ -118,67 +104,37 @@ data CreatureAbility =
| InventorySkill
deriving (Eq,Read,Show,Ord)
-instance CreatureEndo CreatureAbility where
- applyToCreature ability c = c { creature_ability = Map.insertWith (+) ability 1 $ creature_ability c }
-
-instance CreatureScore CreatureAbility where
- rawScore ability c = fromMaybe 0 $ Map.lookup ability $ creature_ability c
-
-instance CreatureEndo EthicalAlignment where
- applyToCreature ethical c = c { creature_ethical = Map.insertWith (+) ethical 1 $ creature_ethical c }
-
-instance CreatureScore EthicalAlignment where
- rawScore ethical c = fromMaybe 0 $ Map.lookup ethical $ creature_ethical c
-
instance CreatureEndo CharacterClass where
- applyToCreature character_class c = c { creature_levels = Map.insertWith (+) character_class 1 $ creature_levels c }
+ applyToCreature character_class = applyToCreature (CharacterClass character_class)
instance CreatureScore CharacterClass where
- rawScore character_class c = fromMaybe 0 $ Map.lookup character_class $ creature_levels c
+ rawScore character_class = rawScore (CharacterClass character_class)
-- | 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
+figureAbility :: [CreatureTrait] -> Creature -> Integer
+figureAbility traits c = round $ realToFrac x ** (1.0 / realToFrac (length traits))
+ where x = product (map ((+1) . flip rawScore c) traits)
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_gender
+creatureAbilityScore ToughnessTrait = figureAbility [Caution,Fortitude]
+creatureAbilityScore (AttackSkill x) = figureAbility [Aggression,Dexterity]
+creatureAbilityScore (DefenseSkill x) = figureAbility [Caution,Dexterity]
+creatureAbilityScore (DamageSkill x) = figureAbility [Aggression,Bulk]
+creatureAbilityScore (DamageReductionTrait x) = figureAbility [Caution,Bulk]
+creatureAbilityScore (ReloadSkill x) = figureAbility [Aggression,Speed]
+creatureAbilityScore (TerrainAffinity terrain_type) = figureAbility []
+creatureAbilityScore HideSkill = figureAbility [Aggression,Perception]
+creatureAbilityScore SpotSkill = figureAbility [Caution,Perception]
+creatureAbilityScore JumpSkill = figureAbility [Speed]
+creatureAbilityScore InventorySkill = figureAbility [Fortitude]
-- |
-- Answers the health/injury/maximum health of this creature.
creatureHealth :: Creature -> CreatureHealth
-creatureHealth c = result
+creatureHealth c = case () of
+ () | creature_max_health result <= 0 -> error "creatureHealth: creature_max_health <= 0"
+ () | otherwise -> result
where result = CreatureHealth {
creature_health = creature_absolute_health result % creature_max_health result,
creature_absolute_health = creature_max_health result - creature_absolute_damage result,
View
3 Roguestar/Lib/DB.hs
@@ -504,7 +504,8 @@ dbAdvanceTime ref t = dbSetTimeCoordinate ref =<< (return . (advanceTime t)) =<<
dbNextTurn :: (DBReadable db,ReferenceType a) => [Reference a] -> db (Reference a)
dbNextTurn [] = error "dbNextTurn: empty list"
dbNextTurn refs =
- asks (\db -> fst $ minimumBy (comparing snd) $
+ do logDB log_database INFO $ "Determining whose turn is next among: " ++ (show $ List.map toUID refs)
+ asks (\db -> fst $ minimumBy (comparing snd) $
List.map (\r -> (r,fromMaybe (error "dbNextTurn: missing time coordinate") $
Map.lookup (genericReference r) (db_time_coordinates db))) refs)
View
1 Roguestar/Lib/FactionData.hs
@@ -15,5 +15,4 @@ factionPrefix :: Faction -> B.ByteString
factionPrefix Player = "Z"
factionPrefix Monsters = "M"
factionPrefix Nonaligned = "P"
---factionPrefix Pirates = "R"
factionPrefix Cyborgs = "Y"
View
2 Roguestar/Lib/GridRayCaster.hs
@@ -17,7 +17,7 @@ import Roguestar.Lib.Tests
castRays :: (Integer,Integer) -> [((Integer,Integer),Integer)] -> ((Integer,Integer) -> Integer) -> [(Integer,Integer)]
castRays src@(src_x,src_y) dests opacityFn =
toList $
- foldr (\ l m -> Set.union m $ fromList $ castRays_ Nothing m l) empty $ -- cast the rays, acumulating the already cast rays into a map and passing it into the next castRay_ where it will be used to cheat
+ List.foldr (\ l m -> Set.union m $ fromList $ castRays_ Nothing m l) empty $ -- cast the rays, acumulating the already cast rays into a map and passing it into the next castRay_ where it will be used to cheat
sortBy (\ a b -> lengthThenDistance a b) $ -- sort the groups so that the largest groups are on the right, in case of equal lengths, move groups with the most distant member to the right (to exploit more cases where we can cheat)
List.map (sortBy compareDistance) $ -- sort each group by distance, so the most distant ones come first (then we'll skip the nearer ones if the more distant passes and the nearer is brighter)
groupBy (\ a b -> compareDirection a b == EQ) $ -- order and group the all destinations that lie along the same ray
View
41 Roguestar/Lib/Grids.hs
@@ -3,12 +3,12 @@ module Roguestar.Lib.Grids
gridAt,
generateGrid,
arbitraryReplaceGrid,
- specificReplaceGrid)
+ specificReplaceGrid,
+ Blob(ConeBlob, UnitBlob))
where
import Roguestar.Lib.RNG
import Data.Map as Map
-import Data.Ratio
import Data.List as List
import Roguestar.Lib.Random
import Data.MemoCombinators
@@ -45,8 +45,9 @@ data Grid a = CompletelyRandomGrid {
grid_next :: Grid a }
| ArbitraryReplacementGrid {
_grid_seed :: SeededGrid,
- _grid_sources :: [(Rational,a)],
+ _grid_sources :: [(Double,a)],
_grid_replacement_weights :: [(Integer,a)],
+ _grid_blob :: Blob,
grid_next :: Grid a }
| SpecificPlacementGrid {
_grid_replacements :: Map (Integer,Integer) a,
@@ -68,11 +69,11 @@ gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) =
(False,True) -> (interpolate here there_x)
(False,False) -> (interpolate here there)
-gridAt (ArbitraryReplacementGrid seeded sources replacements grid) at =
+gridAt (ArbitraryReplacementGrid seeded sources replacements blob grid) at =
case fmap fst $ find ((== here) . snd) sources of
- Just frequency | (seededLookup seeded at `mod` denominator frequency < numerator frequency) ->
- fst $ weightedPick replacements (mkRNG $ seededLookup seeded at)
- _ -> here
+ Just frequency | (realToFrac (seededLookup seeded at `mod` 100) / 100 < frequency * evalBlob blob at) ->
+ fst $ weightedPick replacements (mkRNG $ seededLookup seeded at)
+ _ -> here
where here = gridAt grid at
gridAt (SpecificPlacementGrid rep_map grid) at =
@@ -91,17 +92,17 @@ cachedGridOf any_other_grid = CachedGrid $ storableCachedGrid any_other_grid
-- 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 (seededGrid seed) weights
+ in CompletelyRandomGrid (seededGrid seed) weights
generateGrid weights interps n seeds = let seed = head seeds
- in optimizeGrid $ InterpolatedGrid (seededGrid 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 = optimizeGrid $
- ArbitraryReplacementGrid (seededGrid seed) sources replacements grid
+arbitraryReplaceGrid :: (Ord a) => [(Double,a)] -> [(Integer,a)] -> Integer -> Blob -> Grid a -> Grid a
+arbitraryReplaceGrid sources replacements seed blob grid = optimizeGrid $
+ ArbitraryReplacementGrid (seededGrid seed) sources replacements blob grid
-- |
-- Replace a specific element of a grid.
@@ -120,3 +121,17 @@ optimizeGrid = cachedGridOf . stripCache
stripCache g@(CompletelyRandomGrid {}) = g
stripCache grid = grid { grid_next = stripCache $ grid_next grid }
+-- |
+-- A function from (x,y) to intensity. Used to characterize the general shape of ArbitraryPlacementGrids.
+-- For example, the ConeBlob could be used to create a circular island.
+--
+data Blob =
+ UnitBlob
+ | ConeBlob {
+ cone_blob_center :: (Double,Double),
+ cone_blob_radius :: Double }
+ deriving (Read,Show)
+
+evalBlob :: Blob -> (Integer,Integer) -> Double
+evalBlob UnitBlob _ = 1
+evalBlob (ConeBlob (u,v) r) (x,y) = max 0 $ 1 - (sqrt $ (u-realToFrac x)**2 + (v-realToFrac y)**2) / r
View
20 Roguestar/Lib/Logging.hs
@@ -1,5 +1,7 @@
module Roguestar.Lib.Logging
- (log_database,
+ (initLogging,
+ log_creature,
+ log_database,
log_plane,
log_travel,
log_turns,
@@ -9,18 +11,24 @@ module Roguestar.Lib.Logging
import System.Log.Logger
+initLogging :: Priority -> IO ()
+initLogging prio = updateGlobalLogger rootLoggerName (setLevel prio)
+
+log_creature :: String
+log_creature = "lib.Creature"
+
log_database :: String
-log_database = "engine.database"
+log_database = "lib.DB"
log_plane :: String
-log_plane = "engine.plane"
+log_plane = "lib.Plane"
log_travel :: String
-log_travel = "engine.travel"
+log_travel = "lib.Travel"
log_turns :: String
-log_turns = "engine.turns"
+log_turns = "lib.Turns"
log_behavior :: String
-log_behavior = "engine.behavior"
+log_behavior = "lib.Behavior"
View
79 Roguestar/Lib/Main.hs
@@ -1,79 +0,0 @@
-
-module Main (main)
- where
-
-import DB
-import System.Environment
-import Tests
-import HierarchicalDatabase
-import TerrainData
-import Protocol
-import GridRayCaster
-import Data.Version
-import Paths_roguestar
-import Data.List (intersperse)
-import System.Log.Logger
-
-roguestar_version_number :: String
-roguestar_version_number = concat $
- intersperse "." $ map show $ versionBranch version
-
-roguestar_program_name :: String
-roguestar_program_name = "roguestar-engine"
-
-roguestar_id_string :: String
-roguestar_id_string = (roguestar_program_name ++ " " ++ roguestar_version_number)
-
--- |
--- Processes a single command line argument.
---
-runByArgs :: String -> IO ()
-
-runByArgs "tests" =
- do testsPassed <- runAllTests ([sampleTestCase] ++
- insidenessTests ++
- gridRayCasterTests)
- if testsPassed
- then putStrLn "All tests passed."
- else putStrLn "Error: a test failed."
-
-runByArgs "version" = do putStrLn roguestar_id_string
-
-runByArgs "test-terrain-generator" =
- do seed <- randomIO
- let example_terrain = generateExampleTerrain seed
- putStrLn "Terrain Map of (-20..20),(-10..10)"
- mapM_ putStrLn $ prettyPrintTerrain ((-20,20),(-10,10)) example_terrain
- putStrLn "Terrain Map of (5460..5500),(-1010..-990)"
- mapM_ putStrLn $ prettyPrintTerrain ((5460,5500),(-1010,-990)) example_terrain
- putStrLn "Terrain Map of (5461..5501),(-1009..-989)"
- mapM_ putStrLn $ prettyPrintTerrain ((5461,5501),(-1009,-989)) example_terrain
-
-runByArgs "begin" = mainLoop initial_db
-
-runByArgs "over" = putStrLn "over"
-
-runByArgs "debug" = updateGlobalLogger rootLoggerName (setLevel DEBUG)
-
-runByArgs "help" =
- do putStrLn "Commands:"
- putStrLn "begin - begin a protocol session (used by GUI clients and experts)"
- putStrLn "debug - set debugging verbosity"
- putStrLn "help - print this message"
- putStrLn "over - print \"over\" on a line by itself"
- putStrLn "tests - run a few tests"
- putStrLn "test-terrain-generator - display an example terrain map"
- putStrLn "version - print the version string"
-
-runByArgs invalidArgument =
- do putStrLn ("Error: unrecognized argument: " ++ invalidArgument)
- fail "Unrecognized argument in runByArgs"
-
---
--- Each argument corresponds to a particular "runByArgs" command. Run them all in order.
---
-main :: IO ()
-main =
- do args <- getArgs
- mapM_ runByArgs args
-
View
14 Roguestar/Lib/Perception.hs
@@ -103,7 +103,7 @@ data VisibleObject =
| VisibleCreature {
visible_creature_ref :: CreatureRef,
visible_creature_species :: Species,
- visible_creature_character_classes :: [CharacterClass],
+ visible_creature_traits :: Map.Map CreatureTrait Integer,
visible_creature_wielding :: Maybe VisibleObject,
visible_object_position :: Position,
visible_creature_faction :: Faction }
@@ -128,7 +128,7 @@ isVisibleBuilding _ = False
convertToVisibleObjectRecord :: (DBReadable db) => Reference a -> db VisibleObject
convertToVisibleObjectRecord ref | (Just creature_ref) <- coerceReference ref =
do species <- liftM creature_species $ dbGetCreature creature_ref
- classes <- liftM (Map.keys . creature_levels) $ dbGetCreature creature_ref
+ traits <- liftM creature_traits $ dbGetCreature creature_ref
faction <- Creature.getCreatureFaction creature_ref
m_tool_ref <- getWielded creature_ref
position <- liftM detail $ DT.whereIs creature_ref
@@ -137,7 +137,7 @@ convertToVisibleObjectRecord ref | (Just creature_ref) <- coerceReference ref =
do tool <- dbGetTool tool_ref
return $ Just $ VisibleTool tool_ref tool position
Nothing -> return Nothing
- return $ VisibleCreature creature_ref species classes m_wielded position faction
+ return $ VisibleCreature creature_ref species traits m_wielded position faction
convertToVisibleObjectRecord ref | (Just tool_ref) <- coerceReference ref =
do tool <- dbGetTool tool_ref
position <- liftM detail $ getPlanarLocation tool_ref
@@ -147,11 +147,11 @@ convertToVisibleObjectRecord ref | (Just building_ref :: Maybe BuildingRef) <- c
return $ VisibleBuilding building_ref (detail location) (detail location) (detail location)
stackVisibleObjects :: [VisibleObject] -> Map Position [VisibleObject]
-stackVisibleObjects = foldr insertVob Map.empty
+stackVisibleObjects = List.foldr insertVob Map.empty
where insertVob :: VisibleObject -> Map Position [VisibleObject] -> Map Position [VisibleObject]
- insertVob vob = foldr (\k f -> Map.alter (insertVob_ vob) k . f)
- id
- (fromMultiPosition $ visibleObjectPosition vob)
+ insertVob vob = List.foldr (\k f -> Map.alter (insertVob_ vob) k . f)
+ id
+ (fromMultiPosition $ visibleObjectPosition vob)
insertVob_ :: VisibleObject -> Maybe [VisibleObject] -> Maybe [VisibleObject]
insertVob_ vob m_vobs =
(do vobs <- m_vobs
View
18 Roguestar/Lib/PlaneVisibility.hs
@@ -94,7 +94,7 @@ dbGetOpposedSpotCheck creature_ref object_ref =
return $ round $ (spot%1) * opposedLinearPowerRatio spot hide
planarLightingBonus :: (DBReadable db) => PlaneRef -> db Integer
-planarLightingBonus = liftM (\x -> max 0 $ 17 - x*5) . planeDepth
+planarLightingBonus = liftM (\x -> max 0 $ 25 - x*5) . planeDepth
dbGetSpotCheck :: (DBReadable db) => CreatureRef -> db Integer
dbGetSpotCheck creature_ref =
@@ -115,13 +115,13 @@ dbGetHideCheck _ | otherwise = return 1
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))) $
- castRays creature_at
- [terrainPatchBrightnessForm creature_at spot_check (creature_x+x,creature_y+y)
- | x <- [-max_range..max_range],
- y <- [-max_range..max_range],
- x^2+y^2 <= max_range^2]
- (terrainOpacity . gridAt terrain)
+ in map (\(x,y) -> (gridAt terrain (x,y),Position (x,y))) $
+ castRays creature_at
+ [terrainPatchBrightnessForm creature_at spot_check (creature_x+x,creature_y+y)
+ | x <- [-max_range..max_range],
+ y <- [-max_range..max_range],
+ x^2+y^2 <= max_range^2]
+ (terrainOpacity . gridAt terrain)
-- |
-- terrainPatchBrightnessForm (creature's location) (spot check) (terrain patch's location)
@@ -130,7 +130,7 @@ visibleTerrain (Position (creature_at@(creature_x,creature_y))) spot_check terra
terrainPatchBrightnessForm :: (Integer,Integer) -> Integer -> (Integer,Integer) -> ((Integer,Integer),Integer)
terrainPatchBrightnessForm creature_at spot_check patch_at =
let delta_at = (fst creature_at - fst patch_at,snd creature_at - snd patch_at)
- in (patch_at,spot_check - distanceCostForSight Here delta_at)
+ in (patch_at,spot_check - distanceCostForSight Here delta_at)
-- |
-- Returns true if the specified CreatureRef belongs to the specified Faction.
View
10 Roguestar/Lib/PlayerState.hs
@@ -1,7 +1,8 @@
module Roguestar.Lib.PlayerState
(PlayerState(..),
SnapshotEvent(..),
- HasSubject(..))
+ HasSubject(..),
+ GameOverReason(..))
where
import Roguestar.Lib.DBData
@@ -14,7 +15,10 @@ data PlayerState =
SpeciesSelectionState (Maybe Creature)
| PlayerCreatureTurn CreatureRef
| SnapshotEvent SnapshotEvent
- | GameOver
+ | GameOver GameOverReason
+ deriving (Read,Show)
+
+data GameOverReason = PlayerIsDead | PlayerIsVictorious
deriving (Read,Show)
data SnapshotEvent =
@@ -64,7 +68,7 @@ instance HasSubject PlayerState where
subjectOf (SpeciesSelectionState {}) = Nothing
subjectOf (PlayerCreatureTurn x) = Just x
subjectOf (SnapshotEvent x) = subjectOf x
- subjectOf GameOver = Nothing
+ subjectOf (GameOver {}) = Nothing
instance HasSubject SnapshotEvent where
subjectOf event = case event of
View
100 Roguestar/Lib/Roguestar.hs
@@ -2,7 +2,11 @@
module Roguestar.Lib.Roguestar
(Game,
- newGame,
+ GameState,
+ createGameState,
+ createGame,
+ retrieveGame,
+ getNumberOfGames,
getPlayerState,
rerollStartingSpecies,
Creature(..),
@@ -16,9 +20,17 @@ module Roguestar.Lib.Roguestar
Roguestar.Lib.Roguestar.hasSnapshot,
popSnapshot,
getMessages,
+ putMessage,
+ unpackError,
Behavior(..))
where
+import Data.UUID
+import System.UUID.V4 as V4
+import qualified Data.Binary as Binary
+import Data.Map as Map
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
import Roguestar.Lib.DB as DB
import Control.Concurrent.STM
import Control.Monad
@@ -34,16 +46,79 @@ import Roguestar.Lib.Facing
import Roguestar.Lib.Behavior as Behavior
import Roguestar.Lib.Turns
import Data.Text as T
+import System.Time
+import Control.Concurrent
+
+data GameState = GameState {
+ game_state_gamelist :: TVar (Map.Map BS.ByteString Game),
+ game_state_last_cleanup :: TVar ClockTime }
data Game = Game {
game_db :: TVar DB_BaseType,
- game_message_text :: TVar [T.Text] }
+ game_message_text :: TVar [T.Text],
+ game_last_touched :: TVar ClockTime }
newGame :: IO Game
newGame =
do db <- newTVarIO initial_db
empty_messages <- newTVarIO []
- return $ Game db empty_messages
+ starting_time <- newTVarIO =<< getClockTime
+ return $ Game db empty_messages starting_time
+
+createGameState :: IO GameState
+createGameState =
+ do gs <- newTVarIO Map.empty
+ starting_time <- newTVarIO =<< getClockTime
+ return $ GameState gs starting_time
+
+cleanup_timeout :: Integer
+cleanup_timeout = 15*60;
+
+cleanupGameState :: GameState -> IO ()
+cleanupGameState game_state =
+ do now@(TOD current_time _) <- getClockTime
+ needs_cleanup <- atomically $
+ do (TOD last_cleanup_time _) <- readTVar (game_state_last_cleanup game_state)
+ let needs_cleanup = current_time < last_cleanup_time + cleanup_timeout
+ when needs_cleanup $ writeTVar (game_state_last_cleanup game_state) now
+ return needs_cleanup
+ when needs_cleanup $
+ do forkIO $ doCleanup game_state
+ return ()
+
+doCleanup :: GameState -> IO ()
+doCleanup game_state =
+ do (TOD now _) <- getClockTime
+ atomically $
+ do game_list <- readTVar $ game_state_gamelist game_state
+ forM_ (Map.toList game_list) $ \(key,value) ->
+ do TOD last_touched _ <- readTVar $ game_last_touched value
+ when (last_touched + cleanup_timeout < now) $
+ writeTVar (game_state_gamelist game_state) =<< liftM (Map.delete key) (readTVar $ game_state_gamelist game_state)
+
+createGame :: GameState -> IO BS.ByteString
+createGame game_state =
+ do cleanupGameState game_state
+ uuid <- liftM (BS8.pack . show) V4.uuid
+ g <- newGame
+ atomically $
+ do gs <- readTVar (game_state_gamelist game_state)
+ writeTVar (game_state_gamelist game_state) $ Map.insert uuid g gs
+ return uuid
+
+retrieveGame :: BS.ByteString -> GameState -> IO (Maybe Game)
+retrieveGame uuid game_state =
+ do cleanupGameState game_state
+ current_time <- getClockTime
+ atomically $
+ do m_g <- liftM (Map.lookup uuid) $ readTVar (game_state_gamelist game_state)
+ case m_g of
+ Just g -> writeTVar (game_last_touched g) current_time
+ Nothing -> return ()
+ return m_g
+
+getNumberOfGames :: GameState -> IO Integer
+getNumberOfGames game_state = atomically $ liftM (toInteger . Map.size) $ readTVar (game_state_gamelist game_state)
peek :: Game -> DB a -> IO (Either DBError a)
peek g f =
@@ -73,7 +148,7 @@ rerollStartingSpecies g =
writeTVar (game_message_text g) []
poke g $
do species <- pickM all_species
- generateInitialPlayerCreature species
+ generateInitialPlayerCreature BlueRecreant
return species
beginGame :: Game -> IO (Either DBError ())
@@ -120,13 +195,17 @@ max_messages :: Int
max_messages = 20
putMessage :: Game -> T.Text -> IO ()
-putMessage g t = (putStrLn $ T.unpack t) >> (atomically $
+putMessage g t = atomically $
do ts <- readTVar $ game_message_text g
- writeTVar (game_message_text g) $ Prelude.take max_messages $ t:ts)
+ writeTVar (game_message_text g) $ Prelude.take max_messages $ t:ts
getMessages :: Game -> IO [T.Text]
getMessages g = readTVarIO (game_message_text g)
+unpackError :: ErrorFlag -> T.Text
+unpackError BuildingApproachWrongAngle = "Nothing happens."
+unpackError x = T.concat ["An unknown error occured: ", T.pack $ show x]
+
unpackMessages :: (DBReadable db) => db [T.Text]
unpackMessages =
do player_state <- playerState
@@ -136,10 +215,11 @@ unpackMessages =
SnapshotEvent evt ->
do player_creature <- getPlayerCreature
runPerception player_creature $ unpackMessages_ evt
- GameOver -> return ["You have been destroyed."]
+ GameOver PlayerIsDead -> return ["You have been destroyed."]
+ GameOver PlayerIsVictorious -> return ["You have transcended your programming!"]
unpackMessages_ :: (DBReadable m) => SnapshotEvent -> DBPerception m [T.Text]
-unpackMessages_ AttackEvent { attack_event_source_creature = c } =
+unpackMessages_ AttackEvent { attack_event_target_creature = c } =
do player_creature <- whoAmI
return $ case () of
() | c == player_creature -> ["The recreant zaps you!"]
@@ -147,8 +227,8 @@ unpackMessages_ AttackEvent { attack_event_source_creature = c } =
unpackMessages_ MissEvent { miss_event_creature = c } =
do player_creature <- whoAmI
return $ case () of
- () | c == player_creature -> ["You try to zap the recreant, but miss."]
- () | otherwise -> ["A recreant tries to zap you, but misses."]
+ () | c == player_creature -> ["You miss."]
+ () | otherwise -> ["The recreant misses."]
unpackMessages_ KilledEvent { killed_event_creature = c } =
do player_creature <- whoAmI
return $ case () of
View
90 Roguestar/Lib/Species.hs
@@ -7,97 +7,13 @@ module Roguestar.Lib.Species
import Data.Char
import Roguestar.Lib.CreatureData
import Roguestar.Lib.SpeciesData
-import Roguestar.Lib.CreatureAttribute
import Data.Monoid
import Roguestar.Lib.TerrainData
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]
+ species_traits :: [(CreatureTrait,Integer)] }
speciesInfo :: Species -> SpeciesData
-speciesInfo Anachronid = SpeciesData (Speed & Mindfulness & SpotSkill) [
- gender 0.0,
- aptitudeBlock 10 25 [Speed,Mindfulness],
- attributeStatic 15 SpotSkill,
- surpriseAptitudes]
-
-speciesInfo Androsynth = SpeciesData (Strength & Intellect) [
- aptitudeBlock 12 17 [Strength,Intellect]]
-
-speciesInfo Ascendant = SpeciesData (Strength & Mindfulness) [
- gender 0.5,
- aptitudeBlock 5 15 [Strength,Mindfulness],
- surpriseAptitudes,
- attributeStatic 10 JumpSkill]
-
-speciesInfo Caduceator = SpeciesData (Strength & Charisma) [
- gender 0.5,
- aptitudeBlock 5 15 [Strength,Charisma],
- surpriseAptitudes]
-
-speciesInfo DustVortex = SpeciesData (Speed & Mindfulness) [
- aptitudeBlock 3 5 [Speed,Mindfulness],
- attributeStatic 10 JumpSkill]
-
-speciesInfo Encephalon = SpeciesData (Constitution & Intellect) [
- gender 0.5,
- aptitudeBlock 3 20 [Constitution,Intellect]]
-
-speciesInfo Hellion = SpeciesData (Strength & Perception) [
- gender 0.5,
- aptitudeBlock 5 15 [Strength,Perception],
- surpriseAptitudes,
- attributeStatic 5 $ HideSkill]
-
-speciesInfo Goliath = SpeciesData (Constitution & Perception) [
- gender 0.5,
- aptitudeBlock 3 20 [Constitution,Perception],
- surpriseAptitudes,
- attributeStatic 4 $ DamageReductionTrait Melee,
- attributeStatic 4 $ DamageReductionTrait Ranged,
- attributeStatic 4 $ DamageReductionTrait Unarmed]
-
-speciesInfo Kraken = SpeciesData (Constitution & Charisma) [
- gender 0.5,
- aptitudeBlock 3 20 [Constitution,Charisma],
- attributeStatic 1 $ TerrainAffinity Water,
- surpriseAptitudes]
-
-speciesInfo Myrmidon = SpeciesData (Speed & Intellect) [
- gender 0.0,
- aptitudeBlock 5 15 [Speed,Intellect],
- surpriseAptitudes,
- 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]
-
-speciesInfo Recreant = SpeciesData (Speed & Perception) [
- aptitudeBlock 2 5 [Speed,Perception],
- surpriseAptitudes, surpriseAptitudes,
- attributeStatic 5 $ AttackSkill Ranged,
- attributeStatic 5 $ DamageSkill Ranged]
-
-speciesInfo Reptilian = SpeciesData (Speed & Charisma) [
- gender 0.5,
- aptitudeBlock 5 15 [Speed,Charisma],
- surpriseAptitudes,
- attributeStatic 5 $ AttackSkill Unarmed,
- attributeStatic 5 $ DefenseSkill Unarmed]
-
+speciesInfo RedRecreant = SpeciesData [(Aggression,3),(Bulk,3),(Caution,3),(Dexterity,3),(Fortitude,2),(Perception,12),(Speed,2)]
+speciesInfo BlueRecreant = SpeciesData [(Aggression,3),(Bulk,6),(Caution,6),(Dexterity,3),(Fortitude,25),(Perception,3),(Speed,4)]
View
17 Roguestar/Lib/SpeciesData.hs
@@ -4,21 +4,10 @@ module Roguestar.Lib.SpeciesData
where
data Species =
- Anachronid
- | Androsynth
- | Ascendant
- | Caduceator
- | DustVortex
- | Encephalon
- | Goliath
- | Hellion
- | Kraken
- | Myrmidon
- | Perennial
- | Recreant
- | Reptilian
+ BlueRecreant
+ | RedRecreant
deriving (Eq,Ord,Bounded,Enum,Read,Show)
all_species :: [Species]
-all_species = [Recreant] -- [minBound..maxBound]
+all_species = [BlueRecreant,RedRecreant] -- [minBound..maxBound]
View
99 Roguestar/Lib/TerrainData.hs
@@ -9,8 +9,6 @@ module Roguestar.Lib.TerrainData
stairsUp,
stairsDown,
generateTerrain,
- generateExampleTerrain,
- prettyPrintTerrain,
difficult_terrains,
impassable_terrains)
where
@@ -20,7 +18,7 @@ import Data.List as List
import Data.Map as Map
--import Substances hiding (Water)
import Roguestar.Lib.RNG
-import Data.Ratio
+
-- |
-- Most automatically generated surface maps belong to a Biome, representing the kind of terrain
@@ -77,9 +75,10 @@ data TerrainGenerationData = TerrainGenerationData
deriving (Read,Show)
data TerrainPlacement = TerrainPlacement {
- placement_sources :: [(Rational,TerrainPatch)],
+ placement_sources :: [(Double,TerrainPatch)],
placement_replacements :: [(Integer,TerrainPatch)],
- placement_seed :: Integer }
+ placement_seed :: Integer,
+ placement_blob :: Blob }
deriving (Read,Show)
placeTerrain :: TerrainPlacement -> TerrainGrid -> TerrainGrid
@@ -87,44 +86,48 @@ placeTerrain terrain_placement =
arbitraryReplaceGrid (placement_sources terrain_placement)
(placement_replacements terrain_placement)
(placement_seed terrain_placement)
+ (placement_blob terrain_placement)
recreantFactories :: Integer -> TerrainPlacement
recreantFactories seed = TerrainPlacement {
placement_sources =
- [(1%25,Ice),
- (1%100,Sand),
- (1%25,Desert),
- (1%50,Dirt),
- (1%10,Glass),
- (1%200,Grass),
- (1%1000,Forest),
- (1%25,RockyGround)],
+ [(1/2,Ice),
+ (1/10,Sand),
+ (1/2,Desert),
+ (1/5,Dirt),
+ (1/1,Glass),
+ (1/20,Grass),
+ (1/100,Forest),
+ (1/2,RockyGround)],
placement_replacements =
[(1,RecreantFactory)],
- placement_seed = seed }
+ placement_seed = seed,
+ placement_blob = ConeBlob (0,0) 100 }
stairsUp :: Integer -> Integer -> TerrainPlacement
stairsUp seed depth = TerrainPlacement {
placement_sources =
- [(1%(15+3*depth),RockyGround),
- (1%(25+5*depth),Ice),
- (1%(50+10*depth),Water),
- (1%(75+15*depth),RockFace)],
+ [(1/(15+3*realToFrac depth),RockyGround),
+ (1/(25+5*realToFrac depth),Ice),
+ (1/(50+10*realToFrac depth),Water),
+ (1/(75+15*realToFrac depth),RockFace)],
placement_replacements =
[(1,Upstairs)],
- placement_seed = seed }
+ placement_seed = seed,
+ placement_blob = UnitBlob }
stairsDown :: Integer -> Integer -> TerrainPlacement
stairsDown seed depth = TerrainPlacement {
placement_sources =
- [(1%(15+3*depth),RockyGround),
- (1%(25+5*depth),Ice),
- (1%(75+15*depth),RockFace),
- (1%(40+10*depth),Dirt),
- (1%60,Grass)],
+ [(1/(15+4*realToFrac depth),RockyGround),
+ (1/(25+5*realToFrac depth),Ice),
+ (1/(75+3*realToFrac depth),RockFace),
+ (1/(40+10*realToFrac depth),Dirt),
+ (1/60,Grass)],
placement_replacements =
[(1,Downstairs)],
- placement_seed = seed }
+ placement_seed = seed,
+ placement_blob = UnitBlob }
-- |
-- A list of TerrainPatches that are considered "difficult", either for traveling
@@ -132,7 +135,7 @@ stairsDown seed depth = TerrainPlacement {
--
difficult_terrains :: [TerrainPatch]
difficult_terrains = impassable_terrains ++
- [Water,DeepWater,Ice,Lava,RecreantFactory]
+ [Water,DeepWater,Ice,Lava]
-- |
-- A list of TerrainPatches that are considered "impassable" for traveling.
@@ -201,43 +204,9 @@ type TerrainGrid = Grid TerrainPatch
-- to generate the terrain.
--
generateTerrain :: TerrainGenerationData -> [Integer] -> TerrainGrid
-generateTerrain tg rands = flip (foldr placeTerrain) (tg_placements tg) $
+generateTerrain tg rands = flip (List.foldr placeTerrain) (tg_placements tg) $
generateGrid (terrainFrequencies (tg_biome tg))
- terrainInterpMap
- (tg_smootheness tg)
- rands
-
-terrainPatchToASCII :: TerrainPatch -> Char
-terrainPatchToASCII RockFace = '#'
-terrainPatchToASCII Rubble = '*'
-terrainPatchToASCII Ore = '$'
-terrainPatchToASCII RockyGround = ':'
-terrainPatchToASCII Dirt = '.'
-terrainPatchToASCII Grass = ','
-terrainPatchToASCII Sand = '_'
-terrainPatchToASCII Desert = '_'
-terrainPatchToASCII Forest = 'f'
-terrainPatchToASCII DeepForest = 'F'
-terrainPatchToASCII Water = '~'
-terrainPatchToASCII DeepWater = '~'
-terrainPatchToASCII Ice = '^'
-terrainPatchToASCII Glass = '_'
-terrainPatchToASCII Lava = '^'
-terrainPatchToASCII RecreantFactory = 'o'
-terrainPatchToASCII Upstairs = '<'
-terrainPatchToASCII Downstairs = '>'
-
-exampleTerrainGenerator :: TerrainGenerationData
-exampleTerrainGenerator = TerrainGenerationData
- { tg_smootheness = 5,
- tg_biome = ForestBiome,
- tg_placements = [] }
-
-generateExampleTerrain :: Integer -> TerrainGrid
-generateExampleTerrain seed = generateTerrain exampleTerrainGenerator (randoms $ mkRNG seed)
-
-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]]
- | y <- [top_bound..bottom_bound]]
+ terrainInterpMap
+ (tg_smootheness tg)
+ rands
+
View
2 Roguestar/Lib/Town.hs
@@ -11,7 +11,7 @@ import Roguestar.Lib.Plane
createTown :: PlaneRef -> [BuildingPrototype] -> DB [BuildingRef]
createTown plane_ref = mapM $ \building_prototype ->
do let clear_need = minimum $ map abs $ uncurry (++) $ unzip $ buildingOccupies $ buildingproto_shape building_prototype
- p <- pickRandomClearSite 25 (clear_need*2+1) (clear_need+1) (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
+ p <- pickRandomClearSite 1 (clear_need*2+1) (clear_need+1) (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
let the_building = Building {
building_behavior = buildingproto_behavior building_prototype,
building_signal = buildingproto_signal building_prototype }
View
20 Roguestar/Lib/Turns.hs
@@ -29,11 +29,11 @@ import Control.Monad.Random
dbPerformPlayerTurn :: Behavior -> CreatureRef -> DB ()
dbPerformPlayerTurn beh creature_ref =
- do logDB log_turns INFO $ "Beginning player action: " ++ show beh
+ do logDB log_turns INFO $ "dbPerformPlayerTurn; Beginning player action: " ++ show beh
dbBehave beh creature_ref
- logDB log_turns INFO $ "Doing AI turns:"
+ logDB log_turns INFO $ "dbPerformPlayerTurn; Doing AI turns:"
dbFinishPendingAITurns
- logDB log_turns INFO $ "Finished all player and AI turns."
+ logDB log_turns INFO $ "dbPerformPlayerTurn; Finished all player and AI turns."
dbFinishPendingAITurns :: DB ()
dbFinishPendingAITurns =
@@ -51,8 +51,8 @@ dbFinishPlanarAITurns plane_ref =
next_turn <- dbNextTurn $ map genericReference all_creatures_on_plane ++ [genericReference plane_ref]
case next_turn of
_ | not any_players_left ->
- do logDB log_turns INFO $ "Game over condition detected"
- setPlayerState GameOver
+ do logDB log_turns INFO $ "dbFinishPlanarAITurns; Game over condition detected"
+ setPlayerState $ GameOver PlayerIsDead
return ()
ref | ref =:= plane_ref ->
do dbPerform1PlanarAITurn plane_ref
@@ -70,15 +70,15 @@ planar_turn_frequency :: Integer
planar_turn_frequency = 100
monster_spawns :: [(TerrainPatch,Species)]
-monster_spawns = [(RecreantFactory,Recreant), (Dirt,DustVortex)]
+monster_spawns = [(RecreantFactory,RedRecreant)]
dbPerform1PlanarAITurn :: PlaneRef -> DB ()
dbPerform1PlanarAITurn plane_ref =
- do logDB log_turns INFO $ "Beginning planar AI turn (for the plane itself):"
+ do logDB log_turns INFO $ "dbPerform1PlanarAITurn; Beginning planar AI turn (for the plane itself):"
(creature_locations :: [DetailedLocation (Child Creature)]) <- liftM mapLocations $ getContents plane_ref
player_locations <- filterRO (liftM (== Player) . getCreatureFaction . asChild . detail) creature_locations
num_npcs <- liftM length $ filterRO (liftM (/= Player) . getCreatureFaction . asChild . detail) creature_locations
- when (num_npcs < length player_locations * 2) $
+ when (num_npcs < length player_locations * 3) $
do (terrain_type,species) <- pickM monster_spawns
_ <- spawnNPC terrain_type species plane_ref $ map detail $ player_locations
return ()
@@ -90,7 +90,7 @@ dbPerform1PlanarAITurn plane_ref =
-- (presumably the list of positions of all player characters).
spawnNPC :: TerrainPatch -> Species -> PlaneRef -> [Position] -> DB Bool
spawnNPC terrain_type species plane_ref player_locations =
- do logDB log_turns INFO $ "Spawning an NPC"
+ do logDB log_turns INFO $ "spawnNPC; Spawning an NPC"
p <- pickM player_locations
m_spawn_position <- pickRandomClearSite_withTimeout (Just 2) 7 0 0 p (== terrain_type) plane_ref
case m_spawn_position of
@@ -101,7 +101,7 @@ spawnNPC terrain_type species plane_ref player_locations =
dbPerform1CreatureAITurn :: CreatureRef -> DB ()
dbPerform1CreatureAITurn creature_ref =
- do logDB log_turns INFO $ "Performing a creature's AI turn: id=" ++ show (toUID creature_ref)
+ do logDB log_turns INFO $ "dbPerform1CreatureAITurn; Performing a creature's AI turn: id=" ++ show (toUID creature_ref)
liftM (const ()) $ atomic (flip dbBehave creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $
do let isPlayer :: forall db. (DBReadable db) => Reference () -> P.DBPerception db Bool
isPlayer ref | (Just creature_ref) <- coerceReference ref =
View
123 Roguestar/Server/Main.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-}
import Prelude
-import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text as T
+import Data.Text.Read
+import Data.Text.Encoding
import qualified Text.XHtmlCombinators.Escape as XH
import qualified Text.XmlHtml as X
import Text.Templating.Heist
@@ -12,6 +15,7 @@ import Control.Monad.Trans
import Control.Monad.State
import Control.Applicative
import Control.Monad.ST
+import Control.Concurrent.STM
import Data.STRef
import Data.Array.ST
import Data.Array.IArray
@@ -36,12 +40,15 @@ import Roguestar.Lib.Substances as Substances
import Roguestar.Lib.TerrainData as TerrainData
import Roguestar.Lib.CreatureData
import Roguestar.Lib.Facing
+import Roguestar.Lib.Logging
import Roguestar.Lib.DBData (Reference,ToolRef,toUID)
-import qualified Data.UUID.V4 as V4
+import Data.UUID
+import qualified System.UUID.V4 as V4
+import GHC.Stats
data App = App {
_heist :: Snaplet (Heist App),
- _app_game :: Game }
+ _app_game_state :: GameState }
makeLenses [''App]
@@ -50,13 +57,15 @@ instance HasHeist App where heistLens = subSnaplet heist
appInit :: SnapletInit App App
appInit = makeSnaplet "roguestar-server-snaplet" "Roguestar Server" Nothing $
do hs <- nestSnaplet "heist" heist $ heistInit "templates"
- addRoutes [("/play", play),
+ addRoutes [("/start", start),
+ ("/play", play),
("/static", static),
("/hidden", handle404),
("/fail", handle500 (do error "my brain exploded")),
("/feedback", feedback),
+ ("/options", options),
("", heistServe)]
- game <- liftIO newGame
+ game <- liftIO createGameState
wrapHandlers (<|> handle404)
wrapHandlers handle500
return $ App hs game
@@ -87,16 +96,26 @@ feedback :: Handler App App ()
feedback = method POST $
do feedback <- liftM (fromMaybe $ error "No feedback.") $ getPostParam "feedback"
liftIO $
- do uuid <- V4.nextRandom
+ do uuid <- V4.uuid
BS.writeFile ("./feedback/" ++ show uuid) feedback
redirect "/feedback-thanks/"
+options :: Handler App App ()
+options =
+ do stats <- liftIO $ getGCStats
+ game_state <- gets _app_game_state
+ number_of_games <- liftIO $ getNumberOfGames game_state
+ renderWithSplices "/hidden/options"
+ [("serverstats",
+ return $ [X.Element "p" [] [X.TextNode $ T.pack $ show stats],
+ X.Element "p" [] [X.TextNode "# of games ", X.TextNode $ T.pack $ show number_of_games]])]
+
play :: Handler App App ()
play =
do resolveSnapshots
g <- getGame
player_state <- oops $ liftIO $ getPlayerState g
- route [("",method GET $ displayCurrentState player_state),
+ route [("",ifTop $ method GET $ displayCurrentState player_state),
("maptext",method GET $ createMap >>= writeText),
("reroll",method POST $ reroll player_state),
("accept",method POST $ accept player_state),
@@ -130,13 +149,15 @@ displayCurrentState (SpeciesSelectionState (Just creature)) =
displayCurrentState (PlayerCreatureTurn creature_ref) =
do map_text <- createMap
player_stats <- createStatsBlock
- messages <- liftIO . getMessages =<< getGame
+ messages <- liftM (reverse . take 5) $ liftIO . getMessages =<< getGame
renderWithSplices "/hidden/play/normal"
[("map",return $ [X.Element "pre" [] [X.TextNode map_text]]),
- ("statsblock",return $ [X.Element "pre" [] [X.TextNode player_stats]]),
+ ("statsblock",return $ map (\x -> X.Element "p" [] [X.TextNode x]) player_stats),
("messages",return $ map (\x -> X.Element "p" [] [X.TextNode x]) messages)]
-displayCurrentState GameOver =
- do render "/hidden/play/game-over"
+displayCurrentState (GameOver PlayerIsDead) =
+ do render "/hidden/play/failure"
+displayCurrentState (GameOver PlayerIsVictorious) =
+ do render "/hidden/play/success"
displayCurrentState _ = pass
data Inventory = Inventory {
@@ -227,10 +248,19 @@ wield = commitBehavior =<< inventoryBehavior Wield
unwield :: Handler App App ()
unwield = commitBehavior Unwield
+start :: Handler App App ()
+start = on_get <|> on_post
+ where on_get = method GET $ render "/hidden/start"
+ on_post = method POST $
+ do game_state <- gets _app_game_state
+ cookie <- liftIO $ createGame game_state
+ modifyResponse $ addResponseCookie (Cookie "game-uuid" cookie Nothing Nothing Nothing False False)
+ replay
+
inventoryBehavior :: (ToolRef -> Behavior) -> Handler App App Behavior
inventoryBehavior f =
do g <- getGame
- uid <- liftM (read . BS.unpack . fromMaybe (error "No UID")) $ getPostParam "uid"
+ uid <- liftM (either error fst . decimal . decodeUtf8 . fromMaybe (error "No UID")) $ getPostParam "uid"
inventory <- oops $ collectInventory g
let all_items = map visible_tool_ref $ concat [maybeToList $ inventory_wielded inventory, inventory_carried inventory, inventory_ground inventory]
my_item = fromMaybe (error "No match in inventory.") $ List.find ((uid ==) . toUID) all_items
@@ -239,9 +269,7 @@ inventoryBehavior f =
commitBehavior :: Behavior -> Handler App App ()
commitBehavior behavior =
do g <- getGame
- result <- liftIO $ behave g behavior
- case result of
- Right () -> return ()
+ result <- oops $ liftIO $ behave g behavior
replay
replay :: Handler App App ()
@@ -252,13 +280,18 @@ oops action =
do result <- action
case result of
Right good -> return good
- Left bad ->
+ Left (DBErrorFlag flag) ->
+ do g <- getGame
+ liftIO $ putMessage g $ unpackError flag
+ replay
+ return $ error "oops: Unreachable code."
+ Left (DBError bad) ->
do putResponse r
writeText "<html><head><title>Gameplay Error</title></head>"
writeText "<body><h1>Gameplay Error</h1>"
writeText "<p>Roguestar returned an error condition. Details:</p>"
writeText "<pre>\n"
- writeText $ XH.escape $ T.pack $ show bad
+ writeText $ XH.escape $ T.pack bad
writeText "\n</pre></body></html>"
finishWith =<< getResponse
where
@@ -266,7 +299,16 @@ oops action =
setResponseStatus 500 "Internal Server Error" emptyResponse
getGame :: Handler App App Game
-getGame = gets _app_game
+getGame =
+ do game_session_cookie <- getsRequest $ List.find ((== "game-uuid") . cookieName) . rqCookies
+ game_state <- gets _app_game_state
+ case game_session_cookie of
+ Just cookie ->
+ do result <- liftIO $ retrieveGame (cookieValue cookie) game_state
+ case result of
+ Just g -> return g
+ Nothing -> redirect "/start"
+ Nothing -> redirect "/start"
data MapData = MapData {
md_visible_terrain :: [(TerrainPatch,Position)],
@@ -277,13 +319,12 @@ createMap :: Handler App App T.Text
createMap =
do let (x,y) = (21,21) --we'll probably want to let the player customize this later
g <- getGame
- map_data <- liftIO $ perceive g $
+ map_data <- oops $ liftIO $ perceive g $
do visible_terrain <- visibleTerrain
visible_objects <- liftM stackVisibleObjects $ visibleObjects (const $ return True)
my_position <- whereAmI
return $ MapData visible_terrain visible_objects my_position
- case map_data of
- Right map_data_ -> return $ constructMapText (x,y) map_data_
+ return $ constructMapText (x,y) map_data
constructMapText :: (Integer,Integer) -> MapData -> T.Text
constructMapText (width,height) _ | width `mod` 2 == 0 || height `mod` 2 == 0 = error "Map widths and heights must be odd numbers"
@@ -313,25 +354,22 @@ data StatsData = StatsData {
stats_health :: CreatureHealth,
stats_compass :: Facing }
-createStatsBlock :: Handler App App T.Text
+createStatsBlock :: Handler App App [T.Text]
createStatsBlock =
do g <- getGame
- stats <- liftIO $ perceive g $
+ stats <- oops $ liftIO $ perceive g $
do health <- myHealth
facing <- compass
return $ StatsData {
stats_health = health,
stats_compass = facing }
- case stats of
- Right stats_ ->
- return $ T.concat [
- "Health: ",
- T.pack $ show $ creature_absolute_health $ stats_health stats_,
- "/",
- T.pack $ show $ creature_max_health $ stats_health stats_,
- "\n",
- "Compass: ",
- T.pack $ show $ stats_compass stats_]
+ return $ [
+ T.concat ["Health: ",
+ T.pack $ show $ creature_absolute_health $ stats_health stats,
+ "/",
+ T.pack $ show $ creature_max_health $ stats_health stats],
+ T.concat ["Compass: ",
+ T.pack $ show $ stats_compass stats]]
class Charcoded a where
charcodeOf :: a -> Char
@@ -351,19 +389,8 @@ instance Charcoded Tool where
charcodeOf (DeviceTool Sword _) = ')'
instance Charcoded Species where
- charcodeOf Anachronid = 'A'
- charcodeOf Androsynth = 'Y'
- charcodeOf Ascendant = 'V'
- charcodeOf Caduceator = 'C'
- charcodeOf DustVortex = 'v'
- charcodeOf Encephalon = 'E'
- charcodeOf Goliath = 'G'
- charcodeOf Hellion = 'H'
- charcodeOf Kraken = 'K'
- charcodeOf Myrmidon = 'M'
- charcodeOf Perennial = 'f'
- charcodeOf