Skip to content
Browse files

optimized sight-range engine

darcs-hash:20060917053633-7cce2-b681b830823e099b00cd52dd48788fa385f78a34.gz
  • Loading branch information...
1 parent 583286a commit bf590d1b8fe4b1e87d9f2ec3616957f704a23811 @clanehin committed Sep 17, 2006
Showing with 124 additions and 71 deletions.
  1. +11 −4 Makefile
  2. +5 −5 src/BeginGame.hs
  3. +80 −36 src/GridRayCaster.hs
  4. +9 −15 src/PlaneVisibility.hs
  5. +5 −5 src/TerrainData.hs
  6. +14 −6 src/VisibilityData.hs
View
15 Makefile
@@ -6,7 +6,9 @@ HS_FLAGS = -hidir products/ \
--make src/Main.hs \
-o products/roguestar-engine
-default : ghc-release
+default : ghc
+
+release : ghc-release
install :
install products/roguestar-engine /usr/local/bin/
@@ -21,10 +23,15 @@ doc :
${MAKE} -C haddock
ghc :
- ghc ${HS_FLAGS}
+ @echo "warning: you're building with development flags on (-Werror, no optimization)"
+ @echo " did you want to 'make release' ?"
+ ghc -Werror ${HS_FLAGS}
+
+ghc-prof :
+ ghc ${HS_FLAGS} -prof -auto-all
ghc-release :
- ghc -O -Werror ${HS_FLAGS}
+ ghc -O2 -fvia-c ${HS_FLAGS}
check:
${MAKE} clean
@@ -42,4 +49,4 @@ headache:
headache-remove:
headache -c header/license-header.conf -h header/license-header -r src/*.hs
-.PHONY : default clean doc ghc ghc-release check dist headache headache-remove
+.PHONY : default clean doc ghc ghc-release check dist headache headache-remove release
View
10 src/BeginGame.hs
@@ -13,22 +13,22 @@ import Data.Maybe
player_race_to_biome :: [(String,Biome)]
player_race_to_biome =
- [("anachronid",DeasertBiome),
+ [("anachronid",DesertBiome),
("androsynth",RockBiome),
("ascendant",MountainBiome),
("canduceator",SwampBiome),
("encephalon",SwampBiome),
- ("goliath",DeasertBiome),
+ ("goliath",DesertBiome),
("hellion",GrasslandBiome),
("kraken",OceanBiome),
- ("myrmidon",DeasertBiome),
+ ("myrmidon",DesertBiome),
("perennial",ForestBiome),
- ("recreant",DeasertBiome),
+ ("recreant",DesertBiome),
("reptilian",SwampBiome)]
dbCreateStartingPlane :: Creature -> DB PlaneRef
dbCreateStartingPlane creature =
- dbNewPlane $ TerrainGenerationData {tg_smootheness = 5,
+ dbNewPlane $ TerrainGenerationData {tg_smootheness = 3,
tg_biome = fromMaybe GrasslandBiome $ lookup (creature_species_name creature) player_race_to_biome}
-- |
View
116 src/GridRayCaster.hs
@@ -1,10 +1,62 @@
module GridRayCaster
- (castRay,
- gridRayCasterTests)
+ (castRays,
+ castRay,
+ gridRayCasterTests,
+ dontWarnAboutTrace)
where
+import Data.Set as Set
+import Data.List as List
import Data.Ratio
import Tests
+import Data.Maybe
+import Debug.Trace
+
+-- |
+-- When casting large numbers of rays from the same point, castRays will try to do this in
+-- O( n^2 ), although O( n^3 ) is still the worst case. It does cheat a little.
+--
+castRays :: (Integer,Integer) -> [((Integer,Integer),Integer)] -> ((Integer,Integer) -> Integer) -> [(Integer,Integer)]
+castRays src@(src_x,src_y) dests opacityFn =
+ toList $
+ foldr (\ l m -> Set.union m $ fromList $ castRays_ Nothing m l) empty $ -- cast the rays, acumulating the already cast rays into a map and passing it into the next castRay_ where it will be used to cheat
+ sortBy (\ a b -> lengthThenDistance a b) $ -- sort the groups so that the largest groups are on the right, in case of equal lengths, move groups with the most distant member to the right (to exploit more cases where we can cheat)
+ List.map (sortBy compareDistance) $ -- sort each group by distance, so the most distant ones come first (then we'll skip the nearer ones if the more distant passes and the nearer is brighter)
+ groupBy (\ a b -> compareDirection a b == EQ) $ -- order and group the all destinations that lie along the same ray
+ sortBy (\ a b -> compareDirection a b) dests
+ where lengthThenDistance a b = case (length a) `compare` (length b) of
+ EQ -> (head b) `compareDistance` (head a)
+ ordering -> ordering
+ compareDistance ((x1,y1),_) ((x2,y2),_) = compare (abs (x2-src_x) + abs (y2-src_y)) (abs (x1-src_x) + abs (y1-src_y)) -- pairs 1 and 2 deliberately reversed to get reverse sort order
+ compareDirection ((x1,y1),_) ((x2,y2),_) | (src_y - y1 == 0) && (src_y - y2 == 0) = signum (src_x-x1) `compare` signum (src_x-x2)
+ compareDirection ((_,y1),_) _ | (src_y - y1 == 0) = LT
+ compareDirection _ ((_,y2),_) | (src_y - y2 == 0) = GT
+ compareDirection ((x1,y1),_) ((x2,y2),_) =
+ let slope1 = (src_x-x1)%(src_y-y1)
+ slope2 = (src_x-x2)%(src_y-y2)
+ in case slope1 `compare` slope2 of
+ EQ -> signum (src_y-y1) `compare` signum (src_y-y2)
+ ordering -> ordering
+ castRays_ _ _ [] = []
+ -- in this case: if a more distant ray from a darker spot passes, then the nearer, brighter ray obviously passes (NOT cheating!)
+ castRays_ (Just old_brightness) m ((dest,brightness):rest) | brightness >= old_brightness = trace' "skipping" $ dest : (castRays_ (Just old_brightness) m rest)
+ -- in this case: if the three spots near to this spot, but one step further from the observer, pass, then pass this spot (cheating!)
+ castRays_ maybe_old_brightness m (((dx,dy),_):rest) | (>= 2) $ length $ List.filter (flip member m) [(dx+signum (dx-src_x),dy),(dx,dy+signum (dy-src_y)),(dx+signum (dx-src_x),dy+signum (dy-src_y))] = trace' "cheating" $ (dx,dy) : (castRays_ maybe_old_brightness m rest)
+ -- if we don't have a basis to automatically include this spot, then actually cast a ray (expensive!)
+ castRays_ maybe_old_brightness m ((dest,brightness):rest) = trace' "casting" $
+ if castRay src dest brightness opacityFn
+ then dest : (castRays_ (Just brightness) m rest)
+ else castRays_ maybe_old_brightness m rest
+
+-- |
+-- Enable or disable tracing by commenting out one of the following.
+--
+trace' :: String -> a -> a
+--trace' = trace
+trace' _ x = x
+
+dontWarnAboutTrace :: String -> a -> a
+dontWarnAboutTrace = trace
-- |
-- Facade function to castRayForOpacity.
@@ -15,62 +67,54 @@ import Tests
--
castRay :: (Integer,Integer) -> (Integer,Integer) -> Integer -> ((Integer,Integer) -> Integer) -> Bool
castRay (ax,ay) (bx,by) brightness opacityFn =
- castRayForOpacity (1%10)
- (ax%1,ay%1)
- (bx%1,by%1)
- (brightness%1)
- (integerToRationalOpacityGrid opacityFn)
-
-data Ray = Ray { ray_origin :: (Rational,Rational),
- ray_delta :: (Rational,Rational) }
-
-integerToRationalOpacityGrid :: ((Integer,Integer) -> Integer) -> ((Rational,Rational) -> Rational)
-integerToRationalOpacityGrid fn (x,y) =
- let partx = abs $ x - (floor x % 1)
- party = abs $ y - (floor y % 1)
- partx_inv = 1 - partx
- party_inv = 1 - party
- ff = (fn (floor x,floor y) % 1) * partx * party
- fc = (fn (floor x,ceiling y) % 1) * partx * party_inv
- cf = (fn (ceiling x, floor y) % 1) * partx_inv * party
- cc = (fn (ceiling x, ceiling y) % 1) * partx_inv * party_inv
- in ff + fc + cf + cc
+ castRayForOpacity (1/8)
+ (fromInteger ax,fromInteger ay)
+ (fromInteger bx,fromInteger by)
+ (fromInteger brightness)
+ (integerToFloatOpacityGrid opacityFn)
+
+data Ray = Ray { ray_origin :: !(Float,Float),
+ ray_delta :: !(Float,Float) }
+
+integerToFloatOpacityGrid :: ((Integer,Integer) -> Integer) -> ((Float,Float) -> Float)
+integerToFloatOpacityGrid fn (x,y) = fromInteger $ fn (round x, round y)
-- |
-- Cast a ray from point a to b, through a medium with variable opacity defined by opacityFn,
--- determining whether or not light from point a will reach point b.
+-- determining whether or not a ray of vision from point a will reach point b.
--
-- Opacity is relative to the brightness of a ray -- a unit-square region of material with an opacity of
-- 5 will completely block a ray with a brightness of 5. A region with an opacity of 1, however,
-- will block 1/5th of the brightness of the ray each time the ray passes through a unit square with that
--- brightness.
+-- brightness. (Note that brightness here is an abtract concept representing how easily our hero can
+-- see the object, not a physical property of a beam of light)
--
-- If a ray ends with a brightness less than 1, then is considered completely blocked, otherwise it is
-- considered to have passed.
--
-castRayForOpacity :: Rational -> (Rational,Rational) -> (Rational,Rational) -> Rational -> ((Rational,Rational)->Rational) -> Bool
-castRayForOpacity fineness a b brightness rawOpacityFn =
+castRayForOpacity :: Float -> (Float,Float) -> (Float,Float) -> Float -> ((Float,Float)->Float) -> Bool
+castRayForOpacity fineness a@(ax,ay) b@(bx,by) brightness rawOpacityFn =
let ray = setRayLength fineness $ rayFromTo a b
- opacityFn = \ x -> 1 - rawOpacityFn x * fineness / brightness
- lengthSquared (ax,ay) (bx,by) = (ax-bx)^2 + (ay-by)^2
- goal_length = lengthSquared a b
+ opacityFn = \ x -> (1 - rawOpacityFn x / brightness) ** fineness
+ lengthSquared (x1,y1) (x2,y2) = (x1-x2)^2 + (y1-y2)^2
+ goal_length = minimum $ List.map (lengthSquared a) [(bx - signum (bx-ax),by),(bx,by - signum (by-ay)),(bx - signum (bx-ax),by + signum (by-ay))]
in all (> 1) $
- scanl (\ bright pt -> bright * opacityFn pt) brightness $
- takeWhile (\ pt -> lengthSquared a pt < goal_length) $
+ scanl (\ bright pt -> bright * opacityFn pt) brightness $
+ takeWhile ( \ pt -> lengthSquared a pt < goal_length) $
rayToPoints ray
-- |
-- Generates a ray from the first point through the second point.
--
-rayFromTo :: (Rational,Rational) -> (Rational,Rational) -> Ray
+rayFromTo :: (Float,Float) -> (Float,Float) -> Ray
rayFromTo (ax,ay) (bx,by) = Ray (ax,ay) (bx-ax,by-ay)
-- |
-- Sets the length of the ray's delta.
--
-setRayLength :: Rational -> Ray -> Ray
+setRayLength :: Float -> Ray -> Ray
setRayLength new_distance ray@(Ray { ray_delta=(dx,dy) }) =
- let old_distance = toRational . sqrt . fromRational $ (dx^2 + dy^2)
+ let old_distance = sqrt $ (dx^2 + dy^2)
scalar = new_distance/old_distance
in ray { ray_delta=(scalar*dx,scalar*dy) }
@@ -86,8 +130,8 @@ incrementRay ray@(Ray {ray_origin=(ax,ay), ray_delta=(dx,dy)}) =
-- where seglength is the distance to each subsequent point,
-- such that all points lie on the ray. The result is an infinite
-- list.
-rayToPoints :: Ray -> [(Rational,Rational)]
-rayToPoints ray = ray_origin ray : rayToPoints (incrementRay ray)
+rayToPoints :: Ray -> [(Float,Float)]
+rayToPoints ray = List.map ray_origin $ iterate (incrementRay) ray
sampleDensityFunction :: (Integer,Integer) -> Integer
sampleDensityFunction (x,y) = (abs x + abs y) `mod` 10
View
24 src/PlaneVisibility.hs
@@ -36,20 +36,14 @@ visibleTerrain :: (Integer,Integer) -> Integer -> TerrainMap -> [((Integer,Integ
visibleTerrain creature_at@(creature_x,creature_y) spot_check terrain =
let max_range = maximumRangeForSpotCheck spot_check
in map ( \ (x,y) -> ((x,y), gridAt terrain (x,y))) $
- filter ( \ (x,y) -> terrainPatchIsVisible creature_at (x,y) spot_check terrain)
- [(x,y) | x <- [creature_x-max_range..creature_x+max_range],
- y <- [creature_y-max_range..creature_y+max_range]]
+ castRays creature_at
+ [terrainPatchBrightnessForm creature_at spot_check (creature_x+x,creature_y+y)
+ | x <- [-max_range..max_range],
+ y <- [-max_range..max_range],
+ x^2+y^2 <= max_range^2]
+ (terrainOpacity . gridAt terrain)
-terrainPatchIsVisible :: (Integer,Integer) -> (Integer,Integer) -> Integer -> TerrainMap -> Bool
-terrainPatchIsVisible creature_at patch_at spot_check terrain =
+terrainPatchBrightnessForm :: (Integer,Integer) -> Integer -> (Integer,Integer) -> ((Integer,Integer),Integer)
+terrainPatchBrightnessForm creature_at spot_check patch_at =
let delta_at = (fst creature_at - fst patch_at,snd creature_at - snd patch_at)
- in castRay creature_at patch_at
- (spot_check - distanceCostForSight Here delta_at) $
- terrainOpacity . gridAt terrain
-
--- |
--- The maximum distance from any point that a creature with that spot check could see anything,
--- no matter how well lit.
---
-maximumRangeForSpotCheck :: Integer -> Integer
-maximumRangeForSpotCheck spot_check = genericLength $ takeWhile (< spot_check) [x*x | x <- [1..]]
+ in (patch_at,spot_check - distanceCostForSight Here delta_at)
View
10 src/TerrainData.hs
@@ -44,7 +44,7 @@ data Biome = RockBiome
| GrasslandBiome
| ForestBiome
| TundraBiome
- | DeasertBiome
+ | DesertBiome
| OceanBiome
| MountainBiome
| SwampBiome
@@ -64,7 +64,7 @@ data TerrainPatch = RockFace
| Dirt
| Grass
| Sand
- | Deasert -- exactly like sand, except from the terrain generator's point of view: oasis can appear
+ | Desert -- exactly like sand, except from the terrain generator's point of view: oasis can appear
| Forest
| DeepForest
| Water
@@ -94,7 +94,7 @@ terrainFrequencies IcyRockBiome = [(1,RockFace),(2,Rubble),(3,RockyGround),(6,Ic
terrainFrequencies GrasslandBiome = [(1,RockFace),(1,RockyGround),(1,Dirt),(2,Sand),(1,Forest),(1,Water),(10,Grass)]
terrainFrequencies ForestBiome = [(1,RockFace),(1,RockyGround),(1,Dirt),(5,Water),(3,Grass),(5,Forest),(5,DeepForest)]
terrainFrequencies TundraBiome = [(1,RockFace),(3,RockyGround),(1,Sand),(1,Water),(1,Grass),(8,Ice)]
-terrainFrequencies DeasertBiome = [(1,RockFace),(3,RockyGround),(1,Grass),(1,Water),(11,Deasert)]
+terrainFrequencies DesertBiome = [(1,RockFace),(3,RockyGround),(1,Grass),(1,Water),(11,Desert)]
terrainFrequencies OceanBiome = [(1,RockyGround),(3,Sand),(1,Grass),(1,Forest),(7,Water),(20,DeepWater)]
terrainFrequencies MountainBiome = [(6,RockFace),(3,RockyGround),(1,Rubble),(1,Sand),(1,Grass),(1,Forest),(1,Water)]
terrainFrequencies SwampBiome = [(1,Forest),(1,Water)]
@@ -119,7 +119,7 @@ terrainInterpRule (Forest,_) = [(1,Grass)]
terrainInterpRule (Water,Water) = [(20,Water),(1,Sand)]
terrainInterpRule (Water,DeepWater) = []
terrainInterpRule (Water,_) = [(1,Sand)]
-terrainInterpRule (Sand,Deasert) = [(1,Grass),(1,Forest)]
+terrainInterpRule (Sand,Desert) = [(1,Grass),(1,Forest)]
terrainInterpRule _ = []
-- |
@@ -156,7 +156,7 @@ terrainPatchToASCII RockyGround = ':'
terrainPatchToASCII Dirt = '.'
terrainPatchToASCII Grass = ','
terrainPatchToASCII Sand = '_'
-terrainPatchToASCII Deasert = '_'
+terrainPatchToASCII Desert = '_'
terrainPatchToASCII Forest = 'f'
terrainPatchToASCII DeepForest = 'F'
terrainPatchToASCII Water = '~'
View
20 src/VisibilityData.hs
@@ -4,10 +4,12 @@ module VisibilityData
terrainHideMultiplier,
terrainSpotMultiplier,
terrainOpacity,
- facingToRelative7)
+ facingToRelative7,
+ maximumRangeForSpotCheck)
where
import TerrainData
+import Data.List
data Facing = North
| NorthEast
@@ -20,8 +22,7 @@ data Facing = North
| Here
deriving (Eq,Enum,Bounded)
-- |
--- In relative coordinates, one integral step in the specified
--- direction.
+-- In relative coordinates, one integral step in the specified direction.
--
facingToRelative :: Facing -> (Integer,Integer)
facingToRelative North = (0,1)
@@ -60,7 +61,7 @@ terrainHideMultiplier RockyGround = 1
terrainHideMultiplier Dirt = 0
terrainHideMultiplier Grass = 1
terrainHideMultiplier Sand = 1
-terrainHideMultiplier Deasert = 1
+terrainHideMultiplier Desert = 1
terrainHideMultiplier Forest = 2
terrainHideMultiplier DeepForest = 2
terrainHideMultiplier Water = 2
@@ -90,7 +91,7 @@ terrainOpacity RockyGround = 0
terrainOpacity Dirt = 0
terrainOpacity Grass = 0
terrainOpacity Sand = 0
-terrainOpacity Deasert = 0
+terrainOpacity Desert = 0
terrainOpacity Forest = 2
terrainOpacity DeepForest = 5
terrainOpacity Water = 0
@@ -108,4 +109,11 @@ 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'
+ in (x*x' + y*y')
+
+-- |
+-- The maximum distance from any point that a creature with that spot check could see anything,
+-- no matter how well lit.
+--
+maximumRangeForSpotCheck :: Integer -> Integer
+maximumRangeForSpotCheck spot_check = genericLength $ takeWhile (< spot_check) [(x*x) | x <- [1..]]

0 comments on commit bf590d1

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