From f5f1f760cda8d82835389ada0da71cf7e83be56e Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Sun, 27 Apr 2014 23:49:15 +0200 Subject: [PATCH 1/5] Added first test suite with first test (questionable .cabal though) --- Pioneers.cabal | 31 +++++++++++++++++++++++++++++++ src/Map/Map.hs | 2 +- tests/MainTestSuite.hs | 20 ++++++++++++++++++++ 3 files changed, 52 insertions(+), 1 deletion(-) create mode 100644 tests/MainTestSuite.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index 4aad55e..633c0c5 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -12,6 +12,8 @@ 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.Combinators, Map.Types, Map.Graphics, Map.Creation, @@ -49,3 +51,32 @@ executable Pioneers attoparsec-binary >= 0.1 Default-Language: Haskell2010 +test-suite QuickCheckTests + type: exitcode-stdio-1.0 + hs-source-dirs: tests, src + main-is: MainTestSuite.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-quickcheck2 + Default-Language: Haskell2010 diff --git a/src/Map/Map.hs b/src/Map/Map.hs index e358cee..ba697c0 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -40,5 +40,5 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in remdups :: Ord a => [a] -> [a] remdups = map head . group . sort -prop_rd_idempot :: Ord a => [a] -> Bool +prop_rd_idempot :: [Int] -> Bool prop_rd_idempot xs = remdups xs == (remdups . remdups) xs diff --git a/tests/MainTestSuite.hs b/tests/MainTestSuite.hs new file mode 100644 index 0000000..9c46a05 --- /dev/null +++ b/tests/MainTestSuite.hs @@ -0,0 +1,20 @@ +module Main where + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Map.Map + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ + testGroup "Map.Map" + [ + testProperty "remdups idempotency" prop_rd_idempot + ] + ] + + From 777c868de0aee39f58d272c7f5ebdb2abddfdc83 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Mon, 28 Apr 2014 10:37:31 +0200 Subject: [PATCH 2/5] Fixed shadowing in aplAll --- src/Map/Creation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index d677cdd..da0a12b 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -31,7 +31,7 @@ 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 -- general 3D-Gaussian gauss3Dgeneral :: Floating q => From 07dac9aad1bc0955d49bc2b32fd181fd72b9e523 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Mon, 28 Apr 2014 16:34:13 +0200 Subject: [PATCH 3/5] Added first test suite for Mapping --- Pioneers.cabal | 5 +++-- src/Map/Map.hs | 3 --- tests/MainTestSuite.hs | 20 -------------------- tests/Map/MapTestSuite.hs | 23 +++++++++++++++++++++++ 4 files changed, 26 insertions(+), 25 deletions(-) delete mode 100644 tests/MainTestSuite.hs create mode 100644 tests/Map/MapTestSuite.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index 633c0c5..de59517 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -53,8 +53,8 @@ executable Pioneers test-suite QuickCheckTests type: exitcode-stdio-1.0 - hs-source-dirs: tests, src - main-is: MainTestSuite.hs + hs-source-dirs: tests/Map, src + main-is: MapTestSuite.hs build-depends: base, OpenGL >=2.9, bytestring >=0.10, @@ -78,5 +78,6 @@ test-suite QuickCheckTests attoparsec-binary >= 0.1, QuickCheck, test-framework, + test-framework-th, test-framework-quickcheck2 Default-Language: Haskell2010 diff --git a/src/Map/Map.hs b/src/Map/Map.hs index ba697c0..7ea3593 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -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 :: [Int] -> Bool -prop_rd_idempot xs = remdups xs == (remdups . remdups) xs diff --git a/tests/MainTestSuite.hs b/tests/MainTestSuite.hs deleted file mode 100644 index 9c46a05..0000000 --- a/tests/MainTestSuite.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Main where - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Map.Map - -main :: IO () -main = defaultMain tests - -tests :: [Test] -tests = - [ - testGroup "Map.Map" - [ - testProperty "remdups idempotency" prop_rd_idempot - ] - ] - - diff --git a/tests/Map/MapTestSuite.hs b/tests/Map/MapTestSuite.hs new file mode 100644 index 0000000..e6a715d --- /dev/null +++ b/tests/Map/MapTestSuite.hs @@ -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 From 6c4e63f085d70acf8ac2679d3bd26d87f19b35db Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Tue, 29 Apr 2014 00:18:38 +0200 Subject: [PATCH 4/5] cosmetics --- Pioneers.cabal | 2 +- src/Map/Combinators.hs | 2 +- src/Map/Creation.hs | 12 +----------- 3 files changed, 3 insertions(+), 13 deletions(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index de59517..ec1f70a 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -51,7 +51,7 @@ executable Pioneers attoparsec-binary >= 0.1 Default-Language: Haskell2010 -test-suite QuickCheckTests +test-suite MapTests type: exitcode-stdio-1.0 hs-source-dirs: tests/Map, src main-is: MapTestSuite.hs diff --git a/src/Map/Combinators.hs b/src/Map/Combinators.hs index 9dabb89..7837fac 100644 --- a/src/Map/Combinators.hs +++ b/src/Map/Combinators.hs @@ -31,7 +31,7 @@ gaussMountain :: Int -> PlayMap -> PlayMap gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp where g = mkStdGen seed - c = head $ randomRs (bounds mp) g + 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 diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index da0a12b..b5d4ec3 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,19 +2,9 @@ module Map.Creation where import Map.Types -import Map.Map +-- 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) - - random gen1 = let (a, gen2) = random gen1 - (b, gen3) = random gen2 in ((a,b), gen3) -- | Generate a new Map of given Type and Size -- From 683b72a413b356d99635d31ddc6ed0fae9e22955 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Tue, 29 Apr 2014 01:05:05 +0200 Subject: [PATCH 5/5] Refactoring & more cosmetics --- Pioneers.cabal | 1 - src/Map/Combinators.hs | 46 ------------------------------ src/Map/Creation.hs | 53 +++++++++++++++++++++++++++++++++++ src/Map/Graphics.hs | 6 ++-- src/Map/StaticMaps.hs | 63 +++++++++++++++++++++--------------------- 5 files changed, 86 insertions(+), 83 deletions(-) delete mode 100644 src/Map/Combinators.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index ec1f70a..fadfec1 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -13,7 +13,6 @@ executable Pioneers } other-modules: Map.Map, - Map.Combinators, Map.Types, Map.Graphics, Map.Creation, diff --git a/src/Map/Combinators.hs b/src/Map/Combinators.hs deleted file mode 100644 index 7837fac..0000000 --- a/src/Map/Combinators.hs +++ /dev/null @@ -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 = 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) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index b5d4ec3..554cb6c 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,9 +2,25 @@ module Map.Creation where import Map.Types +import Map.StaticMaps -- import Map.Map unused (for now) 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 + +exportedMap :: IO PlayMap +exportedMap = do mounts <- mnt + return $ aplAll mounts mapEmpty -- | Generate a new Map of given Type and Size -- @@ -23,6 +39,9 @@ aplByNode f g mp = array (bounds mp) (map (\(ab,c) -> (if g c then (ab, f c) els aplAll :: [a -> a] -> a -> a 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 => q -- ^ Amplitude @@ -58,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.... diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 5cc198a..858b1f4 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -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] diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs index 74ea371..5ef9942 100644 --- a/src/Map/StaticMaps.hs +++ b/src/Map/StaticMaps.hs @@ -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)