Permalink
Browse files

Adds fast random number generator and SiteCriteria.

  • Loading branch information...
1 parent 155ef03 commit 8e5142ab8131ea8f95d85848d73e80063b522efa @clanehin committed Oct 22, 2012
Showing with 130 additions and 34 deletions.
  1. +27 −24 Roguestar/Lib/DB.hs
  2. +85 −6 Roguestar/Lib/Plane.hs
  3. +14 −1 Roguestar/Lib/UnitTests.hs
  4. +4 −3 roguestar.cabal
View
@@ -63,7 +63,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 +71,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 +80,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 +108,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 256
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 +147,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 +174,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 +246,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 +272,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
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, PatternGuards, TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, PatternGuards, TypeFamilies, ExistentialQuantification #-}
module Roguestar.Lib.Plane
(dbNewPlane,
planetName,
@@ -15,7 +15,14 @@ module Roguestar.Lib.Plane
setTerrainAt,
whatIsOccupying,
isTerrainPassable,
- getBiome)
+ getBiome,
+ SiteCriteria(..),
+ SimpleSiteCriteria,
+ areaClearForObjectPlacement,
+ onTerrainType,
+ closeTo,
+ atDistanceFrom,
+ pickRandomSite)
where
import Prelude hiding (getContents)
@@ -26,7 +33,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
@@ -41,6 +47,8 @@ import Roguestar.Lib.BuildingData
import Roguestar.Lib.Logging
import Control.Monad.Maybe
import Control.Monad.Trans
+import Data.Ord
+import qualified Data.Vector.Unboxed as Vector
dbNewPlane :: (LocationConstructor l, ReferenceTypeOf l ~ Plane) => B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef
dbNewPlane name tg_data l =
@@ -109,9 +117,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
@@ -222,3 +228,76 @@ isTerrainPassable plane_ref creature_ref position =
getBiome :: (DBReadable db) => PlaneRef -> db Biome
getBiome = liftM plane_biome . dbGetPlane
+
+-- |
+-- 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 plane_ref (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 xs <- uniformVector (fromInteger tryhard) (0, fromInteger $ snd north_south - fst north_south)
+ ys <- uniformVector (fromInteger tryhard) (0, fromInteger $ snd east_west - fst east_west)
+ liftM pickBest $ forM [1.. fromInteger tryhard] (generateOption xs ys)
+ where pickBest :: [(Double,Position)] -> Position
+ pickBest = snd . maximumBy (comparing fst)
+ generateOption :: (DBReadable db) => Vector.Vector Int -> Vector.Vector Int -> Int -> db (Double,Position)
+ generateOption xs ys i =
+ do let x = toInteger (Vector.unsafeIndex xs i) + fst north_south
+ y = toInteger (Vector.unsafeIndex ys i) + snd north_south
+ let p = Position (x,y)
+ fitness <- testSiteCriteria plane_ref p site_criteria
+ return (fitness,p)
+
View
@@ -11,6 +11,7 @@ import Data.Monoid
import System.IO
import Roguestar.Lib.DB
import Roguestar.Lib.PlayerState
+import Control.Monad.Reader.Class
type UnitTest = WriterT (T.Text,All) IO ()
@@ -22,7 +23,8 @@ runTests =
unit_tests :: [UnitTest]
unit_tests = [testSessionAliveBeforeTimeout,
testSessionExpiredAfterTimeout,
- testSetPlayerState]
+ testSetPlayerState,
+ testLocal]
assert :: Bool -> T.Text -> UnitTest
assert ok test_name =
@@ -66,3 +68,14 @@ 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"
+
+
View
@@ -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 -fno-warn-type-defaults -rtsopts=all -Wall
else
ghc-options: -threaded -fno-warn-type-defaults
other-modules: Roguestar.Lib.HTML.Mustache
@@ -53,7 +53,8 @@ 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
other-modules: Roguestar.Lib.TravelData,
Roguestar.Lib.VisibilityData,
Roguestar.Lib.FactionData,
@@ -107,7 +108,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 -fno-warn-type-defaults -rtsopts=all -Wall
else
ghc-options: -threaded -fno-warn-type-defaults
exposed-modules: Roguestar.Lib.UnitTests,

0 comments on commit 8e5142a

Please sign in to comment.