(\_/)

=(^.^)=
(")_(")  bunny approves this commit!
         (rewrote the whole damn camera-height-function.
                                   Should be better now.)

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)
+    amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
-    sig = head $ randomRs ((2.0, 8.0) :: (Float, Float)) (gs !! 3)
+    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

src/Map/Graphics.hs

@@ -31,7 +31,7 @@ import Control.Arrow         ((***))
 
 import Map.Types
 
-type Height = Float
+type Height = Double
 
 type MapEntry = (
                 Height,

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
@@ -39,75 +38,42 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
 
 -- | 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
---
 giveMapHeight :: PlayMap
-              -> (Float, Float)  -- ^ Coordinates on X/Z-axes 
+             -> (Double, Double)
-              -> Float           -- ^ Terrain Height at that position
+             -> Double
-giveMapHeight mp (x,z)
+giveMapHeight mop (x,z)
-  | outsideMap (x',z)           = 0.0
+  | outsideMap (x,z) = 0.0
-  | (isInt z 6) && (isInt x' 6) = hlu (round x', round z)
+  | otherwise        = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups
-  | (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)
   where
-
+    outsideMap :: (Double, Double) -> Bool
-    -- compensating
+    outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop
-    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
                               fr = fromIntegral
                           in  mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d)
  
-    fi :: (Int, Int) -> (Float, Float)
+    -- Height LookUp on PlayMap
-    fi (m, n) = (fromIntegral m, fromIntegral n)
+    hlu :: (Int, Int) -> Double
-
+    hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
-    -- Height LookUp
-    hlu :: (Int, Int) -> Float
-    hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (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)
+    -- tupels with reference point and distance
-    tfc = (fc, dist (x,z) fc)
+    tups = map (\t -> (t, dist (x,z) t)) [ff,fc,cf,cc]
-    tcf = (cf, dist (x,z) cf)
-    tcc = (cc, dist (x,z) cc)
 
-    getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)]
+    -- total distance of all for reference point from the point in question
-    getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd)))
+    totald = sum $ map (\(_,d) -> d) tups
 
-    dist :: (Float, Float) -> (Int, Int) -> Float
+    -- Real distance on PlayMap
-    dist (x1,z1) (x2,z2) = let xf = x1 - fromIntegral x2
+    dist :: (Double, Double) -> (Int, Int) -> Double
-                               zf = z1 - fromIntegral z2
+    dist (x1,z1) pmp = let xf = x1 - realx 
+                           zf = z1 - realz
                        in  sqrt $ xf*xf + zf*zf
-
+      where
-    -- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula
+        realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp)
-    area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float
+        realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp)
-    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)
 
 -- removing duplicates in O(n log n), losing order and adding Ord requirement
 remdups :: Ord a => [a] -> [a]

src/Map/Types.hs

@@ -7,9 +7,9 @@ type PlayMap = Array (Xindex, Zindex) Node
 
 type Xindex  = Int
 type Zindex  = Int
-type XCoord  = Float
+type XCoord  = Double
-type ZCoord  = Float
+type ZCoord  = Double
-type YCoord  = Float
+type YCoord  = Double
 
 data MapType    = GrassIslandMap
                 | DesertMap

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)
+					y     = giveMapHeight map (x,z)
-					fc = double2Float
   move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
 
 sphereToCart :: (Floating a) => a -> a -> a -> V3 a