Skip to content
Browse files

Fix issue with terrain generator / random number generation, make up …

…and down stairwells more common.
  • Loading branch information...
1 parent 5a7b753 commit aef92973fa3378403a10397295158c4e083833c8 @clanehin committed Jan 27, 2011
Showing with 28 additions and 28 deletions.
  1. +14 −14 roguestar-engine/src/Grids.hs
  2. +5 −4 roguestar-engine/src/Plane.hs
  3. +9 −10 roguestar-engine/src/TerrainData.hs
View
28 roguestar-engine/src/Grids.hs
@@ -31,8 +31,8 @@ seededGrid n = SeededGrid n
seededLookup :: SeededGrid -> (Integer,Integer) -> Integer
seededLookup (SeededGrid n) (x,y) = toInteger $ fst $ next $ mkRNG $
- (fst $ next $ mkRNG (fromInteger $ x `mod` max_int)) +
- (fst $ next $ mkRNG (fromInteger $ y `mod` max_int)) +
+ (fst $ next $ mkRNG (fromInteger $ (x*809) `mod` max_int)) +
+ (fst $ next $ mkRNG (fromInteger $ (y*233) `mod` max_int)) +
(fromInteger $ n `mod` max_int)
where max_int = toInteger (maxBound :: Int)
@@ -56,19 +56,19 @@ data Grid a = CompletelyRandomGrid {
gridAt :: (Ord a) => Grid a -> (Integer,Integer) -> a
gridAt (CompletelyRandomGrid seeded weights) at = fst $ weightedPick weights (mkRNG $ seededLookup seeded at)
-gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) =
+gridAt (InterpolatedGrid seeded interpolation_map grid) at@(x,y) =
let here = gridAt grid (x `div` 2,y `div` 2)
- there = gridAt grid (x `div` 2 + 1,y `div` 2 + 1)
- there_x = gridAt grid (x `div` 2 + 1,y `div` 2)
- there_y = gridAt grid (x `div` 2,y `div` 2 + 1)
- interpolate a1 a2 = fst $ weightedPick (interpolation_map ! (a1,a2)) (mkRNG $ seededLookup seeded at)
- in case (even x,even y) of
- (True,True) -> here
- (True,False) -> (interpolate here there_y)
- (False,True) -> (interpolate here there_x)
- (False,False) -> (interpolate here there)
-
-gridAt (ArbitraryReplacementGrid seeded sources replacements grid) at =
+ there = gridAt grid (x `div` 2 + 1,y `div` 2 + 1)
+ there_x = gridAt grid (x `div` 2 + 1,y `div` 2)
+ there_y = gridAt grid (x `div` 2,y `div` 2 + 1)
+ interpolate a1 a2 = fst $ weightedPick (interpolation_map ! (a1,a2)) (mkRNG $ seededLookup seeded at)
+ in case (even x,even y) of
+ (True,True) -> here
+ (True,False) -> (interpolate here there_y)
+ (False,True) -> (interpolate here there_x)
+ (False,False) -> (interpolate here there)
+
+gridAt (ArbitraryReplacementGrid seeded sources replacements grid) at =
case fmap fst $ find ((== here) . snd) sources of
Just frequency | (seededLookup seeded at `mod` denominator frequency < numerator frequency) ->
fst $ weightedPick replacements (mkRNG $ seededLookup seeded at)
View
9 roguestar-engine/src/Plane.hs
@@ -109,14 +109,15 @@ dbGetCurrentPlane = liftM (fmap parent) $ maybe (return Nothing) getPlanarPositi
-- only appropriate terrain (as defined by a predicate) within terrain_clear squares.
-- Distance is chessboard distance.
--
--- This function will expand the search radius liberally if encounters the slightest
+-- This function will gradually expand the search radius if encounters the slightest
-- difficulty finding a qualifying position. The search radius parameter is strictly advisory.
--
-- This function can take an optional timeout parameter (pickRandomClearSite_withTimeout). When used
-- without a timeout parameter, it may not terminate. The only possible cause of non-termination is that no
--- site satisfies the terrain predicate.
+-- site satisfies the terrain predicate. However, if satisfactory sites are sufficiently rare,
+-- extreme slowness is likely.
--
--- The timeout value should be a small integer greater or equal to one, since this function is exponential in the timeout value.
+-- The timeout value should be a small integer greater or equal to one, since this function becomes slow with large timeout values.
--
pickRandomClearSite :: (DBReadable db) =>
Integer -> Integer -> Integer ->
@@ -163,7 +164,7 @@ pickRandomClearSite_withTimeout timeout search_radius object_clear terrain_clear
return $ Just result
Nothing -> pickRandomClearSite_withTimeout
(fmap (subtract 1) timeout)
- (search_radius*2 + 1)
+ (search_radius + 1)
object_clear
(max 0 $ terrain_clear - 1)
(Position (start_x,start_y))
View
19 roguestar-engine/src/TerrainData.hs
@@ -105,21 +105,20 @@ recreantFactories seed = TerrainPlacement {
stairsUp :: Integer -> Integer -> TerrainPlacement
stairsUp seed depth = TerrainPlacement {
placement_sources =
- [(1%(30+15*depth),RockyGround),
- (1%(30+25*depth),Ice)],
+ [(1%(15+3*depth),RockyGround),
+ (1%(25+5*depth),Ice),
+ (1%(50+10*depth),Water),
+ (1%(75+15*depth),RockFace)],
placement_replacements =
[(1,Upstairs)],
placement_seed = seed }
stairsDown :: Integer -> Integer -> TerrainPlacement
stairsDown seed depth = TerrainPlacement {
placement_sources =
- [(1%(30+15*depth),RockyGround),
- (1%(30+25*depth),Ice),
- (1%100,Grass),
- (1%200,Dirt),
- (1%50,Forest),
- (1%500,Glass)],
+ [(1%(15+3*depth),RockyGround),
+ (1%(25+5*depth),Ice),
+ (1%(75+15*depth),RockFace)],
placement_replacements =
[(1,Downstairs)],
placement_seed = seed }
@@ -185,8 +184,8 @@ baseTerrainPatches = nub $ List.map snd $ concatMap terrainFrequencies [minBound
terrainInterpMap :: Map (TerrainPatch,TerrainPatch) [(Integer,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)
+ interps = List.map terrainInterpFn terrain_patch_pairs
+ in fromList (zip terrain_patch_pairs interps)
type TerrainGrid = Grid TerrainPatch

0 comments on commit aef9297

Please sign in to comment.
Something went wrong with that request. Please try again.