Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-04-25 21:26:54 +02:00
commit 0af848996a
6 changed files with 149 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/Map/Combinators.hs Normal file
View File

@ -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)

45
src/Map/Creation.hs
View File

@ -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

12
src/Map/Graphics.hs
View File

@ -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]

43
src/Map/Map.hs
View File

@ -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

46
src/Map/StaticMaps.hs
View File

@ -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)
nodes = [((a,b), Full (a,b)
(height a b)
(heightToTerrain GrassIslandMap $ height a b)
BNothing
NoPlayer
NoPath
Plain
[])) | a <- [0..199], b <- [0..199]]
[]) | a <- [0..199], b <- [0..199]]
where
height a b = (_noisyMap (fromIntegral a) (fromIntegral b))
height a b = _noisyMap (fromIntegral a) (fromIntegral b)

8
src/Map/Types.hs
View File

@ -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)