diff --git a/src/Map/Combinators.hs b/src/Map/Combinators.hs new file mode 100644 index 0000000..9dabb89 --- /dev/null +++ b/src/Map/Combinators.hs @@ -0,0 +1,46 @@ +module Map.Combinators where + +import Map.Types +import Map.Creation + +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 + +lake :: Int -> PlayMap -> PlayMap +lake = undefined + +river :: Int -> PlayMap -> PlayMap +river = undefined + +mnt :: IO [PlayMap -> PlayMap] +mnt = do g <- newStdGen + let seeds = take 10 $ randoms g + return $ map gaussMountain seeds + +gaussMountain :: Int -> PlayMap -> PlayMap +gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp + where + g = mkStdGen seed + c = head $ randomRs (bounds mp) g + amp = head $ randomRs (5.0, 20.0) g + sig = head $ randomRs (5.0, 25.0) 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 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) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 0f2c60f..d677cdd 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,31 @@ 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 fs m = foldl (\ m f -> f m) m fs + +-- 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 +68,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 diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index d551790..5cc198a 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -27,9 +27,12 @@ import Foreign.Storable (sizeOf) import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Render.Misc (checkError) import Linear +import Control.Arrow ((***)) import Map.Types import Map.StaticMaps +import Map.Creation +import Map.Combinators type Height = Float @@ -41,7 +44,7 @@ type GraphicsMap = Array (Int, Int) MapEntry -- converts from classical x/z to striped version of a map convertToStripeMap :: PlayMap -> PlayMap -convertToStripeMap mp = array (stripify l, stripify u) (map (\(i,e) -> (stripify i,strp e)) (assocs mp)) +convertToStripeMap mp = array (stripify l, stripify u) (map (stripify *** strp) (assocs mp)) where (l,u) = bounds mp @@ -57,7 +60,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 @@ -75,7 +78,7 @@ bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat mapVertexArrayDescriptor count' offset = - VertexArrayDescriptor count' Float mapStride (bufferObjectPtr ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) + VertexArrayDescriptor count' Float mapStride (bufferObjectPtr (fromIntegral offset * sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first @@ -88,7 +91,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] diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 0abaf38..e358cee 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..74ea371 100644 --- a/src/Map/StaticMaps.hs +++ b/src/Map/StaticMaps.hs @@ -3,44 +3,21 @@ 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 -mapEmpty = array ((0,0), (199,199)) [((a,b), (Minimal (a,b))) | a <- [0..199], b <- [0..199]] +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] + 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) @@ -51,7 +28,7 @@ mapCenterMountain = array ((0,0),(199,199)) nodes -- 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 +_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 @@ -61,14 +38,13 @@ _noisyMap = \x y -> gauss3Dgeneral 15 100.0 100.0 15.0 15.0 x y 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]] + 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)) + height a b = _noisyMap (fromIntegral a) (fromIntegral b) diff --git a/src/Map/Types.hs b/src/Map/Types.hs index d3fe76c..c62837f 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -20,7 +20,7 @@ data PlayerInfo = NoPlayer instance Show PlayerInfo where show (NoPlayer) = "not occupied" - show (Occupied i) = "occupied by player " ++ (show i) + show (Occupied i) = "occupied by player " ++ show i -- | Path info, is this node part of a path and if so, where does it lead? data PathInfo = NoPath @@ -34,7 +34,7 @@ data ResInfo = Plain instance Show ResInfo where show (Plain) = "no resources" - show (ResInfo res amt) = "Resource: " ++ (show res) ++ "," ++ (show amt) + show (ResInfo res amt) = "Resource: " ++ show res ++ "," ++ show amt -- | What commodities are currently stored here? type StorInfo = [(Commodity,Amount)] @@ -49,7 +49,7 @@ data BuildInfo = BStruc Structure | BLarge instance Show BuildInfo where - show (BStruc s) = "Structure: " ++ (show s) + show (BStruc s) = "Structure: " ++ show s show (BNothing) = "no Structure possible" show (BFlag) = "only flags possible" show (BMine) = "mines possible" @@ -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)