From 5b2537188f213e157eba208ea44539ea437f66ee Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 17:26:40 +0200 Subject: [PATCH] (\_/) =(^.^)= (")_(") bunny approves this commit! (rewrote the whole damn camera-height-function. Should be better now.) --- src/Map/Creation.hs | 4 +-- src/Map/Graphics.hs | 2 +- src/Map/Map.hs | 84 ++++++++++++++------------------------------- src/Map/Types.hs | 6 ++-- src/Render/Types.hs | 7 ++-- 5 files changed, 34 insertions(+), 69 deletions(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 205c99b..38a49a6 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -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 diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 71df337..6de0cab 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -31,7 +31,7 @@ import Control.Arrow ((***)) import Map.Types -type Height = Float +type Height = Double type MapEntry = ( Height, diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 657be5d..5730778 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -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] diff --git a/src/Map/Types.hs b/src/Map/Types.hs index cd3f246..2ca5d61 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -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 diff --git a/src/Render/Types.hs b/src/Render/Types.hs index 0b60da1..8e7bf49 100644 --- a/src/Render/Types.hs +++ b/src/Render/Types.hs @@ -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