Adds fast random number generator and SiteCriteria.

parent 155ef038
......@@ -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
......
{-# 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)
......@@ -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"
......@@ -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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment