diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 0f2c60f..8f302c2 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,7 +2,19 @@ module Map.Creation where import Map.Types +import Map.Map + import Data.Array +import System.Random + +-- Orphan instance since this isn't where either Random nor Tuples are defined +instance (Random x, Random y) => Random (x, y) where + randomR ((x1, y1), (x2, y2)) gen1 = let (a, gen2) = randomR (x1, x2) gen1 + (b, gen3) = randomR (y1, y2) gen2 + in ((a, b), gen3) + + random gen1 = let (a, gen2) = random gen1 + (b, gen3) = random gen2 in ((a,b), gen3) -- | Generate a new Map of given Type and Size -- @@ -18,6 +30,32 @@ aplByPlace f g mp = array (bounds mp) (map (\(ab,c) -> if g ab then (ab, f c) el aplByNode :: (Node -> Node) -> (Node -> Bool) -> PlayMap -> PlayMap aplByNode f g mp = array (bounds mp) (map (\(ab,c) -> (if g c then (ab, f c) else (ab,c))) (assocs mp)) +aplAll :: [a -> a] -> a -> a +aplAll [] m = m +aplAll (f:fs) m = aplAll fs $ f m + +-- general 3D-Gaussian +gauss3Dgeneral :: Floating q => + q -- ^ Amplitude + -> q -- ^ Origin on X-Achsis + -> q -- ^ Origin on Z-Achsis + -> q -- ^ Sigma on X + -> q -- ^ Sigma on Z + -> 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))))) + +-- 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) @@ -38,4 +76,20 @@ type Seed = (XCoord, ZCoord) -- -- TODO: implement and erode terrain on the way down. addLakes :: PlayMap -> [Seed] -> PlayMap -addLakes m s = undefined +addLakes = undefined + +gaussMountain :: Int -> PlayMap -> PlayMap +gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp + where + g = mkStdGen seed + c = head $ randomRs (bounds mp) g + fi = fromIntegral + 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 10.0 (fi gx) (fi gz) 5.0 5.0 (fi x) (fi z) + liftUp (gx, gz) (Minimal (x,z)) = Full (x,z) e (htt GrassIslandMap e) BFlag NoPlayer NoPath Plain [] + where e = gauss3Dgeneral 10.0 (fi gx) (fi gz) 5.0 5.0 (fi x) (fi z) diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index d551790..2a35ea9 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -30,6 +30,7 @@ import Linear import Map.Types import Map.StaticMaps +import Map.Creation type Height = Float @@ -88,7 +89,9 @@ fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject = do - myMap' <- return $ convertToGraphicsMap $ convertToStripeMap mapNoise + let mountains = [(gaussMountain 123456), (gaussMountain 31415926), + (gaussMountain 101514119), (gaussMountain 0)] + myMap' <- return $ convertToGraphicsMap $ convertToStripeMap $ aplAll mountains mapEmpty ! myMap <- return $ generateTriangles myMap' len <- return $ fromIntegral $ P.length myMap `div` numComponents putStrLn $ P.unwords ["num verts in map:",show len] diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 0abaf38..b88a3b8 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -2,12 +2,43 @@ module Map.Map where import Map.Types --- potentially to be expanded to Nodes -giveNeighbours :: (Int, Int) -> [(Int,Int)] -giveNeighbours (x,y) = filter (not . negative) all +import Data.Array (bounds) +import Data.List (sort, group) + +-- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet. +unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates + -> [(Int,Int)] -- ^ list of neighbours +unsafeGiveNeighbours (x,z) = filter (not . negative) allNs where - all = if even y then [(x+1,y), (x-1,y), (x,y+1), (x,y-1), (x+1,y+1), (x+1,y-1)] - else [(x+1,y), (x-1,y), (x,y+1), (x,y-1), (x-1,y+1), (x-1,y-1)] + allNs = if even z then [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x+1,z+1), (x+1,z-1)] + else [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x-1,z+1), (x-1,z-1)] negative :: (Int, Int) -> Bool - negative (x,y) = x < 0 || y < 0 + negative (a,b) = a < 0 || b < 0 + +giveNeighbours :: PlayMap -- ^ Map on which to find neighbours + -> (Int, Int) -- ^ original coordinates + -> [(Int, Int)] -- ^ list of neighbours +giveNeighbours mp (x,z) = filter (not . outOfBounds mp) allNs + where + allNs = if even z then [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x+1,z+1), (x+1,z-1)] + else [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x-1,z+1), (x-1,z-1)] + + outOfBounds :: PlayMap -> (Int, Int) -> Bool + outOfBounds mp' (a,b) = let (lo,hi) = bounds mp' in + a < fst lo || b < snd lo || a > fst hi || b > snd hi + +giveNeighbourhood :: PlayMap -- ^ map on which to find neighbourhood + -> Int -- ^ iterative + -> (Int, Int) -- ^ original coordinates + -> [(Int, Int)] -- ^ neighbourhood +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) + +-- removing duplicates in O(n log n), losing order and adding Ord requirement +remdups :: Ord a => [a] -> [a] +remdups = map head . group . sort + +prop_rd_idempot :: Ord a => [a] -> Bool +prop_rd_idempot xs = remdups xs == (remdups . remdups) xs diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs index abe047e..9507a82 100644 --- a/src/Map/StaticMaps.hs +++ b/src/Map/StaticMaps.hs @@ -3,30 +3,7 @@ where import Map.Types import Data.Array -import Map.Creation (heightToTerrain) - --- general 3D-Gaussian -gauss3Dgeneral :: Floating q => - q -- ^ Amplitude - -> q -- ^ Origin on X-Achsis - -> q -- ^ Origin on Z-Achsis - -> q -- ^ Sigma on X - -> q -- ^ Sigma on Z - -> 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))))) - --- 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) +import Map.Creation -- entirely empty map, only uses the minimal constructor mapEmpty :: PlayMap