Merge remote-tracking branch 'origin/Mapping' into tessallation

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)
@@ -31,11 +69,3 @@ heightToTerrain GrassIslandMap y
                 | y < 10    = Hill
                 | otherwise = Mountain
 heightToTerrain _ _ = undefined
-
-type Seed = (XCoord, ZCoord)
-
--- | Add lakes on generated Map from (possible) Seeds noted before.
---
---   TODO: implement and erode terrain on the way down.
-addLakes :: PlayMap -> [Seed] -> PlayMap
-addLakes m s = undefined

src/Map/Graphics.hs

@@ -30,6 +30,8 @@ import Linear
 
 import Map.Types
 import Map.StaticMaps
+import Map.Creation
+import Map.Combinators
 
 type Height = Float
 
@@ -57,7 +59,7 @@ convertToGraphicsMap :: PlayMap -> GraphicsMap
 convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp]
     where
       graphicsyfy :: Node -> MapEntry
-      graphicsyfy (Minimal _               ) = (0, Grass)
+      graphicsyfy (Minimal _               ) = (1.0, Grass)
       graphicsyfy (Full    _ y t _ _ _ _ _ ) = (y, t)
 
 lineHeight :: GLfloat
@@ -88,7 +90,8 @@ fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
 
 getMapBufferObject :: IO (BufferObject, NumArrayIndices)
 getMapBufferObject = do
-        myMap'  <- return $ convertToGraphicsMap $ convertToStripeMap mapNoise
+        mountains <- mnt
+        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]

src/Map/Map.hs

@@ -2,12 +2,43 @@ module Map.Map where
 
 import Map.Types
 
--- potentially to be expanded to Nodes
+import Data.Array (bounds)
-giveNeighbours :: (Int, Int) -> [(Int,Int)]
+import Data.List  (sort, group)
-giveNeighbours (x,y) = filter (not . negative) all
+
+-- 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)]
+    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,y), (x-1,y), (x,y+1), (x,y-1), (x-1,y+1), (x-1,y-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

src/Map/StaticMaps.hs

@@ -3,30 +3,7 @@ where
 
 import Map.Types
 import Data.Array
-import Map.Creation (heightToTerrain)
+import Map.Creation
-
--- 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)
 
 -- entirely empty map, only uses the minimal constructor
 mapEmpty :: PlayMap

src/Map/Types.hs

@@ -68,5 +68,5 @@ data TileType   = Ocean
 
 -- 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 0
+          | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1
           deriving (Show)