(\_/)
=(^.^)=
(")_(") bunny approves this commit!
(rewrote the whole damn camera-height-function.
Should be better now.)
This commit is contained in:
Jonas Betzendahl
parent
15d55e1577
commit
5b2537188f
@ -76,8 +76,8 @@ gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
|
||||
where
|
||||
gs = map mkStdGen (map (*seed) [1..])
|
||||
c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
|
||||
amp = head $ randomRs ((2.0, 5.0) :: (Float, Float)) (gs !! 2)
|
||||
sig = head $ randomRs ((2.0, 8.0) :: (Float, Float)) (gs !! 3)
|
||||
amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
|
||||
sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3)
|
||||
htt = heightToTerrain
|
||||
|
||||
-- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
|
||||
|
||||
@ -31,7 +31,7 @@ import Control.Arrow ((***))
|
||||
|
||||
import Map.Types
|
||||
|
||||
type Height = Float
|
||||
type Height = Double
|
||||
|
||||
type MapEntry = (
|
||||
Height,
|
||||
|
||||
@ -2,9 +2,8 @@ module Map.Map where
|
||||
|
||||
import Map.Types
|
||||
|
||||
import Data.Function (on)
|
||||
import Data.Array (bounds, (!))
|
||||
import Data.List (sort, sortBy, group)
|
||||
import Data.List (sort, group)
|
||||
|
||||
-- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
|
||||
unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates
|
||||
@ -38,76 +37,43 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
|
||||
remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns
|
||||
|
||||
-- | Calculates the height of any given point on the map.
|
||||
-- Does not add camera distance to ground to that.
|
||||
--
|
||||
-- This ueses barycentric coordinate stuff. Wanna read more?
|
||||
-- http://en.wikipedia.org/wiki/Barycentric_coordinate_system_%28mathematics%29
|
||||
-- http://www.alecjacobson.com/weblog/?p=1596
|
||||
--
|
||||
-- Does not add camera distance to ground to that.
|
||||
giveMapHeight :: PlayMap
|
||||
-> (Float, Float) -- ^ Coordinates on X/Z-axes
|
||||
-> Float -- ^ Terrain Height at that position
|
||||
giveMapHeight mp (x,z)
|
||||
| outsideMap (x',z) = 0.0
|
||||
| (isInt z 6) && (isInt x' 6) = hlu (round x', round z)
|
||||
| (isInt z 6) = let dist_down = x' - fromIntegral ((floor x') :: Int)
|
||||
dist_up = fromIntegral ((ceiling x') :: Int) - x'
|
||||
in (1 - dist_down) * (hlu (floor x', round z)) + (1 - dist_up) * (hlu (ceiling x', round z))
|
||||
| (isInt x' 6) = let dist_down = z - fromIntegral ((floor z) :: Int)
|
||||
dist_up = fromIntegral ((ceiling z) :: Int) - z
|
||||
in (1 - dist_down) * (hlu (round x', floor z)) + (1 - dist_up) * (hlu (round x', ceiling z))
|
||||
| otherwise = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc]
|
||||
ar = area (fi a) (fi b) (fi c)
|
||||
λa = area (fi b) (fi c) (x, z) / ar
|
||||
λb = area (fi a) (fi c) (x, z) / ar
|
||||
λc = area (fi a) (fi b) (x, z) / ar
|
||||
in (λa * hlu a) + (λb * hlu b) + (λc * hlu c)
|
||||
-> (Double, Double)
|
||||
-> Double
|
||||
giveMapHeight mop (x,z)
|
||||
| outsideMap (x,z) = 0.0
|
||||
| otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups
|
||||
where
|
||||
|
||||
-- compensating
|
||||
x' = x * ((sqrt 3) / 2)
|
||||
|
||||
--Returns if q is an int to n decimal places
|
||||
isInt :: RealFrac b => b -> Int -> Bool
|
||||
isInt q n = (round $ 10^((fromIntegral n) :: Integer) * (q - (fromIntegral ((round q):: Integer)))) == (0 :: Integer)
|
||||
|
||||
outsideMap :: (Float, Float) -> Bool
|
||||
outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mp
|
||||
outsideMap :: (Double, Double) -> Bool
|
||||
outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop
|
||||
fr = fromIntegral
|
||||
in mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d)
|
||||
|
||||
fi :: (Int, Int) -> (Float, Float)
|
||||
fi (m, n) = (fromIntegral m, fromIntegral n)
|
||||
|
||||
-- Height LookUp
|
||||
hlu :: (Int, Int) -> Float
|
||||
hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (k,j) in y
|
||||
-- Height LookUp on PlayMap
|
||||
hlu :: (Int, Int) -> Double
|
||||
hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
|
||||
|
||||
-- reference Points
|
||||
ff = (floor x, floor z) :: (Int, Int)
|
||||
fc = (floor x, ceiling z) :: (Int, Int)
|
||||
cf = (ceiling x, floor z) :: (Int, Int)
|
||||
cc = (ceiling x, ceiling z) :: (Int, Int)
|
||||
|
||||
tff = (ff, dist (x,z) ff)
|
||||
tfc = (fc, dist (x,z) fc)
|
||||
tcf = (cf, dist (x,z) cf)
|
||||
tcc = (cc, dist (x,z) cc)
|
||||
-- tupels with reference point and distance
|
||||
tups = map (\t -> (t, dist (x,z) t)) [ff,fc,cf,cc]
|
||||
|
||||
getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)]
|
||||
getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd)))
|
||||
-- total distance of all for reference point from the point in question
|
||||
totald = sum $ map (\(_,d) -> d) tups
|
||||
|
||||
dist :: (Float, Float) -> (Int, Int) -> Float
|
||||
dist (x1,z1) (x2,z2) = let xf = x1 - fromIntegral x2
|
||||
zf = z1 - fromIntegral z2
|
||||
in sqrt $ xf*xf + zf*zf
|
||||
|
||||
-- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula
|
||||
area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float
|
||||
area (x1,z1) (x2,z2) (x3,z3) = let a = sqrt $ (x1-x2)*(x1-x2) + (z1-z2)*(z1-z2)
|
||||
b = sqrt $ (x2-x3)*(x2-x3) + (z2-z3)*(z2-z3)
|
||||
c = sqrt $ (x1-x3)*(x1-x3) + (z1-z3)*(z1-z3)
|
||||
s = (a+b+c)/2
|
||||
in sqrt $ s * (s-a) * (s-b) * (s-c)
|
||||
-- Real distance on PlayMap
|
||||
dist :: (Double, Double) -> (Int, Int) -> Double
|
||||
dist (x1,z1) pmp = let xf = x1 - realx
|
||||
zf = z1 - realz
|
||||
in sqrt $ xf*xf + zf*zf
|
||||
where
|
||||
realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp)
|
||||
realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp)
|
||||
|
||||
-- removing duplicates in O(n log n), losing order and adding Ord requirement
|
||||
remdups :: Ord a => [a] -> [a]
|
||||
|
||||
@ -7,9 +7,9 @@ type PlayMap = Array (Xindex, Zindex) Node
|
||||
|
||||
type Xindex = Int
|
||||
type Zindex = Int
|
||||
type XCoord = Float
|
||||
type ZCoord = Float
|
||||
type YCoord = Float
|
||||
type XCoord = Double
|
||||
type ZCoord = Double
|
||||
type YCoord = Double
|
||||
|
||||
data MapType = GrassIslandMap
|
||||
| DesertMap
|
||||
|
||||
@ -29,7 +29,7 @@ data Camera = Flat Position Height
|
||||
|
||||
-- | create a Flatcam-Camera starting at given x/z-Coordinates
|
||||
createFlatCam :: Double -> Double -> PlayMap -> Camera
|
||||
createFlatCam x z map' = Flat (x,z) (float2Double $ giveMapHeight map' (double2Float x,double2Float z))
|
||||
createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
|
||||
|
||||
-- | create a Flatcam-Camera starting at given pitch/azimuth/radius
|
||||
createSphereCam :: Double -> Double -> Double -> Camera
|
||||
@ -76,11 +76,10 @@ instance GLCamera Camera where
|
||||
xa = realToFrac xa'
|
||||
ya = realToFrac ya'
|
||||
moveBy (Sphere (inc, az) r) f map = undefined
|
||||
moveBy (Flat (x', z') y) f map = Flat (x,z) (float2Double y)
|
||||
moveBy (Flat (x', z') y) f map = Flat (x,z) y
|
||||
where
|
||||
(x,z) = f (x', z')
|
||||
y = giveMapHeight map (fc x,fc z)
|
||||
fc = double2Float
|
||||
y = giveMapHeight map (x,z)
|
||||
move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
|
||||
|
||||
sphereToCart :: (Floating a) => a -> a -> a -> V3 a
|
||||
|
||||
Loading…
Reference in New Issue
Block a user