diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 7ea3593..ced09c0 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -1,9 +1,11 @@ module Map.Map where import Map.Types +import Map.Creation -import Data.Array (bounds) -import Data.List (sort, group) +import Data.Function (on) +import Data.Array (bounds, (!)) +import Data.List (sort, sortBy, group) -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet. unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates @@ -36,6 +38,60 @@ giveNeighbourhood _ 0 (a,b) = [(a,b)] 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 +-- +giveMapHeight :: PlayMap + -> (Float, Float) -- ^ Coordinates on X/Z-axes + -> Float -- ^ Terrain Height at that position +giveMapHeight mp (x,z) = 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 + + fi :: (Int, Int) -> (Float, Float) + fi (m, n) = (fromIntegral m, fromIntegral n) + + -- Height LookUp + hlu :: (Int, Int) -> Float + hlu (k,j) = let node = mp ! (k,j) + in case node of + (Full _ y _ _ _ _ _ _) -> y + (Minimal _ ) -> 1.0 + + 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) + + getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)] + getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd))) + + dist :: (Float, Float) -> (Int, Int) -> Float + dist (x1,z1) (x2,z2) = let x' = x1 - fromIntegral x2 + z' = z1 - fromIntegral z2 + in sqrt $ x'*x' + z'*z' + + -- 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) + -- removing duplicates in O(n log n), losing order and adding Ord requirement remdups :: Ord a => [a] -> [a] remdups = map head . group . sort