Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: clanehin/roguestar
base: 155ef03882
...
head fork: clanehin/roguestar
compare: c44ec0c81e
Checking mergeability… Don't worry, you can still create the pull request.
  • 2 commits
  • 66 files changed
  • 0 commit comments
  • 1 contributor
Commits on Oct 22, 2012
@clanehin Adds fast random number generator and SiteCriteria. 8e5142a
Commits on Oct 29, 2012
@clanehin Various changes made while sleep deprived. I think this adds mwc-rand…
…om, a new random site picker with pluggable criteria, and a few css improvements including images.
c44ec0c
Showing with 510 additions and 272 deletions.
  1. +1 −0  Roguestar/Lib/Activate.hs
  2. +1 −0  Roguestar/Lib/Alignment.hs
  3. +8 −10 Roguestar/Lib/BeginGame.hs
  4. +3 −2 Roguestar/Lib/Behavior.hs
  5. +1 −1  Roguestar/Lib/Behavior/Combat.hs
  6. +1 −1  Roguestar/Lib/Behavior/Construction.hs
  7. +1 −1  Roguestar/Lib/Behavior/Travel.hs
  8. +8 −8 Roguestar/Lib/Building.hs
  9. +1 −0  Roguestar/Lib/BuildingData.hs
  10. +1 −3 Roguestar/Lib/Character.hs
  11. +1 −0  Roguestar/Lib/CharacterAdvancement.hs
  12. +1 −3 Roguestar/Lib/Contact.hs
  13. +4 −7 Roguestar/Lib/{ → Core}/Plane.hs
  14. +2 −5 Roguestar/Lib/Creature.hs
  15. +8 −10 Roguestar/Lib/CreatureData.hs
  16. +28 −24 Roguestar/Lib/DB.hs
  17. +3 −4 Roguestar/Lib/DBData.hs
  18. +1 −0  Roguestar/Lib/DBErrorFlag.hs
  19. +1 −0  Roguestar/Lib/DBPrivate.hs
  20. +3 −1 Roguestar/Lib/DetailedLocation.hs
  21. +1 −1  Roguestar/Lib/DetailedTravel.hs
  22. +10 −9 Roguestar/Lib/Facing.hs
  23. +1 −0  Roguestar/Lib/FactionData.hs
  24. +1 −0  Roguestar/Lib/GridRayCaster.hs
  25. +33 −21 Roguestar/Lib/Grids.hs
  26. +1 −1  Roguestar/Lib/HierarchicalDatabase.hs
  27. +1 −0  Roguestar/Lib/Logging.hs
  28. +1 −0  Roguestar/Lib/MakeData.hs
  29. +2 −1  Roguestar/Lib/Perception.hs
  30. +1 −0  Roguestar/Lib/PersistantData.hs
  31. +1 −1  Roguestar/Lib/PlaneData.hs
  32. +2 −1  Roguestar/Lib/PlaneVisibility.hs
  33. +2 −2 Roguestar/Lib/Planet.hs
  34. +2 −0  Roguestar/Lib/PlanetData.hs
  35. +1 −1  Roguestar/Lib/PlayerState.hs
  36. +1 −0  Roguestar/Lib/Position.hs
  37. +16 −5 Roguestar/Lib/RNG.hs
  38. +41 −20 Roguestar/Lib/Random.hs
  39. +3 −10 Roguestar/Lib/Reference.hs
  40. +5 −8 Roguestar/Lib/Roguestar.hs
  41. +2 −4 Roguestar/Lib/Species.hs
  42. +2 −0  Roguestar/Lib/SpeciesData.hs
  43. +3 −3 Roguestar/Lib/Substances.hs
  44. +61 −47 Roguestar/Lib/TerrainData.hs
  45. +4 −4 Roguestar/Lib/Tests.hs
  46. +1 −0  Roguestar/Lib/TimeCoordinate.hs
  47. +2 −2 Roguestar/Lib/Tool.hs
  48. +2 −0  Roguestar/Lib/ToolData.hs
  49. +3 −3 Roguestar/Lib/Town.hs
  50. +1 −1  Roguestar/Lib/TravelData.hs
  51. +5 −5 Roguestar/Lib/Turns.hs
  52. +44 −2 Roguestar/Lib/UnitTests.hs
  53. +89 −0 Roguestar/Lib/Utility/SiteCriteria.hs
  54. +3 −3 Roguestar/Lib/VisibilityData.hs
  55. +3 −3 Roguestar/Server/Main.hs
  56. +7 −4 roguestar.cabal
  57. BIN  static/faded-bead.png
  58. BIN  static/faded-bead.xcf
  59. BIN  static/glass-bead-bright.png
  60. BIN  static/glass-bead-bright.xcf
  61. BIN  static/glass-bead.png
  62. BIN  static/glass-bead.xcf
  63. BIN  static/glass-vertical.png
  64. BIN  static/glass-vertical.xcf
  65. +4 −2 static/play.mustache
  66. +70 −28 static/roguebasic.css
View
1  Roguestar/Lib/Activate.hs
@@ -1,3 +1,4 @@
+-- Mechanics
module Roguestar.Lib.Activate
(ActivationOutcome,
resolveActivation,
View
1  Roguestar/Lib/Alignment.hs
@@ -1,3 +1,4 @@
+-- Data
module Roguestar.Lib.Alignment
(Alignment,
MoralAlignment(..),
View
18 Roguestar/Lib/BeginGame.hs
@@ -3,9 +3,9 @@ module Roguestar.Lib.BeginGame
(beginGame)
where
-import Roguestar.Lib.Plane
+-- World
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.Character
import Roguestar.Lib.BuildingData
import Roguestar.Lib.DB
import Roguestar.Lib.Facing
@@ -14,17 +14,15 @@ import Roguestar.Lib.ToolData
import Control.Monad
import Control.Monad.Error
import Roguestar.Lib.SpeciesData
-import Roguestar.Lib.Substances as Substances
import Roguestar.Lib.PlayerState
import Roguestar.Lib.Town
-import Roguestar.Lib.PlanetData
-import Roguestar.Lib.Planet
import qualified Data.ByteString.Char8 as B ()
import Control.Monad.Random
+import Roguestar.Lib.Utility.SiteCriteria
-homeBiome :: Species -> [Biome]
-homeBiome RedRecreant = [ForestBiome,TundraBiome,MountainBiome]
-homeBiome BlueRecreant = [ForestBiome,TundraBiome,MountainBiome]
+homeBiome :: Species -> WeightedSet Biome
+homeBiome RedRecreant = unweightedSet [ForestBiome,TundraBiome,MountainBiome]
+homeBiome BlueRecreant = unweightedSet [ForestBiome,TundraBiome,MountainBiome]
startingEquipmentBySpecies :: Species -> [Tool]
startingEquipmentBySpecies RedRecreant = []
@@ -33,7 +31,7 @@ startingEquipmentBySpecies BlueRecreant = []
dbCreateStartingPlane :: Creature -> DB PlaneRef
dbCreateStartingPlane creature =
do seed <- getRandom
- biome <- pickM $ homeBiome (creature_species creature)
+ biome <- weightedPickM $ homeBiome (creature_species creature)
dbNewPlane "belhaven" (TerrainGenerationData {
tg_smootheness = 2,
tg_biome = biome,
@@ -49,7 +47,7 @@ beginGame =
SpeciesSelectionState (Just c) -> return c
_ -> throwError $ DBError "Tried to begin a game, but no species/creature has been selected."
plane_ref <- dbCreateStartingPlane creature
- landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
+ landing_site <- pickRandomSite (-150,150) (-150,150) 150 [areaClearForObjectPlacement 0, atDistanceFrom (Position (0,0)) 100] plane_ref
creature_ref <- dbAddCreature creature (Standing plane_ref landing_site Here)
setPlayerCreature creature_ref
_ <- createTown plane_ref [basic_stargate]
View
5 Roguestar/Lib/Behavior.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE ExistentialQuantification, Rank2Types, ScopedTypeVariables #-}
+-- Mechanics
module Roguestar.Lib.Behavior
(Behavior(..),
facingBehavior,
@@ -21,7 +22,7 @@ import Roguestar.Lib.Behavior.Travel
import Roguestar.Lib.TravelData
import Roguestar.Lib.Creature
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlaneVisibility
import Data.List
import Control.Monad.Maybe
@@ -31,7 +32,7 @@ import Roguestar.Lib.Behavior.Construction
import Roguestar.Lib.Building
import Roguestar.Lib.Reference
import Roguestar.Lib.DetailedLocation
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlaneData
--
View
2  Roguestar/Lib/Behavior/Combat.hs
@@ -18,7 +18,7 @@ import Roguestar.Lib.Facing
import Data.Maybe
import Roguestar.Lib.Behavior.DeviceActivation
import Roguestar.Lib.Contact
-import Roguestar.Lib.Plane as Plane
+import Roguestar.Lib.Core.Plane as Plane
import Roguestar.Lib.DetailedLocation
data AttackModel =
View
2  Roguestar/Lib/Behavior/Construction.hs
@@ -7,7 +7,7 @@ module Roguestar.Lib.Behavior.Construction
where
import Roguestar.Lib.DB
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlaneData
import Roguestar.Lib.TerrainData
import Roguestar.Lib.Facing
View
2  Roguestar/Lib/Behavior/Travel.hs
@@ -14,7 +14,7 @@ module Roguestar.Lib.Behavior.Travel
import Control.Monad.Maybe
import Roguestar.Lib.Facing
import Roguestar.Lib.DB as DB
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Data.Maybe
import Control.Monad
import Control.Monad.Trans
View
16 Roguestar/Lib/Building.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
-
+--Core
module Roguestar.Lib.Building
(buildingSize,
buildingShape,
@@ -17,7 +17,7 @@ import Data.Maybe
import Control.Monad.Maybe
import Control.Monad.Random
import Roguestar.Lib.PlaneData
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.Position
import Roguestar.Lib.TerrainData
import Control.Monad.Error
@@ -60,8 +60,8 @@ activateBuilding :: BuildingBehavior -> CreatureRef -> BuildingRef -> DB Bool
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,building_position :: Position) <- liftM detail $ getPlanarLocation building_ref
+activateBuilding (TwoWayStargate _) creature_ref building_ref =
+ do (Parent _ :: Parent Plane,building_position :: Position) <- liftM detail $ getPlanarLocation building_ref
(creature_position :: Position) <- liftM detail $ getPlanarLocation creature_ref
case () of
() | distanceBetweenChessboard creature_position building_position == 1 ->
@@ -70,10 +70,10 @@ activateBuilding (TwoWayStargate region) creature_ref building_ref =
do throwError $ DBErrorFlag BuildingApproachWrongAngle
return True
activateBuilding (OneWayStargate region) creature_ref building_ref =
- do (Parent plane_ref :: Parent Plane,Position (bx,by))
+ do (Parent plane_ref :: Parent Plane,Position (_,by))
<- liftM detail $ getPlanarLocation building_ref
- (Position (cx,cy)) <- liftM detail $ getPlanarLocation creature_ref
- case () of
+ (Position (_,cy)) <- liftM detail $ getPlanarLocation creature_ref
+ _ <- case () of
() | cy - by == 1 ->
do subsequent_plane <- maybe (throwError $ DBErrorFlag NoStargateAddress) return
=<< getSubsequent region plane_ref
@@ -89,7 +89,7 @@ portalCreatureTo building_behavior offset creature_ref plane_ref =
portals <- filterM (liftM ((== building_behavior) . Just) . buildingBehavior) all_buildings
ideal_position <- if null portals
then liftM2 (\x y -> Position (x,y)) (getRandomR (-40,40)) (getRandomR (-40,40))
- else do portal <- pickM portals
+ else do portal <- weightedPickM $ unweightedSet portals
liftM (offsetPosition (0,offset) . detail) $ getPlanarLocation portal
position <- pickRandomClearSite 1 0 0 ideal_position (not . (`elem` impassable_terrains)) plane_ref
dbPushSnapshot $ TeleportEvent creature_ref
View
1  Roguestar/Lib/BuildingData.hs
@@ -1,4 +1,5 @@
+-- Data
module Roguestar.Lib.BuildingData
(Building(..),
BuildingBehavior(..),
View
4 Roguestar/Lib/Character.hs
@@ -1,11 +1,9 @@
-
+-- Core
module Roguestar.Lib.Character
(applyCharacterClass)
where
-import Roguestar.Lib.Alignment
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.TerrainData
import Roguestar.Lib.PersistantData
applyCharacterClass :: CharacterClass -> Creature -> Creature
View
1  Roguestar/Lib/CharacterAdvancement.hs
@@ -1,3 +1,4 @@
+-- Mechanics
module Roguestar.Lib.CharacterAdvancement
(CharacterBumpResult(..),
characterFitness,
View
4 Roguestar/Lib/Contact.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+-- Mechanics
module Roguestar.Lib.Contact
(findContacts,
ContactMode(..),
@@ -10,14 +11,11 @@ import Prelude hiding (getContents)
import Roguestar.Lib.Position as Position
import Roguestar.Lib.Facing
import Roguestar.Lib.DB
-import Roguestar.Lib.Reference
import Roguestar.Lib.CreatureData
import Control.Monad
-import Roguestar.Lib.Plane
import Roguestar.Lib.PlaneData
import Data.Ord
import Data.List as List
-import Data.Maybe
import Roguestar.Lib.DetailedLocation
-- | 'Touch' contacts are on the same or facing square as the subject.
View
11 Roguestar/Lib/Plane.hs → Roguestar/Lib/Core/Plane.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, PatternGuards, TypeFamilies #-}
-module Roguestar.Lib.Plane
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, PatternGuards, TypeFamilies, ExistentialQuantification #-}
+module Roguestar.Lib.Core.Plane
(dbNewPlane,
planetName,
randomPlanetName,
planeDepth,
getCurrentPlane,
- Roguestar.Lib.Plane.distanceBetweenSquared,
+ Roguestar.Lib.Core.Plane.distanceBetweenSquared,
pickRandomClearSite_withTimeout,
pickRandomClearSite,
getPlanarLocation,
@@ -26,7 +26,6 @@ import Roguestar.Lib.TerrainData
import Roguestar.Lib.PlaneData
import Roguestar.Lib.PlanetData
import Roguestar.Lib.ToolData (Tool)
-import Roguestar.Lib.BuildingData (Building)
import Roguestar.Lib.CreatureData (Creature)
import Control.Monad
import Control.Monad.Random as Random
@@ -109,9 +108,7 @@ distanceBetweenSquared :: (DBReadable db,
AlwaysHasIndirectPlanarLocation b) =>
Reference a -> Reference b -> db (Maybe Integer)
distanceBetweenSquared a_ref b_ref =
- do a <- getPlanarLocation a_ref
- b <- getPlanarLocation b_ref
- (Parent a_parent :: Parent Plane, a_multiposition :: MultiPosition) <- liftM detail $ getPlanarLocation a_ref
+ do (Parent a_parent :: Parent Plane, a_multiposition :: MultiPosition) <- liftM detail $ getPlanarLocation a_ref
(Parent b_parent :: Parent Plane, b_multiposition :: MultiPosition) <- liftM detail $ getPlanarLocation b_ref
return $
do guard $ a_parent == b_parent
View
7 Roguestar/Lib/Creature.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE TypeFamilies, PatternGuards #-}
-
+--Core
module Roguestar.Lib.Creature
(generateInitialPlayerCreature,
newCreature,
@@ -24,12 +24,9 @@ import Roguestar.Lib.Species
import Roguestar.Lib.FactionData
import Control.Monad.Error
import Control.Monad.Random
-import Roguestar.Lib.Tool
-import Data.Monoid
-import Data.Ratio
import Roguestar.Lib.Facing
import Roguestar.Lib.Position
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlayerState
import Roguestar.Lib.DetailedLocation
import Roguestar.Lib.Logging
View
18 Roguestar/Lib/CreatureData.hs
@@ -1,4 +1,4 @@
-
+--Data
module Roguestar.Lib.CreatureData
(Creature(..),
CreatureTrait(..),
@@ -13,13 +13,11 @@ module Roguestar.Lib.CreatureData
where
import Roguestar.Lib.PersistantData
-import Roguestar.Lib.Alignment
import Data.Ratio
import Data.Maybe
import Roguestar.Lib.FactionData
import Data.Monoid
import qualified Data.Map as Map
-import qualified Data.Set as Set
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.TerrainData
@@ -113,17 +111,17 @@ instance CreatureScore CharacterClass where
-- | Calculator to determine how many ranks a creature has in an ability.
-- Number of aptitude points plus n times number of ability points
figureAbility :: [CreatureTrait] -> Creature -> Integer
-figureAbility traits c = round $ realToFrac x ** (1.0 / realToFrac (length traits))
+figureAbility traits c = round $ (realToFrac x :: Double) ** (1.0 / realToFrac (length traits))
where x = product (map ((+1) . flip rawScore c) traits)
creatureAbilityScore :: CreatureAbility -> Creature -> Integer
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 (AttackSkill _) = figureAbility [Aggression,Dexterity]
+creatureAbilityScore (DefenseSkill _) = figureAbility [Caution,Dexterity]
+creatureAbilityScore (DamageSkill _) = figureAbility [Aggression,Bulk]
+creatureAbilityScore (DamageReductionTrait _) = figureAbility [Caution,Bulk]
+creatureAbilityScore (ReloadSkill _) = figureAbility [Aggression,Speed]
+creatureAbilityScore (TerrainAffinity _) = figureAbility []
creatureAbilityScore HideSkill = figureAbility [Aggression,Perception]
creatureAbilityScore SpotSkill = figureAbility [Caution,Perception]
creatureAbilityScore JumpSkill = figureAbility [Speed]
View
52 Roguestar/Lib/DB.hs
@@ -6,6 +6,7 @@
ScopedTypeVariables,
TypeFamilies #-}
+--Core
module Roguestar.Lib.DB
(DB,
runDB,
@@ -63,7 +64,6 @@ import Roguestar.Lib.RNG
import Data.Map as Map
import Data.List as List
import qualified Roguestar.Lib.HierarchicalDatabase as HD
-import Roguestar.Lib.SpeciesData
import Data.Maybe
import Roguestar.Lib.ToolData
import Control.Monad.State
@@ -72,7 +72,6 @@ import Control.Monad.Reader
import Control.Applicative
import Roguestar.Lib.TimeCoordinate
import Data.Ord
-import Control.Arrow (first,second)
import Control.Monad.Random as Random
import Roguestar.Lib.Random
import Roguestar.Lib.PlayerState
@@ -82,10 +81,14 @@ import System.IO.Unsafe
import Roguestar.Lib.Logging
import Control.Monad.ST
import Data.STRef
+import qualified Data.Vector.Unboxed as Vector
+import qualified System.Random.MWC as MWC
+import Data.Word
data DBContext s = DBContext {
db_info :: STRef s DB_BaseType,
- db_rng :: STRef s RNG }
+ db_rng :: STRef s RNG,
+ db_mwc_rng :: STRef s (MWC.GenST s) }
data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
db_next_object_ref :: Integer,
@@ -106,10 +109,13 @@ data DB a = DB { internalRunDB :: forall s. DBContext s -> ST s (Either DBError
runDB :: DB a -> DB_BaseType -> IO (Either DBError (a,DB_BaseType))
runDB dbAction database =
do rng <- randomIO
+ (seed :: Vector.Vector Word32) <- MWC.withSystemRandom . MWC.asGenIO $ \gen ->
+ MWC.uniformVector gen 2
return $ runST $
- do data_ref <- newSTRef database
+ do mwc_rng_ref <- newSTRef =<< MWC.initialize seed
+ data_ref <- newSTRef database
rng_ref <- newSTRef rng
- result <- internalRunDB dbAction (DBContext data_ref rng_ref)
+ result <- internalRunDB dbAction (DBContext data_ref rng_ref mwc_rng_ref)
database' <- readSTRef data_ref
return $ case result of
Left err -> Left err
@@ -142,11 +148,10 @@ instance MonadState DB_BaseType DB where
instance MonadReader DB_BaseType DB where
ask = get
local modification actionM =
- do split_rng <- dbRandomSplit
- db <- get
+ do db <- get
modify modification
a <- catchError (liftM Right actionM) (return . Left)
- DB $ \context -> liftM Right $ writeSTRef (db_rng context) split_rng
+ put db
either throwError return a
instance MonadError DBError DB where
@@ -170,27 +175,26 @@ dbRandom rgen = DB $ \context ->
writeSTRef (db_rng context) g1
return $ Right x
-dbRandomSplit :: DB RNG
-dbRandomSplit = dbRandom Random.split
-
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)
+ uniform :: (Int,Int) -> db Int
+ uniformVector :: Int -> (Int,Int) -> db (Vector.Vector Int)
instance DBReadable DB where
dbSimulate = local id
dbPeepSnapshot actionM =
- do db <- get
- m_snapshot <- gets db_prior_snapshot
+ do m_snapshot <- gets db_prior_snapshot
case m_snapshot of
Just snapshot ->
- do split_rng <- dbRandomSplit
- put snapshot
- a <- dbSimulate actionM
- put db
- DB $ \context -> liftM Right $ writeSTRef (db_rng context) split_rng
- return $ Just a
+ do liftM Just $ local (const snapshot) $ dbSimulate actionM
Nothing -> return Nothing
+ uniform range = DB $ \context ->
+ do gen <- readSTRef (db_mwc_rng context)
+ liftM Right $ MWC.uniformR range gen
+ uniformVector n (a,b) = DB $ \ context ->
+ do gen <- readSTRef (db_mwc_rng context)
+ liftM (Right . Vector.map ((+a) . (`mod` (b-a)))) $ MWC.uniformVector gen n
logDB :: (DBReadable db) => String -> Priority -> String -> db ()
logDB l p s = return $! unsafePerformIO $ logM l p $ l ++ ": " ++ s
@@ -243,7 +247,7 @@ playerState :: (DBReadable m) => m PlayerState
playerState = asks db_player_state
setPlayerState :: PlayerState -> DB ()
-setPlayerState state = modify (\db -> db { db_player_state = state })
+setPlayerState player_state = modify (\db -> db { db_player_state = player_state })
getPlayerCreature :: (DBReadable m) => m CreatureRef
getPlayerCreature = liftM (fromMaybe $ error "No player creature selected yet.") $ asks db_player_creature
@@ -269,10 +273,10 @@ dbAddObjectComposable :: (ReferenceType a) =>
(Reference a -> a -> DB ()) ->
(Reference a -> l -> Location) ->
a -> l -> DB (Reference a)
-dbAddObjectComposable constructReference updateObject constructLocation thing loc =
- do ref <- liftM constructReference $ dbNextObjectRef
- updateObject ref thing
- setLocation $ constructLocation ref loc
+dbAddObjectComposable constructReferenceAction updateObjectAction constructLocationAction thing loc =
+ do ref <- liftM constructReferenceAction $ dbNextObjectRef
+ updateObjectAction ref thing
+ setLocation $ constructLocationAction ref loc
genericParent_ref <- liftM parentReference $ whereIs ref
dbSetTimeCoordinate (genericReference ref) =<< dbGetTimeCoordinate (genericReference genericParent_ref)
return ref
View
7 Roguestar/Lib/DBData.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, PatternGuards, TypeFamilies #-}
-
+--Data
module Roguestar.Lib.DBData
(Reference,
toUID,
@@ -36,7 +36,6 @@ import Roguestar.Lib.ToolData
import Roguestar.Lib.CreatureData
import Roguestar.Lib.PlaneData
import Roguestar.Lib.BuildingData
-import Data.Maybe
import Control.Monad
import Roguestar.Lib.Position
import Roguestar.Lib.Reference
@@ -146,7 +145,7 @@ instance LocationDetail Position where
fromLocation (IsBeneath {}) = Nothing
instance LocationDetail MultiPosition where
- fromLocation (IsConstructed b c) = Just $ multiPosition (constructed_position c) (buildingOccupies $ constructed_shape c)
+ fromLocation (IsConstructed _ c) = Just $ multiPosition (constructed_position c) (buildingOccupies $ constructed_shape c)
fromLocation x = fmap (toMultiPosition :: Position -> MultiPosition) $ fromLocation x
instance LocationDetail Facing where
@@ -210,5 +209,5 @@ returnToInventory _ | otherwise = Nothing
shuntToTheUniverse :: Location -> Maybe Location
shuntToTheUniverse l | Just (Child plane) <- fromLocation l = Just $ InTheUniverse plane
-shuntToTHeUniverse _ | otherwise = Nothing
+shuntToTheUniverse _ | otherwise = Nothing
View
1  Roguestar/Lib/DBErrorFlag.hs
@@ -1,3 +1,4 @@
+--Data
module Roguestar.Lib.DBErrorFlag
(DBError(..),
ErrorFlag(..))
View
1  Roguestar/Lib/DBPrivate.hs
@@ -1,3 +1,4 @@
+--Data
module Roguestar.Lib.DBPrivate
(Reference(..),
unsafeReference,
View
4 Roguestar/Lib/DetailedLocation.hs
@@ -1,9 +1,10 @@
{-# LANGUAGE TypeFamilies, EmptyDataDecls, ScopedTypeVariables, PatternGuards, FlexibleContexts #-}
-
+--Core
module Roguestar.Lib.DetailedLocation
(DetailedLocation,
PlaneLocation,
BuildingLocation,
+ CreatureLocation,
ToolLocation,
CarriedLocation,
PlanarLocation,
@@ -82,6 +83,7 @@ instance LocationConstructor Planar where
constructLocation building_ref $ Constructed (planar_parent planar)
(planar_position planar)
(error "LocationConstructor Planar: constructLocation: indeterminate")
+ constructLocation _ _ | otherwise = error "LocationConstructor Planar - constructLocation: failed match"
-- | Meaning that an assignment from one location type to another is guaranteed to succeed.
data Supported
View
2  Roguestar/Lib/DetailedTravel.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE TypeFamilies #-}
-
+--Core
module Roguestar.Lib.DetailedTravel
(Roguestar.Lib.DetailedTravel.whereIs,
Roguestar.Lib.DetailedTravel.getContents)
View
19 Roguestar/Lib/Facing.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+--Data
module Roguestar.Lib.Facing
(Facing(..),
facingToRelative,
@@ -15,15 +16,15 @@ import Data.List
import qualified Data.ByteString.Char8 as B
data Facing = North
- | NorthEast
- | East
- | SouthEast
- | South
- | SouthWest
- | West
- | NorthWest
- | Here
- deriving (Eq,Ord,Enum,Bounded,Read,Show)
+ | NorthEast
+ | East
+ | SouthEast
+ | South
+ | SouthWest
+ | West
+ | NorthWest
+ | Here
+ deriving (Eq,Ord,Enum,Bounded,Read,Show)
-- |
-- Takes an abbreviation (n,e,sw, etc) and answers a facing.
View
1  Roguestar/Lib/FactionData.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+--Data
module Roguestar.Lib.FactionData
(Faction(..),factionPrefix)
where
View
1  Roguestar/Lib/GridRayCaster.hs
@@ -1,4 +1,5 @@
+--Data
module Roguestar.Lib.GridRayCaster
(castRays,
castRay,
View
54 Roguestar/Lib/Grids.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-- Data
module Roguestar.Lib.Grids
(Grid,
gridAt,
@@ -13,6 +15,7 @@ import Data.List as List
import Roguestar.Lib.Random
import Data.MemoCombinators
import Control.Arrow
+import qualified Data.Vector as Vector
newtype SeededGrid = SeededGrid Integer deriving (Read,Show)
data StorableCachedGrid a = StorableCachedGrid (Grid a) ((Integer,Integer) -> a)
@@ -23,30 +26,39 @@ instance (Show a) => Show (StorableCachedGrid a) where
instance (Read a,Ord a) => Read (StorableCachedGrid a) where
readsPrec = (List.map (first storableCachedGrid) .) . readsPrec
-storableCachedGrid :: (Ord a) => Grid a -> StorableCachedGrid a
-storableCachedGrid g = StorableCachedGrid g $ pair integral integral $ gridAt g
+{-# INLINE tile_size #-}
+tile_size :: (Integral i) => i
+tile_size = 16
+
+storableCachedGrid :: forall a. (Ord a) => Grid a -> StorableCachedGrid a
+storableCachedGrid g = StorableCachedGrid g $ \(x,y) ->
+ flip Vector.unsafeIndex (fromInteger $ (y `mod` tile_size)*tile_size + x `mod` tile_size) $ cache (x `div` tile_size, y `div` tile_size)
+ where cache = pair integral integral $ tiledGridAt g
+
+tiledGridAt :: (Ord a) => Grid a -> (Integer,Integer) -> Vector.Vector a
+tiledGridAt g (x,y) = Vector.generate (tile_size*tile_size) $ \i -> gridAt g (x*tile_size + toInteger i `mod` tile_size, y*tile_size + toInteger i `div` tile_size)
seededGrid :: Integer -> SeededGrid
seededGrid n = SeededGrid n
seededLookup :: SeededGrid -> (Integer,Integer) -> Integer
-seededLookup (SeededGrid n) (x,y) = toInteger $ fst $ next $ mkRNG $
- (fst $ next $ mkRNG (fromInteger $ (x*809) `mod` max_int)) +
- (fst $ next $ mkRNG (fromInteger $ (y*233) `mod` max_int)) +
- (fromInteger $ n `mod` max_int)
+seededLookup (SeededGrid n) (x,y) = blurp $
+ ((x*809) `mod` max_int) +
+ ((y*233) `mod` max_int) +
+ (n `mod` max_int)
where max_int = toInteger (maxBound :: Int)
data Grid a = CompletelyRandomGrid {
_grid_seed :: SeededGrid,
- _grid_weights :: [(Integer,a)] }
+ _grid_weights :: WeightedSet a }
| InterpolatedGrid {
_grid_seed :: SeededGrid,
- _grid_interpolation_weights :: Map (a,a) [(Integer,a)],
+ _grid_interpolation_weights :: Map (a,a) (WeightedSet a),
grid_next :: Grid a }
| ArbitraryReplacementGrid {
_grid_seed :: SeededGrid,
_grid_sources :: [(Double,a)],
- _grid_replacement_weights :: [(Integer,a)],
+ _grid_replacement_weights :: WeightedSet a,
_grid_blob :: Blob,
grid_next :: Grid a }
| SpecificPlacementGrid {
@@ -71,7 +83,7 @@ gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) =
gridAt (ArbitraryReplacementGrid seeded sources replacements blob grid) at =
case fmap fst $ find ((== here) . snd) sources of
- Just frequency | (realToFrac (seededLookup seeded at `mod` 100) / 100 < frequency * evalBlob blob at) ->
+ Just frequency | (fromInteger (seededLookup seeded at `mod` 100) / 100 < frequency * evalBlob blob at) ->
fst $ weightedPick replacements (mkRNG $ seededLookup seeded at)
_ -> here
where here = gridAt grid at
@@ -90,17 +102,17 @@ cachedGridOf any_other_grid = CachedGrid $ storableCachedGrid any_other_grid
-- indicates the recursion depth for the generator. The
-- Integer list is the random integer stream used to generate
-- the map.
-generateGrid :: (Ord a) => [(Integer,a)] -> Map (a,a) [(Integer,a)] -> Integer -> [Integer] -> Grid a
+generateGrid :: (Ord a) => WeightedSet a -> Map (a,a) (WeightedSet a) -> Integer -> [Integer] -> Grid a
generateGrid weights _ 0 seeds = let seed = head seeds
in CompletelyRandomGrid (seededGrid seed) weights
generateGrid weights interps n seeds = let seed = head seeds
- in optimizeGrid $ InterpolatedGrid (seededGrid seed) interps $
+ 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) => [(Double,a)] -> [(Integer,a)] -> Integer -> Blob -> Grid a -> Grid a
+arbitraryReplaceGrid :: (Ord a) => [(Double,a)] -> WeightedSet a -> Integer -> Blob -> Grid a -> Grid a
arbitraryReplaceGrid sources replacements seed blob grid = optimizeGrid $
ArbitraryReplacementGrid (seededGrid seed) sources replacements blob grid
@@ -116,10 +128,10 @@ specificReplaceGrid position x grid = specificReplaceGrid position x $ SpecificP
-- 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 }
+optimizeGrid = cachedGridOf {- . stripCache -}
+-- where stripCache (CachedGrid (StorableCachedGrid g _)) = g
+-- 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.
@@ -127,11 +139,11 @@ optimizeGrid = cachedGridOf . stripCache
--
data Blob =
UnitBlob
- | ConeBlob {
- cone_blob_center :: (Double,Double),
- cone_blob_radius :: Double }
+ | 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
+evalBlob (ConeBlob (u,v) r) (x,y) = max 0 $ 1 - (sqrt $ (u-fromInteger x)**2 + (v-fromInteger y)**2) / r
View
2  Roguestar/Lib/HierarchicalDatabase.hs
@@ -1,4 +1,4 @@
-
+-- Services
module Roguestar.Lib.HierarchicalDatabase
(HierarchicalDatabase,
HierarchicalRelation(..),
View
1  Roguestar/Lib/Logging.hs
@@ -1,3 +1,4 @@
+--Services
module Roguestar.Lib.Logging
(initLogging,
log_creature,
View
1  Roguestar/Lib/MakeData.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleInstances #-}
+--Mechanics
module Roguestar.Lib.MakeData
(PrepareMake(..),
prepare_make,
View
3  Roguestar/Lib/Perception.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE ExistentialQuantification, Rank2Types, FlexibleContexts, ScopedTypeVariables, PatternGuards #-}
+--Utility
-- | The Perception monad is a wrapper for roguestar's core
-- monad that reveals only as much information as a character
-- legitimately has. Thus, it is suitable for writing AI
@@ -44,7 +45,7 @@ import Roguestar.Lib.Position as Position
import Roguestar.Lib.TerrainData
import Roguestar.Lib.BuildingData
import Roguestar.Lib.Building
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.DetailedLocation
import Roguestar.Lib.Building
import Roguestar.Lib.SpeciesData
View
1  Roguestar/Lib/PersistantData.hs
@@ -1,3 +1,4 @@
+--Data
module Roguestar.Lib.PersistantData
(CharacterClass(..),
PowerUpData(..),
View
2  Roguestar/Lib/PlaneData.hs
@@ -1,4 +1,4 @@
-
+--Data
module Roguestar.Lib.PlaneData
(Plane(..))
where
View
3  Roguestar/Lib/PlaneVisibility.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE PatternGuards, FlexibleContexts, ScopedTypeVariables, RankNTypes #-}
+--Utility
module Roguestar.Lib.PlaneVisibility
(dbGetVisibleTerrainForFaction,
dbGetVisibleObjectsForFaction)
@@ -9,7 +10,7 @@ import Prelude hiding (getContents)
import Roguestar.Lib.FactionData
import Roguestar.Lib.DB
import Roguestar.Lib.TerrainData
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlaneData
import Control.Monad
import Roguestar.Lib.CreatureData
View
4 Roguestar/Lib/Planet.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE TypeFamilies #-}
-
+--World
module Roguestar.Lib.Planet
(makePlanets,
generatePlanetInfo)
@@ -8,7 +8,7 @@ module Roguestar.Lib.Planet
import Roguestar.Lib.PlanetData
import Roguestar.Lib.PlaneData
import Roguestar.Lib.DB
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.TerrainData
import Control.Monad
import Control.Monad.Random
View
2  Roguestar/Lib/PlanetData.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+--World
module Roguestar.Lib.PlanetData
(PlanetRegion(..),
PlanetInfo(..),
@@ -96,6 +97,7 @@ nonaligned_second_series_planets = [
nonaligned 4 "ocracoke" OceanBiome,
(nonaligned 7 "emerald" GrasslandBiome `removeTown` [basic_stargate]) { planet_info_priority = 100.0 }]
+cyborg_planets :: [PlanetInfo]
cyborg_planets = [
cyber "" TundraBiome,
cyber "" TundraBiome,
View
2  Roguestar/Lib/PlayerState.hs
@@ -1,3 +1,4 @@
+--Data
module Roguestar.Lib.PlayerState
(PlayerState(..),
SnapshotEvent(..),
@@ -7,7 +8,6 @@ module Roguestar.Lib.PlayerState
import Roguestar.Lib.DBData
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.MakeData
import Roguestar.Lib.TravelData
import Roguestar.Lib.PersistantData
View
1  Roguestar/Lib/Position.hs
@@ -1,3 +1,4 @@
+--Data
module Roguestar.Lib.Position
(Position(..),
MultiPosition(..),
View
21 Roguestar/Lib/RNG.hs
@@ -1,3 +1,4 @@
+--Services
-- |
-- Don't depend on any external source of psuedo-random numbers, because
@@ -9,7 +10,8 @@ module Roguestar.Lib.RNG
(mkRNG,
RNG,
Random(..),
- RandomGen(..))
+ RandomGen(..),
+ blurp)
where
import System.Random
@@ -17,17 +19,23 @@ import Control.Arrow (first)
newtype RNG = RNG { rng_state :: Integer }
+k :: Integer
+k = 281474976710656
+
+max_range :: (Integral i) => i
+max_range = 16777216
+
instance RandomGen RNG where
- next g = (fromInteger $ x `quot` (2^24),RNG x)
- where x = (rng_state g * 0x5DEECE66D + 0xB) `mod` (2^48)
+ next g = (fromInteger $ x `quot` max_range,RNG x)
+ where x = (rng_state g * 0x5DEECE66D + 0xB) `mod` k
split g = (mkRNG $ fromIntegral x,mkRNG $ fromIntegral y)
where (x,g') = next g
(y,_) = next g'
- genRange _ = (0,2^24)
+ genRange _ = (0,max_range)
instance Random RNG where
random = first (mkRNG :: Integer -> RNG) . random
- randomR _ = random
+ randomR _ = random
-- |
-- Construct an RNG from a seed.
@@ -35,3 +43,6 @@ instance Random RNG where
mkRNG :: (Integral i) => i -> RNG
mkRNG = RNG . fromIntegral . fst . next . RNG . toInteger
+blurp :: Integer -> Integer
+blurp x = (x * 0x5DEECE66D + 0xB) `mod` k
+
View
61 Roguestar/Lib/Random.hs
@@ -1,7 +1,11 @@
+--Core
module Roguestar.Lib.Random
- (pick,
- pickM,
+ (WeightedSet,
+ weightedSet,
+ unweightedSet,
+ append,
+ fromWeightedSet,
weightedPick,
weightedPickM,
linearRoll,
@@ -13,33 +17,50 @@ module Roguestar.Lib.Random
where
import Data.List
-import Data.Maybe
import System.Random ()
import Control.Monad.Random
import Control.Monad
import Data.Ratio
+import Data.Ord
+import qualified Data.Vector as Vector
--- | Pick an element of a list at random.
-pick :: (RandomGen g) => [a] -> g -> (a,g)
-pick elems = runRand (pickM elems)
+data WeightedSet a = WeightedSet {
+ weighted_set_total :: Integer,
+ weighted_set :: Vector.Vector (Integer,a) }
+ deriving (Read,Show)
+
+weightedSet :: [(Integer,a)] -> WeightedSet a
+weightedSet [] = error "Tried to pick from an empty list."
+weightedSet as = WeightedSet {
+ weighted_set_total = sum $ map fst as,
+ weighted_set = Vector.fromList $ reverse $ sortBy (comparing fst) as }
+
+unweightedSet :: [a] -> WeightedSet a
+unweightedSet [] = error "Tried to pick from an empty list."
+unweightedSet as = WeightedSet {
+ weighted_set_total = genericLength as,
+ weighted_set = Vector.fromList $ map (\x -> (1,x)) as }
+
+append :: WeightedSet a -> WeightedSet a -> WeightedSet a
+append a b = weightedSet $ (Vector.toList $ weighted_set a) ++ (Vector.toList $ weighted_set b)
+
+fromWeightedSet :: WeightedSet a -> [a]
+fromWeightedSet = map snd . Vector.toList . weighted_set
-- | Pick an element of a weighted list at random. E.g. in "[(2,x),(3,y)]" "y" will be picked three times out of five while "x" will be picked 2 times out of five.
-weightedPick :: (RandomGen g) => [(Integer,a)] -> g -> (a,g)
+weightedPick :: (RandomGen g) => WeightedSet a -> g -> (a,g)
weightedPick elems = runRand (weightedPickM elems)
--- | 'pick' in MinadRandom
-pickM :: (MonadRandom m) => [a] -> m a
-pickM elems = weightedPickM (map (\x -> (1,x)) elems)
-
-- | 'weightedPick' in MonadRandom
-weightedPickM :: (MonadRandom m) => [(Integer,a)] -> m a
-weightedPickM [] = error "Tried to pick from an empty list."
-weightedPickM elems =
- do let (weights,values) = unzip elems
- let (weight_total,weight_totals) = mapAccumL (\x y -> (x+y,x+y)) 0 weights
- weight_to_find <- getRandomR (1,weight_total)
- let index = fromJust $ findIndex (\x -> x >= weight_to_find) weight_totals
- return $ values !! index
+weightedPickM :: (MonadRandom m) => WeightedSet a -> m a
+weightedPickM elems =
+ do weight_to_find <- getRandomR (1,weighted_set_total elems)
+ return $ pickWithWeight weight_to_find 0 $ weighted_set elems
+
+pickWithWeight :: Integer -> Int -> Vector.Vector (Integer,a) -> a
+pickWithWeight i ix v = case Vector.unsafeIndex v ix of
+ (x,_) | i > x -> pickWithWeight (i-x) (succ ix) v
+ (_,a) | otherwise -> a
-- | Roll an (n+1) sided die numbered zero to n.
linearRoll :: (MonadRandom m) => Integer -> m Integer
@@ -63,7 +84,7 @@ fixedSumRoll rs a =
--
logRoll :: (MonadRandom m) => Integer -> m Integer
logRoll n = liftM (min n) $ accumRoll 0 n
- where accumRoll c x =
+ where accumRoll c x =
do x' <- linearRoll x
case x' of
0 -> return c
View
13 Roguestar/Lib/Reference.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
+--Data
module Roguestar.Lib.Reference
(ReferenceType(..),
(=:=),
@@ -11,8 +12,6 @@ import Roguestar.Lib.PlaneData
import Roguestar.Lib.BuildingData
import Roguestar.Lib.ToolData
import Roguestar.Lib.CreatureData
-import Data.Either
-import Data.Maybe
--
-- Reference Equality
@@ -51,16 +50,10 @@ instance ReferenceType TheUniverse where
instance (ReferenceType a, ReferenceType b) => ReferenceType (Either a b) where
coerceReference x =
- let -- all of this monstrous let-binding is just to make the typecheck unambiguous
- bind :: Maybe (Reference x) -> x
- bind = undefined
- alike :: a -> a -> Bool
- alike _ _ = True
+ let coerce_left :: Maybe (Reference a)
coerce_left = coerceReference x
+ coerce_right :: Maybe (Reference b)
coerce_right = coerceReference x
- bind_either = either (alike $ bind coerce_left)
- (alike $ bind coerce_right)
- (bind result)
result = case (coerce_left,coerce_right) of
(Just l,_) -> Just $ unsafeReference l
(_,Just r) -> Just $ unsafeReference r
View
13 Roguestar/Lib/Roguestar.hs
@@ -29,9 +29,7 @@ module Roguestar.Lib.Roguestar
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
@@ -40,7 +38,6 @@ import Control.Concurrent.STM
import Control.Monad
import Roguestar.Lib.PlayerState
import Roguestar.Lib.SpeciesData
-import Roguestar.Lib.Random
import Roguestar.Lib.Creature
import Roguestar.Lib.CreatureData
import Roguestar.Lib.BeginGame as BeginGame
@@ -96,7 +93,7 @@ cleanupGameState config game_state =
when needs_cleanup $ writeTVar (game_state_last_cleanup game_state) (game_config_current_clock_time_seconds config)
return needs_cleanup
when needs_cleanup $
- do forkIO $ doCleanup config game_state
+ do _ <- forkIO $ doCleanup config game_state
return ()
doCleanup :: GameConfiguration -> GameState -> IO ()
@@ -111,12 +108,12 @@ doCleanup config game_state =
createGame :: GameConfiguration -> GameState -> IO BS.ByteString
createGame config game_state =
do cleanupGameState config game_state
- uuid <- liftM (BS8.pack . show) V4.uuid
+ new_uuid <- liftM (BS8.pack . show) V4.uuid
g <- newGame config
atomically $
do gs <- readTVar (game_state_gamelist game_state)
- writeTVar (game_state_gamelist game_state) $ Map.insert uuid g gs
- return uuid
+ writeTVar (game_state_gamelist game_state) $ Map.insert new_uuid g gs
+ return new_uuid
retrieveGame :: BS.ByteString -> GameConfiguration -> GameState -> IO (Maybe Game)
retrieveGame uuid config game_state =
@@ -158,7 +155,7 @@ rerollStartingSpecies g =
do writeTVar (game_db g) initial_db
writeTVar (game_message_text g) []
poke g $
- do species <- pickM all_species
+ do species <- weightedPickM $ unweightedSet all_species
generateInitialPlayerCreature BlueRecreant
return species
View
6 Roguestar/Lib/Species.hs
@@ -1,14 +1,12 @@
-
+--Data
module Roguestar.Lib.Species
(SpeciesData(..),
speciesInfo)
where
-import Data.Char
+--Data
import Roguestar.Lib.CreatureData
import Roguestar.Lib.SpeciesData
-import Data.Monoid
-import Roguestar.Lib.TerrainData
data SpeciesData = SpeciesData {
species_traits :: [(CreatureTrait,Integer)] }
View
2  Roguestar/Lib/SpeciesData.hs
@@ -1,8 +1,10 @@
+--Data
module Roguestar.Lib.SpeciesData
(Species(..),
all_species)
where
+--Data
data Species =
BlueRecreant
| RedRecreant
View
6 Roguestar/Lib/Substances.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+--Data
module Roguestar.Lib.Substances
(Gas(..),
Material(..),
@@ -16,12 +17,11 @@ module Roguestar.Lib.Substances
prettySubstance,
gasValue,
chromaliteAlignment,
- chromalitePotency)
+ chromalitePotency,
+ substanceValue)
where
import Roguestar.Lib.Alignment
-import Data.List
-import Data.Ord
import Data.Maybe
import qualified Data.Text as T
View
108 Roguestar/Lib/TerrainData.hs
@@ -1,4 +1,4 @@
-
+--Data
module Roguestar.Lib.TerrainData
(Biome(..),
TerrainPatch(..),
@@ -17,8 +17,7 @@ import Roguestar.Lib.Grids
import Data.List as List
import Data.Map as Map
--import Substances hiding (Water)
-import Roguestar.Lib.RNG
-
+import Roguestar.Lib.Random as Random
-- |
-- Most automatically generated surface maps belong to a Biome, representing the kind of terrain
@@ -76,7 +75,7 @@ data TerrainGenerationData = TerrainGenerationData
data TerrainPlacement = TerrainPlacement {
placement_sources :: [(Double,TerrainPatch)],
- placement_replacements :: [(Integer,TerrainPatch)],
+ placement_replacements :: WeightedSet TerrainPatch,
placement_seed :: Integer,
placement_blob :: Blob }
deriving (Read,Show)
@@ -100,7 +99,7 @@ recreantFactories seed = TerrainPlacement {
(1/100,Forest),
(1/2,RockyGround)],
placement_replacements =
- [(1,RecreantFactory)],
+ unweightedSet [RecreantFactory],
placement_seed = seed,
placement_blob = ConeBlob (0,0) 100 }
@@ -112,7 +111,7 @@ stairsUp seed depth = TerrainPlacement {
(1/(50+10*realToFrac depth),Water),
(1/(75+15*realToFrac depth),RockFace)],
placement_replacements =
- [(1,Upstairs)],
+ unweightedSet [Upstairs],
placement_seed = seed,
placement_blob = UnitBlob }
@@ -125,7 +124,7 @@ stairsDown seed depth = TerrainPlacement {
(1/(40+10*realToFrac depth),Dirt),
(1/60,Grass)],
placement_replacements =
- [(1,Downstairs)],
+ unweightedSet[Downstairs],
placement_seed = seed,
placement_blob = UnitBlob }
@@ -143,54 +142,69 @@ difficult_terrains = impassable_terrains ++
impassable_terrains :: [TerrainPatch]
impassable_terrains = [RockFace,Forest,DeepForest]
-terrainFrequencies :: Biome -> [(Integer,TerrainPatch)]
-terrainFrequencies ShallowDungeon = [(40,RockFace),(50,RockyGround),(5,Sand),(5,Dirt)]
-terrainFrequencies DeepDungeon = [(50,RockFace),(25,Rubble),(25,RockyGround)]
-terrainFrequencies FrozenDungeon = [(75,RockFace),(5,Rubble),(10,RockyGround),(10,Ice)]
-terrainFrequencies AbyssalDungeon = [(60,RockFace),(10,Rubble),(10,RockyGround),(20,Water)]
-terrainFrequencies InfernalDungeon = [(70,RockFace),(15,Rubble),(15,Lava)]
-terrainFrequencies RockBiome = [(15,RockFace),(15,Rubble),(55,RockyGround),(15,Sand)]
-terrainFrequencies IcyRockBiome = [(10,RockFace),(10,Rubble),(20,RockyGround),(60,Ice)]
-terrainFrequencies GrasslandBiome = [(5,RockFace),(5,RockyGround),(10,Dirt),(10,Sand),(10,Forest),(10,Water),(50,Grass)]
-terrainFrequencies ForestBiome = [(10,RockFace),(10,RockyGround),(10,Dirt),(10,Water),(10,Grass),(25,Forest),(25,DeepForest)]
-terrainFrequencies TundraBiome = [(10,RockFace),(10,RockyGround),(10,Sand),(10,Water),(60,Ice)]
-terrainFrequencies DesertBiome = [(10,RockFace),(10,RockyGround),(9,Grass),(1,Water),(70,Desert)]
-terrainFrequencies OceanBiome = [(5,RockyGround),(10,Sand),(5,Grass),(5,Forest),(25,Water),(50,DeepWater)]
-terrainFrequencies MountainBiome = [(50,RockFace),(25,RockyGround),(5,Rubble),(5,Sand),(5,Grass),(5,Forest),(5,Water)]
-terrainFrequencies SwampBiome = [(40,Forest),(50,Water),(5,Sand),(5,Grass)]
-terrainFrequencies PolarBiome = [(40,Ice),(30,Water),(5,DeepWater),(4,RockyGround),(1,RockFace)]
-
-terrainInterpFn :: (TerrainPatch,TerrainPatch) -> [(Integer,TerrainPatch)]
-terrainInterpFn (a,b) = [(1,a),(1,b)] ++ (terrainInterpRule (a,b)) ++ (terrainInterpRule (b,a))
+terrainFrequencies :: Biome -> WeightedSet TerrainPatch
+terrainFrequencies ShallowDungeon =
+ weightedSet [(40,RockFace),(50,RockyGround),(5,Sand),(5,Dirt)]
+terrainFrequencies DeepDungeon =
+ weightedSet [(50,RockFace),(25,Rubble),(25,RockyGround)]
+terrainFrequencies FrozenDungeon =
+ weightedSet [(75,RockFace),(5,Rubble),(10,RockyGround),(10,Ice)]
+terrainFrequencies AbyssalDungeon =
+ weightedSet [(60,RockFace),(10,Rubble),(10,RockyGround),(20,Water)]
+terrainFrequencies InfernalDungeon =
+ weightedSet [(70,RockFace),(15,Rubble),(15,Lava)]
+terrainFrequencies RockBiome =
+ weightedSet [(15,RockFace),(15,Rubble),(55,RockyGround),(15,Sand)]
+terrainFrequencies IcyRockBiome =
+ weightedSet [(10,RockFace),(10,Rubble),(20,RockyGround),(60,Ice)]
+terrainFrequencies GrasslandBiome =
+ weightedSet [(5,RockFace),(5,RockyGround),(10,Dirt),(10,Sand),(10,Forest),(10,Water),(50,Grass)]
+terrainFrequencies ForestBiome =
+ weightedSet [(10,RockFace),(10,RockyGround),(10,Dirt),(10,Water),(10,Grass),(25,Forest),(25,DeepForest)]
+terrainFrequencies TundraBiome =
+ weightedSet [(10,RockFace),(10,RockyGround),(10,Sand),(10,Water),(60,Ice)]
+terrainFrequencies DesertBiome =
+ weightedSet [(10,RockFace),(10,RockyGround),(9,Grass),(1,Water),(70,Desert)]
+terrainFrequencies OceanBiome =
+ weightedSet [(5,RockyGround),(10,Sand),(5,Grass),(5,Forest),(25,Water),(50,DeepWater)]
+terrainFrequencies MountainBiome =
+ weightedSet [(50,RockFace),(25,RockyGround),(5,Rubble),(5,Sand),(5,Grass),(5,Forest),(5,Water)]
+terrainFrequencies SwampBiome =
+ weightedSet [(40,Forest),(50,Water),(5,Sand),(5,Grass)]
+terrainFrequencies PolarBiome =
+ weightedSet [(40,Ice),(30,Water),(5,DeepWater),(4,RockyGround),(1,RockFace)]
+
+terrainInterpFn :: (TerrainPatch,TerrainPatch) -> WeightedSet TerrainPatch
+terrainInterpFn (a,b) = weightedSet [(1,a),(1,b)] `Random.append` terrainInterpRule (a,b) `Random.append` terrainInterpRule (b,a)
-- Notice, in terrainInterpFn, we always throw in both terrain patches with a weight of 1.
-terrainInterpRule :: (TerrainPatch,TerrainPatch) -> [(Integer,TerrainPatch)]
-terrainInterpRule (RockFace,RockFace) = []
-terrainInterpRule (RockFace,RockyGround) = [(3,RockFace),(1,Rubble),(3,RockyGround)]
-terrainInterpRule (RockFace,x) = [(3,RockFace),(2,Rubble),(1,RockyGround),(1,Sand),(7,x)]
-terrainInterpRule (Rubble,x) = [(1,Rubble),(2,Sand),(2,Dirt),(5,x)]
-terrainInterpRule (DeepWater,DeepWater) = []
-terrainInterpRule (DeepWater,Water) = [(3,DeepWater)]
-terrainInterpRule (DeepWater,_) = [(3,Water)]
-terrainInterpRule (DeepForest,DeepForest) = [(1,Grass)]
-terrainInterpRule (DeepForest,Forest) = [(2,Grass)]
-terrainInterpRule (DeepForest,_) = [(1,Forest)]
-terrainInterpRule (Forest,DeepForest) = []
-terrainInterpRule (Forest,Forest) = [(3,Grass)]
-terrainInterpRule (Forest,_) = [(3,Grass)]
-terrainInterpRule (Water,Water) = [(20,Water),(1,Sand)]
-terrainInterpRule (Water,DeepWater) = []
-terrainInterpRule (Water,_) = [(1,Sand)]
-terrainInterpRule (Sand,Desert) = [(1,Grass),(1,Forest)]
-terrainInterpRule _ = []
+terrainInterpRule :: (TerrainPatch,TerrainPatch) -> WeightedSet TerrainPatch
+terrainInterpRule (RockFace,RockFace) = unweightedSet [RockFace]
+terrainInterpRule (RockFace,RockyGround) = weightedSet [(3,RockFace),(1,Rubble),(3,RockyGround)]
+terrainInterpRule (RockFace,x) = weightedSet [(3,RockFace),(2,Rubble),(1,RockyGround),(1,Sand),(7,x)]
+terrainInterpRule (Rubble,x) = weightedSet [(1,Rubble),(2,Sand),(2,Dirt),(5,x)]
+terrainInterpRule (DeepWater,DeepWater) = unweightedSet [DeepWater]
+terrainInterpRule (DeepWater,Water) = weightedSet [(3,DeepWater)]
+terrainInterpRule (DeepWater,_) = weightedSet [(3,Water)]
+terrainInterpRule (DeepForest,DeepForest) = weightedSet [(1,Grass)]
+terrainInterpRule (DeepForest,Forest) = weightedSet [(2,Grass)]
+terrainInterpRule (DeepForest,_) = weightedSet [(1,Forest)]
+terrainInterpRule (Forest,DeepForest) = unweightedSet [Forest,DeepForest]
+terrainInterpRule (Forest,Forest) = weightedSet [(3,Grass)]
+terrainInterpRule (Forest,_) = weightedSet [(3,Grass)]
+terrainInterpRule (Water,Water) = weightedSet [(20,Water),(1,Sand)]
+terrainInterpRule (Water,DeepWater) = unweightedSet [Water,DeepWater]
+terrainInterpRule (Water,_) = weightedSet [(1,Sand)]
+terrainInterpRule (Sand,Desert) = weightedSet [(1,Grass),(1,Forest)]
+terrainInterpRule (a,b) = unweightedSet [a,b]
-- |
-- A list of every TerrainPatch that might be created from the terrainFrequencies function.
--
baseTerrainPatches :: [TerrainPatch]
-baseTerrainPatches = nub $ List.map snd $ concatMap terrainFrequencies [minBound..maxBound]
+baseTerrainPatches = nub $ concatMap (fromWeightedSet . terrainFrequencies) [minBound..maxBound]
-terrainInterpMap :: Map (TerrainPatch,TerrainPatch) [(Integer,TerrainPatch)]
+terrainInterpMap :: Map (TerrainPatch,TerrainPatch) (WeightedSet TerrainPatch)
terrainInterpMap = let terrain_patch_pairs = [(a,b) | a <- baseTerrainPatches, b <- baseTerrainPatches]
interps = List.map terrainInterpFn terrain_patch_pairs
in fromList (zip terrain_patch_pairs interps)
View
8 Roguestar/Lib/Tests.hs
@@ -1,4 +1,4 @@
-
+--Deprecated
module Roguestar.Lib.Tests
(TestResult(..),
TestCase,
@@ -38,6 +38,6 @@ test str False = return $ Failed str
runAllTests :: [TestCase] -> IO Bool
runAllTests [] = do return True
runAllTests (testCase:testCases) = do testResult <- testCase
- putStrLn (show testResult)
- testResults <- runAllTests testCases
- return (testResults && testResultToBool testResult)
+ putStrLn (show testResult)
+ testResults <- runAllTests testCases
+ return (testResults && testResultToBool testResult)
View
1  Roguestar/Lib/TimeCoordinate.hs
@@ -1,3 +1,4 @@
+--Data -- this module is dubious, may deprecate
module Roguestar.Lib.TimeCoordinate
(TimeCoordinate,
advanceTime,
View
4 Roguestar/Lib/Tool.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
-
+--Core
module Roguestar.Lib.Tool
(pickupTool,
wieldTool,
@@ -20,7 +20,7 @@ import Data.Maybe
import Data.List as List
import Roguestar.Lib.ToolData
import Roguestar.Lib.Substances
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Roguestar.Lib.PlaneData
pickupTool :: (DBReadable db) =>
View
2  Roguestar/Lib/ToolData.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
+
+--Data
module Roguestar.Lib.ToolData
(Tool(..),
toolName,
View
6 Roguestar/Lib/Town.hs
@@ -1,17 +1,17 @@
+--World
module Roguestar.Lib.Town
(createTown)
where
import Roguestar.Lib.BuildingData
import Roguestar.Lib.DB
-import Roguestar.Lib.TerrainData
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Utility.SiteCriteria
-- | Create a town from a list of buildings.
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 1 (clear_need*2+1) (clear_need+1) (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
+ p <- pickRandomSite (-100,100) (-100,100) 100 [areaClearForObjectPlacement clear_need, closeTo $ Position (0,0)] plane_ref
let the_building = Building {
building_behavior = buildingproto_behavior building_prototype,
building_signal = buildingproto_signal building_prototype }
View
2  Roguestar/Lib/TravelData.hs
@@ -1,4 +1,4 @@
-
+--Data
module Roguestar.Lib.TravelData
(ClimbDirection(..)) where
View
10 Roguestar/Lib/Turns.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
-
+--Mechanics
module Roguestar.Lib.Turns
(dbPerformPlayerTurn)
where
@@ -12,7 +12,7 @@ import Roguestar.Lib.Reference
import Roguestar.Lib.FactionData
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.CreatureData (Creature)
-import Roguestar.Lib.Plane
+import Roguestar.Lib.Core.Plane
import Control.Monad
import Roguestar.Lib.Creature
import Data.Ratio
@@ -79,7 +79,7 @@ dbPerform1PlanarAITurn 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 * 3) $
- do (terrain_type,species) <- pickM monster_spawns
+ do (terrain_type,species) <- weightedPickM $ unweightedSet monster_spawns
_ <- spawnNPC terrain_type species plane_ref $ map detail $ player_locations
return ()
dbAdvanceTime plane_ref (1%planar_turn_frequency)
@@ -91,7 +91,7 @@ dbPerform1PlanarAITurn plane_ref =
spawnNPC :: TerrainPatch -> Species -> PlaneRef -> [Position] -> DB Bool
spawnNPC terrain_type species plane_ref player_locations =
do logDB log_turns INFO $ "spawnNPC; Spawning an NPC"
- p <- pickM player_locations
+ p <- weightedPickM $ unweightedSet player_locations
m_spawn_position <- pickRandomClearSite_withTimeout (Just 2) 7 0 0 p (== terrain_type) plane_ref
case m_spawn_position of
Nothing -> return False
@@ -113,7 +113,7 @@ dbPerform1CreatureAITurn creature_ref =
-- FIXME: what if there is more than one player
player_position <- MaybeT $ return $ listToMaybe visible_player_locations
(rand_x :: Integer) <- lift $ getRandomR (1,100)
- rand_face <- lift $ pickM [minBound..maxBound]
+ rand_face <- lift $ weightedPickM $ unweightedSet [minBound..maxBound]
(_,my_position) <- lift P.whereAmI
let face_to_player = faceAt my_position player_position
return $ case distanceBetweenChessboard my_position player_position of
View
46 Roguestar/Lib/UnitTests.hs
@@ -7,10 +7,14 @@ import Control.Monad.Writer.Lazy as W
import Roguestar.Lib.Roguestar
import Data.Maybe
import Control.Concurrent
-import Data.Monoid
import System.IO
import Roguestar.Lib.DB
import Roguestar.Lib.PlayerState
+import Control.Monad.Reader.Class
+import Roguestar.Lib.Core.Plane
+import Roguestar.Lib.TerrainData
+import Roguestar.Lib.Utility.SiteCriteria
+import Control.Monad.Random
type UnitTest = WriterT (T.Text,All) IO ()
@@ -22,7 +26,9 @@ runTests =
unit_tests :: [UnitTest]
unit_tests = [testSessionAliveBeforeTimeout,
testSessionExpiredAfterTimeout,
- testSetPlayerState]
+ testSetPlayerState,
+ testLocal,
+ testPickRandomClearSite]
assert :: Bool -> T.Text -> UnitTest
assert ok test_name =
@@ -41,6 +47,19 @@ assertEqual actual expected test_name =
tell (message, All ok)
liftIO $ hPutStr stderr $ T.unpack message
+-- Generate N random planes and run tests against them.
+runWithRandomPlanes :: Int -> T.Text -> (PlaneRef -> DB Bool) -> UnitTest
+runWithRandomPlanes n test_name db_action = forM_ [1..n] $ \x ->
+ do b <- liftIO $ runDB (runWithRandomPlane_ db_action) initial_db
+ assert (either (const False) fst b) (test_name `T.append` "#" `T.append` T.pack (show x))
+
+runWithRandomPlane_ :: (PlaneRef -> DB Bool) -> DB Bool
+runWithRandomPlane_ dbAction =
+ do biome <- weightedPickM $ unweightedSet [minBound..maxBound]
+ plane_ref <- dbNewPlane "testPlane" (TerrainGenerationData 3 biome []) TheUniverse
+ dbAction plane_ref
+
+{-- UNIT TESTS BEGIN HERE --}
testSessionAliveBeforeTimeout :: UnitTest
testSessionAliveBeforeTimeout =
do game_state <- liftIO $ createGameState (GameConfiguration 10 0)
@@ -66,3 +85,26 @@ testSetPlayerState =
case m_pstate of
Left err -> assert False "testSetPlayerState (failed in monad)"
Right (pstate,_) -> assertEqual pstate (GameOver PlayerIsVictorious) "testSetPlayerState"
+
+testLocal :: UnitTest
+testLocal =
+ do m_pstate <- liftIO $ flip runDB initial_db $
+ do local id $ setPlayerState (GameOver PlayerIsVictorious)
+ playerState
+ case m_pstate of
+ Left err -> assert False "testLocal (failed in monad)"
+ Right (pstate,_) -> assertEqual pstate (SpeciesSelectionState Nothing) "testLocal"
+
+testPickRandomClearSite :: UnitTest
+testPickRandomClearSite = runWithRandomPlanes 10 "testPickRandomClearSite" $ \plane_ref ->
+ do Position (x,y) <- pickRandomSite (-1000,100) (-1000,100) 50 (areaClearForObjectPlacement 1) plane_ref
+ t1 <- terrainAt plane_ref $ Position (x-1,y-1)
+ t2 <- terrainAt plane_ref $ Position (x,y-1)
+ t3 <- terrainAt plane_ref $ Position (x+1,y-1)
+ t4 <- terrainAt plane_ref $ Position (x-1,y)
+ t5 <- terrainAt plane_ref $ Position (x,y)
+ t6 <- terrainAt plane_ref $ Position (x+1,y)
+ t7 <- terrainAt plane_ref $ Position (x-1,y+1)
+ t8 <- terrainAt plane_ref $ Position (x,y+1)
+ t9 <- terrainAt plane_ref $ Position (x+1,y+1)
+ return $ Prelude.all (not . (`elem` difficult_terrains)) [t1,t2,t3,t4,t5,t6,t7,t8,t9]
View
89 Roguestar/Lib/Utility/SiteCriteria.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Roguestar.Lib.Utility.SiteCriteria
+ (SiteCriteria(..),
+ SimpleSiteCriteria,
+ areaClearForObjectPlacement,
+ onTerrainType,
+ closeTo,
+ atDistanceFrom,
+ pickRandomSite)
+ where
+
+import Data.Ord
+import Data.List as List
+import Roguestar.Lib.Core.Plane
+import Roguestar.Lib.DB
+import Roguestar.Lib.TerrainData
+import Control.Monad
+import Control.Monad.Random
+
+-- |
+-- Criteria for randomly choosing sites to place things on a plane.
+-- As a simple example, a building should randomly put on a site where there are not already any buildings.
+class SiteCriteria a where
+ testSiteCriteria :: (DBReadable db) => PlaneRef -> Position -> a -> db Double
+
+data SimpleSiteCriteria =
+ TerrainClear { _terrain_clear_radius :: Integer,
+ _terrain_clear_test :: TerrainPatch -> Bool } |
+ ObjectClear { _object_clear_radius :: Integer } |
+ AtDistanceFrom { _at_distance_from_center :: Position,
+ _at_distance :: Integer } |
+ forall a. SiteCriteria a => RequireAtLeast { require_at_least :: Double, require_at_least_criteria :: a }
+
+instance SiteCriteria SimpleSiteCriteria where
+ testSiteCriteria plane_ref (Position (x,y)) (TerrainClear radius testF) =
+ do let ps = [Position (x',y') | x' <- [x-radius..x+radius], y' <- [y-radius..y+radius]]
+ p_count = realToFrac $ length ps
+ liftM sum $ forM ps $ \p ->
+ do t <- terrainAt plane_ref p
+ case testF t of
+ True -> return $ 1/p_count
+ False -> return $ -1/p_count
+ testSiteCriteria plane_ref (Position (x,y)) (ObjectClear radius) =
+ do let ps = [Position (x',y') | x' <- [x-radius..x+radius], y' <- [y-radius..y+radius]]
+ p_count = realToFrac $ length ps
+ liftM sum $ forM ps $ \p ->
+ do o <- whatIsOccupying plane_ref p
+ case o of
+ [] -> return $ 1/p_count
+ _ -> return $ -1/p_count
+ testSiteCriteria _ (Position (x,y)) (AtDistanceFrom (Position (x',y')) distance) = return $ 1.0 / (abs $ sqrt (fromInteger ((x-x')^2 + (y-y')^2)) - fromInteger distance)
+ testSiteCriteria plane_ref p require@(RequireAtLeast { require_at_least_criteria = criteria }) =
+ do result <- testSiteCriteria plane_ref p criteria
+ case result > require_at_least require of
+ False -> return $ result-1e6
+ True -> return result
+
+-- SiteCriteria that requires a radius in which there should be no other buildings, objects, or impassable terrain.
+areaClearForObjectPlacement :: Integer -> SimpleSiteCriteria
+areaClearForObjectPlacement radius = RequireAtLeast 0.999 $ [TerrainClear radius (not . (`elem` difficult_terrains)), ObjectClear radius]
+
+-- SiteCriteria that requires the found site to exactly match the specified type of terrain patch.
+onTerrainType :: TerrainPatch -> SimpleSiteCriteria
+onTerrainType terrain = RequireAtLeast 0 $ TerrainClear 0 (== terrain)
+
+-- SiteCriteria that tries to get as close to the specified position as possible.
+closeTo :: Position -> SimpleSiteCriteria
+closeTo p = AtDistanceFrom p 0
+
+-- SiteCriteria that tries to get at a specific distance from the specified position.
+atDistanceFrom :: Position -> Integer -> SimpleSiteCriteria
+atDistanceFrom p d = AtDistanceFrom p d
+
+instance SiteCriteria a => SiteCriteria [a] where
+ testSiteCriteria plane_ref p xs = liftM sum $ mapM (testSiteCriteria plane_ref p) xs
+
+pickRandomSite :: (DBReadable db, SiteCriteria a) => (Integer,Integer) -> (Integer,Integer) -> Integer -> a -> PlaneRef -> db Position
+pickRandomSite east_west north_south tryhard site_criteria plane_ref =
+ do liftM pickBest $ forM [1.. fromInteger tryhard] $ const generateOption
+ where pickBest :: [(Double,Position)] -> Position
+ pickBest = snd . maximumBy (comparing fst)
+ generateOption :: (DBReadable db) => db (Double,Position)
+ generateOption =
+ do x <- getRandomR east_west
+ y <- getRandomR north_south
+ let p = Position (x,y)
+ fitness <- testSiteCriteria plane_ref p site_criteria
+ return (fitness,p)
+
View
6 Roguestar/Lib/VisibilityData.hs
@@ -1,4 +1,4 @@
-
+--Data
module Roguestar.Lib.VisibilityData
(distanceCostForSight,
terrainHideMultiplier,
@@ -63,8 +63,8 @@ terrainOpacity Upstairs = 0
distanceCostForSight :: Facing -> (Integer,Integer) -> Integer
distanceCostForSight facing (x,y) =
let (xface,yface) = facingToRelative facing
- (x',y') = (x-xface,y-yface)
- in (x*x' + y*y')
+ (x',y') = (x-xface,y-yface)
+ in (x*x' + y*y')
-- |
-- The maximum distance from any point that a creature with that spot check could see anything,
View
6 Roguestar/Server/Main.hs
@@ -262,14 +262,14 @@ inventoryAction tool_ref (action_name,css_class,action_path) =
reroll :: PlayerState -> Handler App App ()
reroll (SpeciesSelectionState _) =
do g <- getGame
- liftIO $ rerollStartingSpecies g
+ _ <- liftIO $ rerollStartingSpecies g
replay
reroll _ = pass
accept :: PlayerState -> Handler App App ()
accept (SpeciesSelectionState (Just _)) =
do g <- getGame
- liftIO $ beginGame g
+ _ <- liftIO $ beginGame g
replay
accept _ = pass
@@ -386,7 +386,7 @@ data MapData = MapData {
generateMapContent :: Handler App App Aeson.Value
generateMapContent =
- do let (x,y) = (21,21) --we'll probably want to let the player customize this later
+ do let (x,y) = (13,13) --we'll probably want to let the player customize this later
g <- getGame
player_state <- oops $ liftIO $ getSnapshotPlayerState g
map_data <- oops $ liftIO $ perceiveSnapshot g $
View
11 roguestar.cabal
@@ -29,7 +29,7 @@ executable roguestar-server
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
if impl(ghc >= 7.0)
- ghc-options: -threaded -fno-warn-type-defaults -rtsopts=all
+ ghc-options: -threaded -rtsopts=all -Wall -fno-warn-type-defaults
else
ghc-options: -threaded -fno-warn-type-defaults
other-modules: Roguestar.Lib.HTML.Mustache
@@ -53,7 +53,9 @@ library
old-time >=1.0.0.3,
array >=0.3.0.0,
containers >=0.3.0.0,
- base >=4
+ base >=4,
+ mwc-random >= 0.12.0.1,
+ streams >= 0.8.2
other-modules: Roguestar.Lib.TravelData,
Roguestar.Lib.VisibilityData,
Roguestar.Lib.FactionData,
@@ -64,7 +66,8 @@ library
Roguestar.Lib.Perception,
Roguestar.Lib.PlaneVisibility,
Roguestar.Lib.Turns,
- Roguestar.Lib.Plane,
+ Roguestar.Lib.Core.Plane,
+ Roguestar.Lib.Utility.SiteCriteria,
Roguestar.Lib.CreatureData,
Roguestar.Lib.Character,
Roguestar.Lib.Tool,
@@ -107,7 +110,7 @@ library
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
if impl(ghc >= 7.0)
- ghc-options: -threaded -fno-warn-type-defaults -rtsopts=all
+ ghc-options: -threaded -rtsopts=all -Wall -fno-warn-type-defaults
else
ghc-options: -threaded -fno-warn-type-defaults
exposed-modules: Roguestar.Lib.UnitTests,
View
BIN  static/faded-bead.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
View
BIN  static/faded-bead.xcf
Binary file not shown
View
BIN  static/glass-bead-bright.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
View
BIN  static/glass-bead-bright.xcf
Binary file not shown
View
BIN  static/glass-bead.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
View
BIN  static/glass-bead.xcf
Binary file not shown
View
BIN  static/glass-vertical.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
View
BIN  static/glass-vertical.xcf
Binary file not shown
View
6 static/play.mustache
@@ -6,7 +6,9 @@
{{#map}}
<div id="gameplaybox" class="roguebox">
{{> map}}
- <a href="/help-map" class="help">?</a>
+</div>
+<div id="gameplaybox-overlay">
+<a href="/help-map" id="help-map" class="help">?</a>
</div>
{{/map}}
@@ -62,7 +64,7 @@
</form>
{{/is-snapshot}}
-<a href="/help-actions" class="help">?</a>
+<a href="/help-actions" id="help-actions" class="help">?</a>
</form>
View
98 static/roguebasic.css
@@ -2,7 +2,7 @@
body {
padding: 0px;
margin: 0px;
- font-family: monospace;
+ font-family: "Verdana", sans-serif;
background: #000000;
color: #EEEEEE;
}
@@ -23,6 +23,9 @@ body {
margin-top: 1em;
margin-bottom: 1em;
width: 1024px;
+ background-image: url('/static/glass-vertical.png');
+ background-repeat: repeat-x;
+ background-position: center center;
}
#menu ul {
@@ -273,7 +276,6 @@ a:hover {
padding-right: 1.62in;
margin: 0;
margin-bottom: 1em;
- font-family: "Georgia", serif;
color: #BBBBBB;
}
@@ -287,6 +289,19 @@ a:hover {
background: #000000;
}
+#gameplaybox-overlay {
+ overflow: hidden;
+ position: absolute;
+ left: 1px;
+ top: 1px;
+ width: 500px;
+ height: 500px;
+ background-image: url('/static/glass-vertical.png');
+ background-repeat: repeat-x;
+ background-position: center center;
+ z-index: 10;
+}
+
.mapcontent {
font-size: 12pt;
text-align: center;
@@ -294,24 +309,47 @@ a:hover {
}
.mapcontent span {
+ font-family: monospace;
+ font-size: 14pt;
text-align: center;
- margin-left: 3.25pt;
- margin-right: 3.25pt;
-}
-
-#gameplaybox .help {
+ margin: 0px;
+ display: inline-block;
+ width: 32px;
+ line-height: 32px;
+ height: 32px;
+ border: solid;
+ border-color: black;
+ border-width: 1px;
+ background-image: url('/static/faded-bead.png');
+}
+
+#help-map {
position: absolute;
left: 476px;
top: 10px;
+ z-index: 20;
}
#messagebox {
+ font-family: monospace;
overflow: auto;
position: absolute;
+ padding: 0px;
left: 0px;
top: 504px;
- height: 96px;
+ height: 95px;
width: 1024px;
+ background: #000000;
+ background-image: url('/static/glass-vertical.png');
+ background-repeat: repeat-x;
+ background-position: center center;
+}
+
+#messagebox p {
+ line-height: 19px;
+ height: 19px;
+ margin: 0px;
+ padding: 0px;
}
#controls {
@@ -321,9 +359,13 @@ a:hover {
top: 0px;
height: 500px;
width: 520px;
+ background: #000000;
+ background-image: url('/static/glass-vertical.png');
+ background-repeat: repeat-x;
+ background-position: center center;
}
-#controls .help {
+#help-actions {
position: absolute;
left: 496px;
top: 10px;