Merge branch 'Mapping'
This commit is contained in:
Jonas Betzendahl
commit
6fe3e3305a
@ -12,6 +12,7 @@ executable Pioneers
|
||||
ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm
|
||||
}
|
||||
other-modules:
|
||||
Map.Map,
|
||||
Map.Types,
|
||||
Map.Graphics,
|
||||
Map.Creation,
|
||||
@ -49,3 +50,33 @@ executable Pioneers
|
||||
attoparsec-binary >= 0.1
|
||||
Default-Language: Haskell2010
|
||||
|
||||
test-suite MapTests
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: tests/Map, src
|
||||
main-is: MapTestSuite.hs
|
||||
build-depends: base,
|
||||
OpenGL >=2.9,
|
||||
bytestring >=0.10,
|
||||
OpenGLRaw >=1.4,
|
||||
text >=0.11,
|
||||
array >=0.4,
|
||||
random >=1.0.1,
|
||||
transformers >=0.3.0,
|
||||
unordered-containers >= 0.2.1,
|
||||
hashable >= 1.0.1.1,
|
||||
mtl >=2.1.2,
|
||||
stm >=2.4.2,
|
||||
vector >=0.10.9 && <0.11,
|
||||
distributive >=0.3.2,
|
||||
linear >=1.3.1,
|
||||
lens >=4.0,
|
||||
SDL2 >= 0.1.0,
|
||||
time >=1.4.0,
|
||||
GLUtil >= 0.7,
|
||||
attoparsec >= 0.11.2,
|
||||
attoparsec-binary >= 0.1,
|
||||
QuickCheck,
|
||||
test-framework,
|
||||
test-framework-th,
|
||||
test-framework-quickcheck2
|
||||
Default-Language: Haskell2010
|
||||
|
||||
@ -1,46 +0,0 @@
|
||||
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)
|
||||
@ -2,19 +2,25 @@ module Map.Creation
|
||||
where
|
||||
|
||||
import Map.Types
|
||||
import Map.Map
|
||||
import Map.StaticMaps
|
||||
-- import Map.Map unused (for now)
|
||||
|
||||
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)
|
||||
-- preliminary
|
||||
infix 5 ->-
|
||||
(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
|
||||
f ->- g = g . f
|
||||
|
||||
random gen1 = let (a, gen2) = random gen1
|
||||
(b, gen3) = random gen2 in ((a,b), gen3)
|
||||
-- also preliminary
|
||||
infix 5 -<-
|
||||
(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
|
||||
f -<- g = f . g
|
||||
|
||||
exportedMap :: IO PlayMap
|
||||
exportedMap = do mounts <- mnt
|
||||
return $ aplAll mounts mapEmpty
|
||||
|
||||
-- | Generate a new Map of given Type and Size
|
||||
--
|
||||
@ -31,7 +37,10 @@ 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
|
||||
aplAll fs m = foldl (\ n f -> f n) m fs
|
||||
|
||||
aplAllM :: Monad m => [m a -> m a] -> m a -> m a
|
||||
aplAllM fs x = foldl (\ n f -> f n) x fs
|
||||
|
||||
-- general 3D-Gaussian
|
||||
gauss3Dgeneral :: Floating q =>
|
||||
@ -68,3 +77,37 @@ heightToTerrain GrassIslandMap y
|
||||
| y < 10 = Hill
|
||||
| otherwise = Mountain
|
||||
heightToTerrain _ _ = undefined
|
||||
|
||||
|
||||
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 = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) 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)
|
||||
|
||||
-- | Makes sure the edges of the Map are mountain-free
|
||||
makeIsland :: PlayMap -> PlayMap
|
||||
makeIsland = undefined -- tomorrow....
|
||||
|
||||
@ -30,9 +30,7 @@ import Linear
|
||||
import Control.Arrow ((***))
|
||||
|
||||
import Map.Types
|
||||
import Map.StaticMaps
|
||||
import Map.Creation
|
||||
import Map.Combinators
|
||||
|
||||
type Height = Float
|
||||
|
||||
@ -91,8 +89,8 @@ fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
|
||||
|
||||
getMapBufferObject :: IO (BufferObject, NumArrayIndices)
|
||||
getMapBufferObject = do
|
||||
mountains <- mnt
|
||||
myMap' <- return $ convertToGraphicsMap $ convertToStripeMap $ aplAll mountains mapEmpty
|
||||
eMap <- exportedMap
|
||||
myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap
|
||||
! myMap <- return $ generateTriangles myMap'
|
||||
len <- return $ fromIntegral $ P.length myMap `div` numComponents
|
||||
putStrLn $ P.unwords ["num verts in map:",show len]
|
||||
|
||||
@ -39,6 +39,3 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
|
||||
-- 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
|
||||
|
||||
@ -3,48 +3,47 @@ where
|
||||
|
||||
import Map.Types
|
||||
import Data.Array
|
||||
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]]
|
||||
|
||||
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]
|
||||
--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]
|
||||
|
||||
g2d :: Int -> Int -> Float
|
||||
g2d x y = gauss3D (fromIntegral x) (fromIntegral y)
|
||||
-- g2d :: Int -> Int -> Float
|
||||
-- g2d x y = gauss3D (fromIntegral x) (fromIntegral y)
|
||||
|
||||
m2d :: (Int,Int) -> Int
|
||||
m2d (x,y) = mnh2D (x,y) (100,100)
|
||||
-- m2d :: (Int,Int) -> Int
|
||||
-- m2d (x,y) = mnh2D (x,y) (100,100)
|
||||
|
||||
-- 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
|
||||
+ 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
|
||||
--_noisyMap :: (Floating q) => q -> q -> q
|
||||
--_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
|
||||
|
||||
-- generates a noisy map
|
||||
-- TODO: add real noise to a simple pattern
|
||||
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]]
|
||||
where
|
||||
height a b = _noisyMap (fromIntegral a) (fromIntegral b)
|
||||
--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]]
|
||||
-- where
|
||||
-- height a b = _noisyMap (fromIntegral a) (fromIntegral b)
|
||||
|
||||
23
tests/Map/MapTestSuite.hs
Normal file
23
tests/Map/MapTestSuite.hs
Normal file
@ -0,0 +1,23 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Test.QuickCheck
|
||||
|
||||
import Test.Framework
|
||||
import Test.Framework.TH
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
|
||||
import Map.Map
|
||||
|
||||
main :: IO ()
|
||||
main = $(defaultMainGenerator)
|
||||
|
||||
prop_rd_idempot :: [Int] -> Bool
|
||||
prop_rd_idempot xs = remdups xs == (remdups . remdups) xs
|
||||
|
||||
prop_rd_length :: [Int] -> Bool
|
||||
prop_rd_length xs = length (remdups xs) <= length xs
|
||||
|
||||
prop_rd_sorted :: [Int] -> Property
|
||||
prop_rd_sorted xs = (not . null) xs ==> head (remdups xs) == minimum xs
|
||||
Loading…
Reference in New Issue
Block a user