From 67428146ca595603139fd9d81adf2dc8986bad95 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Thu, 15 May 2014 10:44:54 +0200 Subject: [PATCH 1/3] added height function --- src/Map/Map.hs | 60 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 58 insertions(+), 2 deletions(-) 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 From eb3ee975e8f4d9f3d9476b83f8f850746e011b51 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Thu, 15 May 2014 12:01:30 +0200 Subject: [PATCH 2/3] =?UTF-8?q?Restructured=20Node=20constructors.=20Rippl?= =?UTF-8?q?es=20are=20getting=20worse!=20(=E2=95=AF=C2=B0=E2=96=A1=C2=B0?= =?UTF-8?q?=EF=BC=89=E2=95=AF=EF=B8=B5=20=E2=94=BB=E2=94=81=E2=94=BB?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Pioneers.cabal | 1 - src/Map/Creation.hs | 28 ++++++++++++------------- src/Map/Graphics.hs | 6 ++---- src/Map/Map.hs | 5 +---- src/Map/StaticMaps.hs | 49 ------------------------------------------- src/Map/Types.hs | 13 ++++++------ 6 files changed, 24 insertions(+), 78 deletions(-) delete mode 100644 src/Map/StaticMaps.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index fadfec1..bf7c426 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -16,7 +16,6 @@ executable Pioneers Map.Types, Map.Graphics, Map.Creation, - Map.StaticMaps, Importer.IQM.Types, Importer.IQM.Parser, Render.Misc, diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 554cb6c..c2304f0 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,7 +2,6 @@ module Map.Creation where import Map.Types -import Map.StaticMaps -- import Map.Map unused (for now) import Data.Array @@ -18,6 +17,10 @@ infix 5 -<- (-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap f -<- g = f . g +-- entirely empty map, only uses the minimal constructor +mapEmpty :: PlayMap +mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]] + exportedMap :: IO PlayMap exportedMap = do mounts <- mnt return $ aplAll mounts mapEmpty @@ -52,7 +55,7 @@ gauss3Dgeneral :: Floating q => -> q -- ^ Coordinate in question on X -> q -- ^ Coordinate in question on Z -> q -- ^ elevation on coordinate in question -gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Integer)/(2 * sX^(2 :: Integer)))+((z-z0)^(2 :: Integer)/(2 * sZ^(2 :: Integer))))) +gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int))))) -- specialised 3D gaussian with an origin on 100/100, an amplitude of 15 and two sigmas of 15 gauss3D :: Floating q => @@ -71,8 +74,8 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d) -- TODO: Implement Desert-Generator heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain GrassIslandMap y - | y < 0.1 = Ocean - | y < 1 = Beach + | y < 0.1 = Ocean + | y < 1 = Beach | y < 5 = Grass | y < 10 = Hill | otherwise = Mountain @@ -93,20 +96,17 @@ mnt = do g <- newStdGen gaussMountain :: Int -> PlayMap -> PlayMap gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp where - g = mkStdGen seed - c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g))) - amp = head $ randomRs (5.0, 20.0) g - sig = head $ randomRs (5.0, 25.0) g - fi = fromIntegral + 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 ((5.0, 20.0) :: (Float, Float)) (gs !! 2) + sig = head $ randomRs ((5.0, 25.0) :: (Float, Float)) (gs !! 3) htt = heightToTerrain -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map liftUp :: (Int, Int) -> Node -> Node - liftUp (gx,gz) (Full (x,z) y _ b pl pa r s) = let y_neu = max y e - in Full (x,z) y_neu (htt GrassIslandMap y_neu) b pl pa r s - where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z) - liftUp (gx, gz) (Minimal (x,z)) = Full (x,z) e (htt GrassIslandMap e) BFlag NoPlayer NoPath Plain [] - where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z) + liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e + in Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s + where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz -- | Makes sure the edges of the Map are mountain-free makeIsland :: PlayMap -> PlayMap diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 858b1f4..a99348b 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -50,16 +50,14 @@ stripify :: (Int,Int) -> (Int,Int) stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2) strp :: Node -> Node -strp (Full xz y tt bi pli p ri si) = Full (stripify xz) y tt bi pli p ri si -strp (Minimal xz ) = Minimal (stripify xz) +strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si -- extract graphics information from Playmap convertToGraphicsMap :: PlayMap -> GraphicsMap convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp] where graphicsyfy :: Node -> MapEntry - graphicsyfy (Minimal _ ) = (1.0, Grass) - graphicsyfy (Full _ y t _ _ _ _ _ ) = (y, t) + graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t) lineHeight :: GLfloat lineHeight = 0.8660254 diff --git a/src/Map/Map.hs b/src/Map/Map.hs index ced09c0..53a0976 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -61,10 +61,7 @@ giveMapHeight mp (x,z) = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc] -- Height LookUp hlu :: (Int, Int) -> Float - hlu (k,j) = let node = mp ! (k,j) - in case node of - (Full _ y _ _ _ _ _ _) -> y - (Minimal _ ) -> 1.0 + hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (k,j) in y ff = (floor x, floor z) :: (Int, Int) fc = (floor x, ceiling z) :: (Int, Int) diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs deleted file mode 100644 index 5ef9942..0000000 --- a/src/Map/StaticMaps.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Map.StaticMaps -where - -import Map.Types -import Data.Array - --- entirely empty map, only uses the minimal constructor -mapEmpty :: PlayMap -mapEmpty = array ((0,0), (199,199)) [((a,b), Minimal (a,b)) | a <- [0..199], b <- [0..199]] - ---mapCenterMountain :: PlayMap ---mapCenterMountain = array ((0,0),(199,199)) nodes --- where --- nodes = water ++ beach ++ grass ++ hill ++ mountain --- water = [((a,b), Full (a,b) 0.0 Ocean BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) > 95] --- beach = [((a,b), Full (a,b) (g2d a b) Beach BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 95, m2d (a,b) > 75] --- grass = [((a,b), Full (a,b) (g2d a b) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 75, m2d (a,b) > 25] --- hill = [((a,b), Full (a,b) (g2d a b) Hill BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 25, m2d (a,b) > 10] --- mountain = [((a,b), Full (a,b) (g2d a b) Mountain BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 10] - --- g2d :: Int -> Int -> Float --- g2d x y = gauss3D (fromIntegral x) (fromIntegral y) - --- m2d :: (Int,Int) -> Int --- m2d (x,y) = mnh2D (x,y) (100,100) - --- small helper for some hills. Should be replaced by multi-layer perlin-noise --- TODO: Replace as given in comment. ---_noisyMap :: (Floating q) => q -> q -> q ---_noisyMap x y = gauss3Dgeneral 15 100.0 100.0 15.0 15.0 x y --- + gauss3Dgeneral 5 10.0 10.0 10.0 10.0 x y --- + gauss3Dgeneral 5 150.0 120.0 10.0 10.0 x y --- + gauss3Dgeneral 5 50.0 75.0 10.0 10.0 x y - --- generates a noisy map --- TODO: add real noise to a simple pattern ---mapNoise :: PlayMap ---mapNoise = array ((0,0),(199,199)) nodes --- where --- nodes = [((a,b), Full (a,b) --- (height a b) --- (heightToTerrain GrassIslandMap $ height a b) --- BNothing --- NoPlayer --- NoPath --- Plain --- []) | a <- [0..199], b <- [0..199]] --- where --- height a b = _noisyMap (fromIntegral a) (fromIntegral b) diff --git a/src/Map/Types.hs b/src/Map/Types.hs index c62837f..dd66236 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -5,10 +5,12 @@ import Types import Data.Array -type PlayMap = Array (XCoord, ZCoord) Node +type PlayMap = Array (Xindex, Zindex) Node -type XCoord = Int -type ZCoord = Int +type Xindex = Int +type Zindex = Int +type XCoord = Float +type ZCoord = Float type YCoord = Float data MapType = GrassIslandMap @@ -66,7 +68,6 @@ data TileType = Ocean | Mountain -- ^ Not accessible deriving (Show, Eq) --- TODO: Record Syntax -data Node = Full (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo - | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1 +-- TODO: Record Syntax? +data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo deriving (Show) From 8e2d46c7ef27a8c3dc6aab2f43490e63ea62576b Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Thu, 15 May 2014 12:06:18 +0200 Subject: [PATCH 3/3] Fixed the hell out of that snow! --- src/Map/Graphics.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index a99348b..0995741 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -201,8 +201,8 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0) Beach -> (0.90, 0.85, 0.70) Desert -> (1.00, 0.87, 0.39) Grass -> (0.30, 0.90, 0.10) - Hill -> (0.80, 0.80, 0.80) - Mountain -> (0.50, 0.50, 0.50) + Mountain -> (0.80, 0.80, 0.80) + Hill -> (0.50, 0.50, 0.50) coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat coordLookup (x,z) y =