From f2fbf101ef8c24380573af789c8abe0d2df83fa8 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 11:30:15 +0200 Subject: [PATCH 01/12] Camera function not NaNing / breaking anymore / merge tessalation --- src/Map/Creation.hs | 26 ++------------------------ src/Map/Map.hs | 31 ++++++++++++++++++++++++------- 2 files changed, 26 insertions(+), 31 deletions(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 944d2b9..91faee9 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,21 +2,10 @@ module Map.Creation where import Map.Types --- import Map.Map unused (for now) import Data.Array import System.Random --- preliminary -infix 5 ->- -(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap -f ->- g = g . f - --- also preliminary -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]] @@ -57,17 +46,6 @@ gauss3Dgeneral :: Floating q => -> q -- ^ elevation on coordinate in question 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 => - q -- ^ X-Coordinate - -> q -- ^ Z-Coordinate - -> q -- ^ elevation on coordinate in quesion -gauss3D = gauss3Dgeneral 15 100.0 100.0 15.0 15.0 - --- 2D Manhattan distance -mnh2D :: (Int,Int) -> (Int,Int) -> Int -mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d) - -- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome -- (like Deserts on Grass-Islands or Grass on Deserts) -- @@ -75,9 +53,9 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d) heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain GrassIslandMap y | y < 0.1 = Ocean - | y < 0.2 = Beach + | y < 0.2 = Beach | y < 1 = Grass - | y < 3 = Hill + | y < 3 = Hill | otherwise = Mountain heightToTerrain _ _ = undefined diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 53a0976..98c5912 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -1,7 +1,6 @@ module Map.Map where import Map.Types -import Map.Creation import Data.Function (on) import Data.Array (bounds, (!)) @@ -48,14 +47,32 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in 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) +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) where + --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) fi (m, n) = (fromIntegral m, fromIntegral n) From 1c1aedda3021e3c843b998836c6123e7bc20c93e Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 11:39:29 +0200 Subject: [PATCH 02/12] Grass is back, bettered mountains --- src/Map/Creation.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 91faee9..205c99b 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -54,7 +54,7 @@ heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain GrassIslandMap y | y < 0.1 = Ocean | y < 0.2 = Beach - | y < 1 = Grass + | y < 1.5 = Grass | y < 3 = Hill | otherwise = Mountain heightToTerrain _ _ = undefined @@ -77,7 +77,7 @@ gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp 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 ((1.0, 15.0) :: (Float, Float)) (gs !! 3) + sig = head $ randomRs ((2.0, 8.0) :: (Float, Float)) (gs !! 3) htt = heightToTerrain -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map From 15d55e157701d5149f983dcbcab351d48c3faafa Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 15:58:07 +0200 Subject: [PATCH 03/12] compensating for stripe depth --- src/Map/Graphics.hs | 1 - src/Map/Map.hs | 27 +++++++++++++++------------ 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 7c9c93f..71df337 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -30,7 +30,6 @@ import Linear import Control.Arrow ((***)) import Map.Types -import Map.Creation type Height = Float diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 98c5912..657be5d 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -38,7 +38,7 @@ 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. + -- 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 @@ -48,14 +48,14 @@ 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)) + | 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 @@ -64,6 +64,9 @@ giveMapHeight mp (x,z) in (λa * hlu a) + (λb * hlu b) + (λc * hlu c) 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) @@ -94,9 +97,9 @@ giveMapHeight mp (x,z) 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' + 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 From 5b2537188f213e157eba208ea44539ea437f66ee Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 17:26:40 +0200 Subject: [PATCH 04/12] (\_/) =(^.^)= (")_(") 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 From a71ce917ecb33f241c505403b79b0a9fb841368b Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 17:43:31 +0200 Subject: [PATCH 05/12] fixed floor/ceiling crap --- src/Map/Map.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 5730778..36269dc 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -55,10 +55,10 @@ giveMapHeight mop (x,z) 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) + ff = ((floor x)-1, (floor z)-1) :: (Int, Int) + fc = ((floor x)-1, (floor z)+2) :: (Int, Int) + cf = ((floor x)+2, (floor z)-1) :: (Int, Int) + cc = ((floor x)+2, (floor z)+2) :: (Int, Int) -- tupels with reference point and distance tups = map (\t -> (t, dist (x,z) t)) [ff,fc,cf,cc] From cd4250336b3bd0c02e52b83c9c8269a6c0765565 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 17:56:03 +0200 Subject: [PATCH 06/12] moar reference points --- src/Map/Map.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 36269dc..85890b2 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -55,13 +55,13 @@ giveMapHeight mop (x,z) hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y -- reference Points - ff = ((floor x)-1, (floor z)-1) :: (Int, Int) - fc = ((floor x)-1, (floor z)+2) :: (Int, Int) - cf = ((floor x)+2, (floor z)-1) :: (Int, Int) - cc = ((floor x)+2, (floor z)+2) :: (Int, Int) + refs :: [(Int, Int)] + refs = map (tadd (floor x, floor z)) [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] + where + tadd (a,b) (c,d) = (a+b,c+d) -- tupels with reference point and distance - tups = map (\t -> (t, dist (x,z) t)) [ff,fc,cf,cc] + tups = map (\t -> (t, dist (x,z) t)) refs -- total distance of all for reference point from the point in question totald = sum $ map (\(_,d) -> d) tups From c624121e236c161046cb3940b95e839d6f4fb420 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 18:48:46 +0200 Subject: [PATCH 07/12] Clamped reference points --- src/Map/Map.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 85890b2..2880d87 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -49,15 +49,16 @@ giveMapHeight mop (x,z) 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) - + -- Height LookUp on PlayMap hlu :: (Int, Int) -> Double hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y -- reference Points refs :: [(Int, Int)] - refs = map (tadd (floor x, floor z)) [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] + refs = remdups $ map clmp $ map (tadd (floor x, floor z)) mods where + mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] tadd (a,b) (c,d) = (a+b,c+d) -- tupels with reference point and distance @@ -66,6 +67,15 @@ giveMapHeight mop (x,z) -- total distance of all for reference point from the point in question totald = sum $ map (\(_,d) -> d) tups + -- clamp, as she is programmed + clamp :: (Ord a) => a -> a -> a -> a + clamp mn mx = max mn . min mx + + -- clamp for tupels + clmp :: (Int, Int) -> (Int, Int) + clmp (a,b) = let ((xmin,zmin),(xmax,zmax)) = bounds mop + in ((clamp (xmin+2) (xmax-2) a),(clamp (zmin+2) (zmax-2) b)) + -- Real distance on PlayMap dist :: (Double, Double) -> (Int, Int) -> Double dist (x1,z1) pmp = let xf = x1 - realx From ffa45515c3a95981457361d8527cb9cc465451c3 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 18:59:26 +0200 Subject: [PATCH 08/12] attempting to compensate once more --- src/Map/Map.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 2880d87..2a3cb26 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -42,9 +42,11 @@ giveMapHeight :: PlayMap -> (Double, Double) -> Double giveMapHeight mop (x,z) - | outsideMap (x,z) = 0.0 - | otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups + | outsideMap (x,z') = 0.0 + | otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups where + z' = z * ((sqrt 3)/2) + outsideMap :: (Double, Double) -> Bool outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop fr = fromIntegral @@ -56,13 +58,13 @@ giveMapHeight mop (x,z) -- reference Points refs :: [(Int, Int)] - refs = remdups $ map clmp $ map (tadd (floor x, floor z)) mods + refs = remdups $ map clmp $ map (tadd (floor x, floor z')) mods where mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] tadd (a,b) (c,d) = (a+b,c+d) -- tupels with reference point and distance - tups = map (\t -> (t, dist (x,z) t)) refs + tups = map (\t -> (t, dist (x,z') t)) refs -- total distance of all for reference point from the point in question totald = sum $ map (\(_,d) -> d) tups From 2944d367037324db2a994293b4f5112a12dda089 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 16 May 2014 19:06:05 +0200 Subject: [PATCH 09/12] changed camera-height --- src/Render/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Render/Types.hs b/src/Render/Types.hs index 8e7bf49..5191322 100644 --- a/src/Render/Types.hs +++ b/src/Render/Types.hs @@ -40,7 +40,7 @@ instance GLCamera Camera where getCam (Flat (x',z') y') dist' xa' ya' = lookAt (cpos ^+^ at') at' up where - at' = V3 x y z + at' = V3 x (y+2) z cpos = crot !* (V3 0 0 (-dist)) crot = ( (fromQuaternion $ axisAngle upmap (xa::CFloat)) From 27d78735956d0558000d475f72a3de1caed47478 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 16 May 2014 22:05:27 +0200 Subject: [PATCH 10/12] reworked Types to support STM - deadlocks somewhere... --- src/Main.hs | 67 ++++++++++++++++++++++++++------------------ src/Render/Render.hs | 13 +++++---- src/Types.hs | 6 ++-- src/UI/Callbacks.hs | 19 +++++++++---- 4 files changed, 64 insertions(+), 41 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0a7e867..e5f9328 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,8 +12,8 @@ import Control.Arrow ((***)) -- data consistency/conversion import Control.Concurrent (threadDelay) -import Control.Concurrent.STM (TQueue, - newTQueueIO) +import Control.Concurrent.STM (TQueue, newTQueueIO, atomically) +import Control.Concurrent.STM.TMVar (newTMVarIO, takeTMVar, putTMVar, readTMVar) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Data.Functor ((<$>)) @@ -94,16 +94,26 @@ main = --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 --TTF.setFontStyle font TTFNormal --TTF.setFontHinting font TTFHNormal - - glHud' <- initHud - let zDistClosest' = 2 - zDistFarthest' = zDistClosest' + 10 - --TODO: Move near/far/fov to state for runtime-changability & central storage + let fov = 90 --field of view near = 1 --near plane far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio + cam' <- newTMVarIO CameraState + { _xAngle = pi/6 + , _yAngle = pi/2 + , _zDist = 10 + , _frustum = frust + , _camObject = createFlatCam 25 25 curMap + } + game' <- newTMVarIO GameState + { _currentMap = curMap + } + glHud' <- initHud + let zDistClosest' = 2 + zDistFarthest' = zDistClosest' + 10 + --TODO: Move near/far/fov to state for runtime-changability & central storage (guiMap, guiRoots) = createGUI aks = ArrowKeyState { _up = False @@ -123,17 +133,11 @@ main = , _height = fbHeight , _shouldClose = False } - , _camera = CameraState - { _xAngle = pi/6 - , _yAngle = pi/2 - , _zDist = 10 - , _frustum = frust - , _camObject = createFlatCam 25 25 curMap - } , _io = IOState { _clock = now , _tessClockFactor = 0 } + , _camera = cam' , _mouse = MouseState { _isDown = False , _isDragging = False @@ -155,9 +159,7 @@ main = , _glRenderbuffer = renderBuffer , _glFramebuffer = frameBuffer } - , _game = GameState - { _currentMap = curMap - } + , _game = game' , _ui = UIState { _uiHasChanged = True , _uiMap = guiMap @@ -207,20 +209,26 @@ run = do | otherwise = newYAngle' newYAngle' = sodya + myrot/100 - modify $ ((camera.xAngle) .~ newXAngle) - . ((camera.yAngle) .~ newYAngle) + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam + putTMVar (state ^. camera) cam' -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement - let - multc = cos $ state ^. camera.yAngle - mults = sin $ state ^. camera.yAngle - modx x' = x' - 0.2 * kxrot * multc - - 0.2 * kyrot * mults - mody y' = y' + 0.2 * kxrot * mults - - 0.2 * kyrot * multc - modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap)) + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + game' <- readTMVar (state ^. game) + let + multc = cos $ cam ^. yAngle + mults = sin $ cam ^. yAngle + modx x' = x' - 0.2 * kxrot * multc + - 0.2 * kyrot * mults + mody y' = y' + 0.2 * kxrot * mults + - 0.2 * kyrot * multc + cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam + putTMVar (state ^. camera) cam' {- --modify the state with all that happened in mt time. @@ -290,7 +298,10 @@ adjustWindow = do ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) - modify $ camera.frustum .~ frust + liftIO $ atomically $ do + cam <- readTMVar (state ^. camera) + cam' <- return $ frustum .~ frust $ cam + putTMVar (state ^. camera) cam' rb <- liftIO $ do -- bind ints to CInt for lateron. let fbCWidth = (fromInteger.toInteger) fbWidth diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 7863ceb..ee91b27 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -12,6 +12,8 @@ import qualified Linear as L import Control.Lens ((^.)) import Control.Monad.RWS.Strict (liftIO) import qualified Control.Monad.RWS.Strict as RWS (get) +import Control.Concurrent.STM.TMVar (readTMVar) +import Control.Concurrent.STM (atomically) import Data.Distributive (distribute, collect) -- FFI import Foreign (Ptr, castPtr, with) @@ -364,11 +366,12 @@ drawMap = do render :: Pioneers () render = do state <- RWS.get - let xa = state ^. camera.xAngle - ya = state ^. camera.yAngle - frust = state ^. camera.Types.frustum - camPos = state ^. camera.camObject - zDist' = state ^. camera.zDist + cam <- liftIO $ atomically $ readTMVar (state ^. camera) + let xa = cam ^. xAngle + ya = cam ^. yAngle + frust = cam ^. Types.frustum + camPos = cam ^. camObject + zDist' = cam ^. zDist d = state ^. gl.glMap.mapShaderData (UniformLocation proj) = shdrProjMatIndex d (UniformLocation nmat) = shdrNormalMatIndex d diff --git a/src/Types.hs b/src/Types.hs index 75932ea..c722d11 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue) +import Control.Concurrent.STM (TQueue, TMVar) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -161,12 +161,12 @@ data UIState = UIState data State = State { _window :: !WindowState - , _camera :: !CameraState + , _camera :: TMVar CameraState , _io :: !IOState , _mouse :: !MouseState , _keyboard :: !KeyboardState , _gl :: !GLState - , _game :: !GameState + , _game :: TMVar GameState , _ui :: !UIState } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 31d5a73..9ce6cc5 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -13,6 +13,8 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL +import Control.Concurrent.STM.TMVar (readTMVar, takeTMVar, putTMVar) +import Control.Concurrent.STM (atomically) import Render.Misc (curb,genColorData) @@ -105,11 +107,13 @@ eventCallback e = do state <- get if state ^. mouse.isDown && not (state ^. mouse.isDragging) then + do + cam <- liftIO $ atomically $ readTMVar (state ^. camera) modify $ (mouse.isDragging .~ True) . (mouse.dragStartX .~ fromIntegral x) . (mouse.dragStartY .~ fromIntegral y) - . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) - . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) + . (mouse.dragStartXAngle .~ (cam ^. xAngle)) + . (mouse.dragStartYAngle .~ (cam ^. yAngle)) else mouseMoveHandler (x, y) modify $ (mouse.mousePosition. Types._x .~ fromIntegral x) . (mouse.mousePosition. Types._y .~ fromIntegral y) @@ -134,8 +138,13 @@ eventCallback e = do SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll do state <- get - let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in - modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + let zDist' = (cam ^. zDist) + realToFrac (negate vscroll) + zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' + cam' <- return $ zDist .~ zDist'' $ cam + putTMVar (state ^. camera) cam' + -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] @@ -340,4 +349,4 @@ copyGUI tex (vX, vY) widget = do mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. ---TODO: Maybe queues are better? \ No newline at end of file +--TODO: Maybe queues are better? From 0d65a485d563d1d3b9635317f9a8f09d414b0129 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 17 May 2014 11:40:23 +0200 Subject: [PATCH 11/12] changed constant in Map.Map --- src/Map/Map.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 2a3cb26..b92e926 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -41,11 +41,11 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in giveMapHeight :: PlayMap -> (Double, Double) -> Double -giveMapHeight mop (x,z) +giveMapHeight mop (x, z) | outsideMap (x,z') = 0.0 | otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups where - z' = z * ((sqrt 3)/2) + z' = z * 2/(sqrt 3) outsideMap :: (Double, Double) -> Bool outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop From 230e31bf635690103e19222b4a25cdce04b1d27b Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 17 May 2014 12:57:49 +0200 Subject: [PATCH 12/12] changed TMVar to TVar - compiles & runs again --- src/Main.hs | 20 ++++++++++---------- src/Render/Render.hs | 4 ++-- src/Types.hs | 6 +++--- src/UI/Callbacks.hs | 8 ++++---- 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index e5f9328..f4d401c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -13,7 +13,7 @@ import Control.Arrow ((***)) -- data consistency/conversion import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TQueue, newTQueueIO, atomically) -import Control.Concurrent.STM.TMVar (newTMVarIO, takeTMVar, putTMVar, readTMVar) +import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Data.Functor ((<$>)) @@ -100,14 +100,14 @@ main = far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio - cam' <- newTMVarIO CameraState + cam' <- newTVarIO CameraState { _xAngle = pi/6 , _yAngle = pi/2 , _zDist = 10 , _frustum = frust , _camObject = createFlatCam 25 25 curMap } - game' <- newTMVarIO GameState + game' <- newTVarIO GameState { _currentMap = curMap } glHud' <- initHud @@ -210,16 +210,16 @@ run = do newYAngle' = sodya + myrot/100 liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) + cam <- readTVar (state ^. camera) cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) - game' <- readTMVar (state ^. game) + cam <- readTVar (state ^. camera) + game' <- readTVar (state ^. game) let multc = cos $ cam ^. yAngle mults = sin $ cam ^. yAngle @@ -228,7 +228,7 @@ run = do mody y' = y' + 0.2 * kxrot * mults - 0.2 * kyrot * multc cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' {- --modify the state with all that happened in mt time. @@ -299,9 +299,9 @@ adjustWindow = do frust = createFrustum fov near far ratio liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) liftIO $ atomically $ do - cam <- readTMVar (state ^. camera) + cam <- readTVar (state ^. camera) cam' <- return $ frustum .~ frust $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' rb <- liftIO $ do -- bind ints to CInt for lateron. let fbCWidth = (fromInteger.toInteger) fbWidth diff --git a/src/Render/Render.hs b/src/Render/Render.hs index ee91b27..59fe4ed 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -12,7 +12,7 @@ import qualified Linear as L import Control.Lens ((^.)) import Control.Monad.RWS.Strict (liftIO) import qualified Control.Monad.RWS.Strict as RWS (get) -import Control.Concurrent.STM.TMVar (readTMVar) +import Control.Concurrent.STM.TVar (readTVarIO) import Control.Concurrent.STM (atomically) import Data.Distributive (distribute, collect) -- FFI @@ -366,7 +366,7 @@ drawMap = do render :: Pioneers () render = do state <- RWS.get - cam <- liftIO $ atomically $ readTMVar (state ^. camera) + cam <- liftIO $ readTVarIO (state ^. camera) let xa = cam ^. xAngle ya = cam ^. yAngle frust = cam ^. Types.frustum diff --git a/src/Types.hs b/src/Types.hs index c722d11..cbdba50 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue, TMVar) +import Control.Concurrent.STM (TQueue, TVar) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -161,12 +161,12 @@ data UIState = UIState data State = State { _window :: !WindowState - , _camera :: TMVar CameraState + , _camera :: TVar CameraState , _io :: !IOState , _mouse :: !MouseState , _keyboard :: !KeyboardState , _gl :: !GLState - , _game :: TMVar GameState + , _game :: TVar GameState , _ui :: !UIState } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 9ce6cc5..6b5d7f3 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -13,7 +13,7 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL -import Control.Concurrent.STM.TMVar (readTMVar, takeTMVar, putTMVar) +import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar) import Control.Concurrent.STM (atomically) @@ -108,7 +108,7 @@ eventCallback e = do if state ^. mouse.isDown && not (state ^. mouse.isDragging) then do - cam <- liftIO $ atomically $ readTMVar (state ^. camera) + cam <- liftIO $ readTVarIO (state ^. camera) modify $ (mouse.isDragging .~ True) . (mouse.dragStartX .~ fromIntegral x) . (mouse.dragStartY .~ fromIntegral y) @@ -139,11 +139,11 @@ eventCallback e = do do state <- get liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) + cam <- readTVar (state ^. camera) let zDist' = (cam ^. zDist) + realToFrac (negate vscroll) zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' cam' <- return $ zDist .~ zDist'' $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True