Merge branch 'master' into ui

Conflicts:
	src/Types.hs

.gitignore

@@ -1,3 +1,11 @@
 /.dist-buildwrapper
 /.project
 /.settings
+.cabal-sandbox
+*.trace
+cabal.sandbox.config
+deps/hsSDL2*
+deps/*.deb
+dist/*
+*.swp
+

Pioneers.cabal

@@ -16,14 +16,15 @@ executable Pioneers
                    Map.Graphics,
                    Map.Creation,
                    Map.StaticMaps,
-                   IQM.Types,
+                   Importer.IQM.Types,
-                   IQM.TestMain,
+                   Importer.IQM.TestMain,
-                   IQM.Parser,
+                   Importer.IQM.Parser,
                    Render.Misc,
                    Render.Render,
                    Render.RenderObject,
+                   Render.Types,
                    UI.Callbacks,
-                   Types,
+                   UI.Types,
                    UI.SurfaceOverlay
                    Types
   main-is:         Main.hs
@@ -47,7 +48,7 @@ executable Pioneers
                    SDL2 >= 0.1.0,
                    time >=1.4.0,
                    GLUtil >= 0.7,
-                   attoparsec >= 0.11.2
+                   attoparsec >= 0.11.2,
-  other-modules:   Render.Types
+                   attoparsec-binary >= 0.1
   Default-Language: Haskell2010
 

README

@@ -1,4 +0,0 @@
-Pioneers
-========
-
-A Settlers II inspired game written in Haskell

README.md

@@ -0,0 +1,39 @@
+# Pioneers
+
+A Settlers II inspired game written in Haskell
+
+## Development-Status
+
+Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers
+
+## Compiling
+
+1. 	Clone this repository
+2. 	Set up cabal-sandbox
+	```
+	$ cabal sandbox init
+	$ cd deps
+	$ ./getDeps.sh
+	$ cd ..
+	$ cabal sandbox add-source deps/hsSDL2
+	```
+3. 	install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04)
+4. 	install dependencies `cabal install --only-dependencies`
+5. 	build `cabal build`
+6. 	run `./Pioneers`
+
+Step 2 is likely to break in the future due to restructuring in hsSDL2. This will be updated accordingly then.
+
+## Features
+
+Note, that most of it is just planned and due to change.
+
+- modern OpenGL3.x-Engine
+- themeable with different Cultures
+- rock-solid Multiplayer (no desync, just slightly more lag in case of resync)
+
+## Why Haskell?
+
+- There are not enough good games written in functional languages.
+- More robust and easier to reason about lateron
+

shaders/map/tessEval.shader

@@ -2,6 +2,101 @@
 
 #extension GL_ARB_tessellation_shader : require
 
+//#include "shaders/3rdParty/noise.glsl"
+
+vec3 mod289(vec3 x) {
+  return x - floor(x * (1.0 / 289.0)) * 289.0;
+}
+
+vec4 mod289(vec4 x) {
+  return x - floor(x * (1.0 / 289.0)) * 289.0;
+}
+
+vec4 permute(vec4 x) {
+     return mod289(((x*34.0)+1.0)*x);
+}
+
+vec4 taylorInvSqrt(vec4 r)
+{
+  return 1.79284291400159 - 0.85373472095314 * r;
+}
+
+float snoise(vec3 v)
+  {
+  const vec2  C = vec2(1.0/6.0, 1.0/3.0) ;
+  const vec4  D = vec4(0.0, 0.5, 1.0, 2.0);
+
+// First corner
+  vec3 i  = floor(v + dot(v, C.yyy) );
+  vec3 x0 =   v - i + dot(i, C.xxx) ;
+
+// Other corners
+  vec3 g = step(x0.yzx, x0.xyz);
+  vec3 l = 1.0 - g;
+  vec3 i1 = min( g.xyz, l.zxy );
+  vec3 i2 = max( g.xyz, l.zxy );
+
+  //   x0 = x0 - 0.0 + 0.0 * C.xxx;
+  //   x1 = x0 - i1  + 1.0 * C.xxx;
+  //   x2 = x0 - i2  + 2.0 * C.xxx;
+  //   x3 = x0 - 1.0 + 3.0 * C.xxx;
+  vec3 x1 = x0 - i1 + C.xxx;
+  vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y
+  vec3 x3 = x0 - D.yyy;      // -1.0+3.0*C.x = -0.5 = -D.y
+
+// Permutations
+  i = mod289(i);
+  vec4 p = permute( permute( permute(
+             i.z + vec4(0.0, i1.z, i2.z, 1.0 ))
+           + i.y + vec4(0.0, i1.y, i2.y, 1.0 ))
+           + i.x + vec4(0.0, i1.x, i2.x, 1.0 ));
+
+// Gradients: 7x7 points over a square, mapped onto an octahedron.
+// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294)
+  float n_ = 0.142857142857; // 1.0/7.0
+  vec3  ns = n_ * D.wyz - D.xzx;
+
+  vec4 j = p - 49.0 * floor(p * ns.z * ns.z);  //  mod(p,7*7)
+
+  vec4 x_ = floor(j * ns.z);
+  vec4 y_ = floor(j - 7.0 * x_ );    // mod(j,N)
+
+  vec4 x = x_ *ns.x + ns.yyyy;
+  vec4 y = y_ *ns.x + ns.yyyy;
+  vec4 h = 1.0 - abs(x) - abs(y);
+
+  vec4 b0 = vec4( x.xy, y.xy );
+  vec4 b1 = vec4( x.zw, y.zw );
+
+  //vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0;
+  //vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0;
+  vec4 s0 = floor(b0)*2.0 + 1.0;
+  vec4 s1 = floor(b1)*2.0 + 1.0;
+  vec4 sh = -step(h, vec4(0.0));
+
+  vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ;
+  vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ;
+
+  vec3 p0 = vec3(a0.xy,h.x);
+  vec3 p1 = vec3(a0.zw,h.y);
+  vec3 p2 = vec3(a1.xy,h.z);
+  vec3 p3 = vec3(a1.zw,h.w);
+
+//Normalise gradients
+  vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
+  p0 *= norm.x;
+  p1 *= norm.y;
+  p2 *= norm.z;
+  p3 *= norm.w;
+
+// Mix final noise value
+  vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0);
+  m = m * m;
+  return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1),
+                                dot(p2,x2), dot(p3,x3) ) );
+  }
+
+
 layout(triangles, equal_spacing, cw) in;
 in vec3 tcPosition[];
 in vec4 tcColor[];
@@ -38,6 +133,7 @@ void main()
     float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal));
     float standout = i0+i1+i2;
     tePosition = tePosition+tessNormal*standout;
+    tePosition = tePosition+0.05*snoise(tePosition);
     gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1);
     fogDist = gl_Position.z;
 

src/Importer/IQM/Parser.hs

@@ -8,84 +8,98 @@ module Importer.IQM.Parser (parseIQM) where
 import Importer.IQM.Types
 import Data.Attoparsec.ByteString.Char8
 import Data.Attoparsec.ByteString
+import Data.Attoparsec.Binary
 import Data.ByteString.Char8 (pack)
-import Data.ByteString (split, null)
+import Data.ByteString (split, null, ByteString)
+import Data.ByteString.Unsafe (unsafeUseAsCString)
+import qualified Data.ByteString as B
 import Data.Word
 import Data.Int
 import Unsafe.Coerce
 import Control.Monad.Trans.State
 import Control.Monad.Trans.Class
 import Control.Monad
+import Foreign.Ptr
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
 
 import Prelude as P hiding (take, null)
 
 -- | helper-function for creating an integral out of [8-Bit Ints]
-w8ToInt :: Integral a => a -> a -> a
+_w8ToInt :: Integral a => a -> a -> a
-w8ToInt i add = 256*i + add
+_w8ToInt i add = 256*i + add
 
 -- | shorthand-function for parsing Word8 into Integrals
-parseNum :: (Integral a, Integral b) => [a] -> b
+_parseNum :: (Integral a, Integral b) => [a] -> b
-parseNum = (foldl1 w8ToInt) . map fromIntegral
+_parseNum = foldl1 _w8ToInt . map fromIntegral
 
 -- | read a 16-Bit Int from Parsing-Input and log 2 bytes in our Parsing-Monad
 --
 --   begins with _ to defeat ghc-warnings. Rename if used!
-_int16 :: CParser Int16
+_int16 :: CParser Word16
 _int16 = do
         ret <- lift $ do
                          a <- anyWord8 :: Parser Word8
                          b <- anyWord8 :: Parser Word8
-                         return $ parseNum [b,a]
+                         return $ _parseNum [b,a]
         modify (+2)
         return ret
 
 -- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad
-int32 :: CParser Int32
+_int32 :: CParser Int32
-int32 = do
+_int32 = do
         ret <- lift $ do
                          a <- anyWord8 :: Parser Word8
                          b <- anyWord8 :: Parser Word8
                          c <- anyWord8 :: Parser Word8
                          d <- anyWord8 :: Parser Word8
-                         return $ parseNum [d,c,b,a]
+                         return $ _parseNum [d,c,b,a]
         modify (+4)
-        return $ ret
+        return ret
+
+w32leCParser :: CParser Word32
+w32leCParser = do
+	ret <- lift anyWord32le
+	modify (+4)
+	return ret
 
 -- | Parser for the header
 readHeader :: CParser IQMHeader
 readHeader = do
          _ <- lift $ string (pack "INTERQUAKEMODEL\0")
-         v <- int32
+         modify (+16)
-         -- when v /= 2 then --TODO: error something
+         v <- w32leCParser
-         size' <- int32
+	 lift $ when (v /= 2) $ fail "Version /= 2.\nThis Parser only supports Version 2 of the InterQuake-Model IQM"
-         flags' <- int32
+         -- when v /= 2 then fail parsing.
-         num_text' <- int32
+         size' <- w32leCParser
-         ofs_text' <- int32
+         flags' <- w32leCParser
-         num_meshes' <- int32
+         num_text' <- w32leCParser
-         ofs_meshes' <- int32
+         ofs_text' <- w32leCParser
-         num_vertexarrays' <- int32
+         num_meshes' <- w32leCParser
-         num_vertexes' <- int32
+         ofs_meshes' <- w32leCParser
-         ofs_vertexarrays' <- int32
+         num_vertexarrays' <- w32leCParser
-         num_triangles' <- int32
+         num_vertexes' <- w32leCParser
-         ofs_triangles' <- int32
+         ofs_vertexarrays' <- w32leCParser
-         ofs_adjacency' <- int32
+         num_triangles' <- w32leCParser
-         num_joints' <- int32
+         ofs_triangles' <- w32leCParser
-         ofs_joints' <- int32
+         ofs_adjacency' <- w32leCParser
-         num_poses' <- int32
+         num_joints' <- w32leCParser
-         ofs_poses' <- int32
+         ofs_joints' <- w32leCParser
-         num_anims' <- int32
+         num_poses' <- w32leCParser
-         ofs_anims' <- int32
+         ofs_poses' <- w32leCParser
-         num_frames' <- int32
+         num_anims' <- w32leCParser
-         num_framechannels' <- int32
+         ofs_anims' <- w32leCParser
-         ofs_frames' <- int32
+         num_frames' <- w32leCParser
-         ofs_bounds' <- int32
+         num_framechannels' <- w32leCParser
-         num_comment' <- int32
+         ofs_frames' <- w32leCParser
-         ofs_comment' <- int32
+         ofs_bounds' <- w32leCParser
-         num_extensions' <- int32
+         num_comment' <- w32leCParser
-         ofs_extensions' <- int32
+         ofs_comment' <- w32leCParser
+         num_extensions' <- w32leCParser
+         ofs_extensions' <- w32leCParser
          return IQMHeader { version = v
                 , filesize           = size'
-                , flags              = flags'
+                , flags              = fromIntegral flags'
                 , num_text           = num_text'
                 , ofs_text           = ofs_text'
                 , num_meshes         = num_meshes'
@@ -115,12 +129,12 @@ readHeader = do
 -- | Parser for Mesh-Structure
 readMesh :: CParser IQMMesh
 readMesh = do
-        name <- int32
+        name <- w32leCParser
-        mat <- int32
+        mat <- w32leCParser
-        fv <- int32
+        fv <- w32leCParser
-        nv <- int32
+        nv <- w32leCParser
-        ft <- int32
+        ft <- w32leCParser
-        nt <- int32
+        nt <- w32leCParser
         return IQMMesh
                 { meshName              = if name == 0 then Nothing else Just (Mesh name)
                 , meshMaterial          = mat
@@ -140,12 +154,32 @@ readMeshes n = do
         ms <- readMeshes (n-1)
         return $ m:ms
 
+-- | Parser for Mesh-Structure
+readVAF :: CParser IQMVertexArray
+readVAF = do
+        vat <- rawEnumToVAT =<< w32leCParser
+        flags' <- w32leCParser
+        format <- rawEnumToVAF =<< w32leCParser
+        size <- w32leCParser
+        offset <- w32leCParser
+        return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset nullPtr
+
+-- | helper to read n consecutive Meshes tail-recursive
+readVAFs :: Int -> CParser [IQMVertexArray]
+readVAFs 1 = do
+        f <- readVAF
+        return [f]
+readVAFs n = do
+        f <- readVAF
+        fs <- readVAFs (n-1)
+        return $ f:fs
+
 -- | helper-Notation for subtracting 2 integral values of different kind in the precision
 --   of the target-kind
 (.-) :: forall a a1 a2.
               (Num a, Integral a2, Integral a1) =>
               a1 -> a2 -> a
-(.-) a b = (fromIntegral a) - (fromIntegral b)
+(.-) a b = fromIntegral a - fromIntegral b
 
 infix 5 .-
 
@@ -162,18 +196,69 @@ skipToCounter a = do
                         put d
 
 -- | Parses an IQM-File and handles back the Haskell-Structure
-parseIQM :: CParser IQM
+--
-parseIQM = do
+--   Does a 2-Pass-Parsing. Reads in Structure on first pass (O(n))and
-        put 0                                                   --start at offset 0
+--   fills the Structure in a 2nd Pass from Offsets (O(memcpy'd bytes)).
+parseIQM :: String -> IO IQM
+parseIQM a =
+	do
+	f <- B.readFile a
+	-- Parse Headers/Offsets
+	let result = parse doIQMparse f
+	raw <- case result of
+		Done _ x -> return x
+		y -> error $ show y
+	-- Fill Vertex-Arrays with data of Offsets
+	let 	va = vertexArrays raw
+	va' <- mapM (readInVAO f) va
+	return $ raw {
+		vertexArrays = va'
+		}
+
+-- | Allocates memory for the Vertex-data and copies it over there
+--   from the given input-String
+--
+--   Note: The String-Operations are O(1), so only O(numberOfCopiedBytes)
+--   is needed in term of computation.
+readInVAO :: ByteString -> IQMVertexArray -> IO IQMVertexArray
+readInVAO d (IQMVertexArray type' a format num offset ptr) = 
+		do
+		let 
+			byteLen = fromIntegral num * vaSize format
+			data' = skipDrop (fromIntegral offset) byteLen d
+			
+		unless (ptr == nullPtr) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type'
+		p <- mallocBytes byteLen
+		putStrLn $ concat ["Allocating ", show byteLen, " Bytes at ", show p]
+		unsafeUseAsCString data' (\s -> copyBytes p s byteLen)
+		return $ IQMVertexArray type' a format num offset $ castPtr p
+		
+-- | Real internal Parser.
+--
+--   Consumes the String only once, thus in O(n). But all Data-Structures are
+--   not allocated and copied. readInVAO has to be called on each one.
+doIQMparse :: Parser IQM
+doIQMparse = 
+	flip evalStateT 0 $ --evaluate parser with state starting at 0
+		do
         	h <- readHeader                                         --read header
 	        skipToCounter $ ofs_text h                              --skip 0-n bytes to get to text
 	        text <- lift . take . fromIntegral $ num_text h         --read texts
 	       	modify . (+) . fromIntegral $ num_text h                --put offset forward
 	        skipToCounter $ ofs_meshes h                            --skip 0-n bytes to get to meshes
-        meshes' <- readMeshes (fromIntegral (num_meshes h))     --read meshes
+	        meshes' <- readMeshes $ fromIntegral $ num_meshes h     --read meshes
+		skipToCounter $ ofs_vertexarrays h			--skip 0-n bytes to get to Vertex-Arrays
+                vaf <- readVAFs $ fromIntegral $ num_vertexarrays h     --read Vertex-Arrays
 	        return IQM
 	                { header = h
 	                , texts = filter (not.null) (split (unsafeCoerce '\0') text)
 	                , meshes = meshes'
+			, vertexArrays = vaf
 	                }
 
+-- | Helper-Function for Extracting a random substring out of a Bytestring
+--   by the Offsets provided.
+--
+--   O(1).
+skipDrop :: Int -> Int -> ByteString -> ByteString
+skipDrop a b= B.drop b . B.take a

src/Importer/IQM/Types.hs

@@ -1,19 +1,39 @@
--- | Int32 or Int64 - depending on implementation. Format just specifies "uint".
+-- {-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-}
---   4-Byte in the documentation indicates Int32 - but not specified!
+-- | Word32 or Word64 - depending on implementation. Format just specifies "uint".
+--   4-Byte in the documentation indicates Word32 - but not specified!
 module Importer.IQM.Types where
 
+import Control.Monad.Trans.State.Lazy (StateT)
 import Data.Int
+import Data.Word
 import Data.ByteString
 import Data.Attoparsec.ByteString.Char8
-import Control.Monad.Trans.State.Lazy (StateT)
+import Foreign.Ptr
+import Graphics.Rendering.OpenGL.Raw.Types
+import Prelude as P
+import Foreign.Storable
+import Foreign.C.Types
 
 -- | Mesh-Indices to distinguish the meshes referenced
-newtype Mesh = Mesh Int32 deriving (Show, Eq)
+newtype Mesh = Mesh Word32 deriving (Show, Eq)
 -- | State-Wrapped Parser-Monad which is capable of counting the
 --   Bytes read for offset-gap reasons
 type CParser a = StateT Int64 Parser a
 
+-- | Alias
+type Flags = GLbitfield      -- ^ Alias for UInt32
 
+-- | Alias
+type Offset = Word32         -- ^ Alias for UInt32
+
+-- | Alias
+type Index = GLuint          -- ^ Alias for UInt32
+
+-- | Alias
+type NumComponents = GLsizei -- ^ Alias for UInt32
+
+-- | Data-BLOB inside IQM
+type IQMData = Ptr IQMVertexArrayFormat -- ^ Pointer for Data
 
 -- | Header of IQM-Format.
 --
@@ -23,33 +43,33 @@ type CParser a = StateT Int64 Parser a
 --
 --   ofs_* fields are aligned at 4-byte-boundaries
 data IQMHeader = IQMHeader
-                { version            :: Int32 -- ^ Must be 2
+                { version            :: !Word32 -- ^ Must be 2
-                , filesize           :: Int32
+                , filesize           :: !Word32
-                , flags              :: Int32
+                , flags              :: !Flags
-                , num_text           :: Int32
+                , num_text           :: !Word32
-                , ofs_text           :: Int32
+                , ofs_text           :: !Offset
-                , num_meshes         :: Int32
+                , num_meshes         :: !Word32
-                , ofs_meshes         :: Int32
+                , ofs_meshes         :: !Offset
-                , num_vertexarrays   :: Int32
+                , num_vertexarrays   :: !Word32
-                , num_vertexes       :: Int32
+                , num_vertexes       :: !Word32
-                , ofs_vertexarrays   :: Int32
+                , ofs_vertexarrays   :: !Offset
-                , num_triangles      :: Int32
+                , num_triangles      :: !Word32
-                , ofs_triangles      :: Int32
+                , ofs_triangles      :: !Offset
-                , ofs_adjacency      :: Int32
+                , ofs_adjacency      :: !Offset
-                , num_joints         :: Int32
+                , num_joints         :: !Word32
-                , ofs_joints         :: Int32
+                , ofs_joints         :: !Offset
-                , num_poses          :: Int32
+                , num_poses          :: !Word32
-                , ofs_poses          :: Int32
+                , ofs_poses          :: !Offset
-                , num_anims          :: Int32
+                , num_anims          :: !Word32
-                , ofs_anims          :: Int32
+                , ofs_anims          :: !Offset
-                , num_frames         :: Int32
+                , num_frames         :: !Word32
-                , num_framechannels  :: Int32
+                , num_framechannels  :: !Word32
-                , ofs_frames         :: Int32
+                , ofs_frames         :: !Offset
-                , ofs_bounds         :: Int32
+                , ofs_bounds         :: !Offset
-                , num_comment        :: Int32
+                , num_comment        :: !Word32
-                , ofs_comment        :: Int32
+                , ofs_comment        :: !Offset
-                , num_extensions     :: Int32 -- ^ stored as linked list, not as array.
+                , num_extensions     :: !Word32 -- ^ stored as linked list, not as array.
-                , ofs_extensions     :: Int32
+                , ofs_extensions     :: !Offset
                 } deriving (Show, Eq)
 
 -- | Format of an IQM-Mesh Structure.
@@ -57,13 +77,29 @@ data IQMHeader = IQMHeader
 --   Read it like a Header of the Meshes lateron in the Format
 data IQMMesh = IQMMesh
                 { meshName              :: Maybe Mesh
-                , meshMaterial          :: Int32
+                , meshMaterial          :: Word32
-                , meshFirstVertex       :: Int32
+                , meshFirstVertex       :: Word32
-                , meshNumVertexes       :: Int32
+                , meshNumVertexes       :: Word32
-                , meshFirstTriangle     :: Int32
+                , meshFirstTriangle     :: Word32
-                , meshNumTriangles      :: Int32
+                , meshNumTriangles      :: Word32
                 } deriving (Show, Eq)
 
+-- | Format of IQM-Triangle Structure
+data IQMTriangle = IQMTriangle VertexIndex VertexIndex VertexIndex
+
+-- | Type-Alias for Word32 indicating an index on vertices in IQMMesh
+type VertexIndex = Word32
+
+-- | Type-Alias for Word32 indicating an index on IQMTriangle
+type TriangleIndex = Word32
+
+-- | From the IQM-Format-Description:
+--
+--   each value is the index of the adjacent triangle for edge 0, 1, and 2, where ~0 (= -1)
+--   indicates no adjacent triangle indexes are relative to the iqmheader.ofs_triangles array
+--   and span all meshes, where 0 is the first triangle, 1 is the second, 2 is the third, etc.
+data IQMAdjacency = IQMAdjacency TriangleIndex TriangleIndex TriangleIndex
+
 -- | Format of a whole IQM-File
 --
 --   still unfinished!
@@ -71,5 +107,97 @@ data IQM = IQM
         { header                :: IQMHeader
         , texts                 :: [ByteString]
         , meshes                :: [IQMMesh]
+        , vertexArrays          :: [IQMVertexArray]
         } deriving (Show, Eq)
 
+-- | Different Vertex-Array-Types in IQM
+--
+--   Custom Types have to be > 0x10 as of specification
+data IQMVertexArrayType = IQMPosition
+                       | IQMTexCoord
+                       | IQMNormal
+                       | IQMTangent
+                       | IQMBlendIndexes
+                       | IQMBlendWeights
+                       | IQMColor
+                       | IQMCustomVAT Word32
+                       deriving (Show, Eq)
+
+-- | Lookup-Function for internal enum to VertexArrayFormat
+rawEnumToVAT :: Word32 -> CParser IQMVertexArrayType
+rawEnumToVAT 0 = return IQMPosition
+rawEnumToVAT 1 = return IQMTexCoord
+rawEnumToVAT 2 = return IQMNormal
+rawEnumToVAT 3 = return IQMTangent
+rawEnumToVAT 4 = return IQMBlendIndexes
+rawEnumToVAT 5 = return IQMBlendWeights
+rawEnumToVAT 6 = return IQMColor
+rawEnumToVAT a = return $ IQMCustomVAT a
+
+-- | Vetrex-Array-Format of the data found at offset
+data IQMVertexArrayFormat = IQMbyte
+                            | IQMubyte
+                            | IQMshort
+                            | IQMushort
+                            | IQMint
+                            | IQMuint
+                            | IQMhalf
+                            | IQMfloat
+                            | IQMdouble
+--                            | Unknown Word32
+                       deriving (Show, Eq)
+
+-- | Get the Size (in Bytes) of the given IQMVertexArrayFormat-Struct
+vaSize :: IQMVertexArrayFormat -> Int
+vaSize IQMbyte 		= sizeOf (undefined :: CSChar)
+vaSize IQMubyte 	= sizeOf (undefined :: CUChar)
+vaSize IQMshort 	= sizeOf (undefined :: CShort)
+vaSize IQMushort 	= sizeOf (undefined :: CUShort)
+vaSize IQMint 		= sizeOf (undefined :: CInt)
+vaSize IQMuint 		= sizeOf (undefined :: CUInt)
+vaSize IQMhalf 		= sizeOf (undefined :: Word16) --TODO: Find 16-Bit-Float-Datatype FIXME!
+vaSize IQMfloat 	= sizeOf (undefined :: CFloat)
+vaSize IQMdouble 	= sizeOf (undefined :: CDouble)
+
+--mallocVArray :: Storable a => IQMVertexArrayFormat -> Int -> IO (Ptr a)
+--mallocVArray IQMbyte n	= mallocArray n :: IO (Ptr CSChar)
+--mallocVArray IQMubyte n	= mallocArray n :: IO (Ptr CUChar)
+
+-- | Lookup-Function for internal enum to VertexArrayFormat
+rawEnumToVAF :: Word32 -> CParser IQMVertexArrayFormat
+rawEnumToVAF 0 = return IQMbyte
+rawEnumToVAF 1 = return IQMubyte
+rawEnumToVAF 2 = return IQMshort
+rawEnumToVAF 3 = return IQMushort
+rawEnumToVAF 4 = return IQMint
+rawEnumToVAF 5 = return IQMuint
+rawEnumToVAF 6 = return IQMhalf
+rawEnumToVAF 7 = return IQMfloat
+rawEnumToVAF 8 = return IQMdouble
+--rawEnumToVAF a = return $ Unknown a
+rawEnumToVAF a = fail $ P.concat ["unrecognized enum(",show a,") in VertexArrayFormat"]
+
+
+-- | A Vertex-Array-Definiton.
+--
+--   The Vertex starts at Offset and has num_vertexes * NumComponents entries.
+--
+--   All Vertex-Arrays seem to have the same number of components, just differ in Type, Format
+--   and Flags
+data IQMVertexArray = IQMVertexArray
+                        IQMVertexArrayType
+                        Flags
+                        IQMVertexArrayFormat
+                        NumComponents
+                        Offset
+			IQMData
+                       deriving (Eq)
+instance Show IQMVertexArray where
+    show (IQMVertexArray t fl fo nc off dat) = "IQMVertexArray (Type: " ++ show t ++
+                                                        ", Flags: " ++ show fl ++
+                                                        ", Format: " ++ show fo ++
+                                                        ", NumComponents: " ++ show nc ++
+                                                        ", Offset: " ++ show off ++
+							", Data at: " ++ show dat ++ 
+                                                        ")"
+

src/Main.hs

@@ -16,7 +16,6 @@ import           Control.Concurrent.STM               (TQueue,
                                                        newTQueueIO)
 
 import           Control.Monad.RWS.Strict             (ask, evalRWST, get, liftIO, modify)
-import           Control.Monad.Trans.State            (evalStateT)
 import           Data.Functor                         ((<$>))
 import           Data.Monoid                          (mappend)
 
@@ -46,17 +45,21 @@ import           UI.Callbacks
 import           Map.Graphics
 import           Types
 import           Importer.IQM.Parser
-import           Data.Attoparsec.Char8 (parseTest)
+--import           Data.Attoparsec.Char8 (parseTest)
-import qualified Data.ByteString as B
+--import qualified Data.ByteString as B
 
 -- import qualified Debug.Trace                          as D (trace)
 
 --------------------------------------------------------------------------------
 
-testParser :: IO ()
+testParser :: String -> IO ()
-testParser = do
+testParser a = putStrLn . show  =<< parseIQM a
-        f <- B.readFile "sample.iqm"
+{-do
-        parseTest (evalStateT parseIQM 0) f
+		f <- B.readFile a
+		putStrLn "reading in:"
+		putStrLn $ show f
+		putStrLn "parsed:"
+		parseTest parseIQM f-}
 
 --------------------------------------------------------------------------------
 
@@ -82,9 +85,7 @@ main =
         (Size fbWidth fbHeight) <- glGetDrawableSize window'
         initRendering
         --generate map vertices
-        (mapBuffer, vert) <- getMapBufferObject
+        glMap' <- initMapShader 4 =<< getMapBufferObject
-        (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader
-        overTex <- GL.genObjectName
         print window'
         eventQueue <- newTQueueIO :: IO (TQueue Event)
         putStrLn "foo"
@@ -110,23 +111,6 @@ main =
                 , _left     = False
                 , _right    = False
             }
-            glMap' = GLMapState
-                { _shdrVertexIndex      = vi
-                , _shdrNormalIndex      = ni
-                , _shdrColorIndex       = ci
-                , _shdrProjMatIndex     = pri
-                , _shdrViewMatIndex     = vii
-                , _shdrModelMatIndex    = mi
-                , _shdrNormalMatIndex   = nmi
-                , _shdrTessInnerIndex   = tli
-                , _shdrTessOuterIndex   = tlo
-                , _stateTessellationFactor = 4
-                , _stateMap             = mapBuffer
-                , _mapVert              = vert
-                , _mapProgram           = mapprog
-                , _mapTexture           = mapTex
-                , _overviewTexture      = overTex
-                }
             env = Env
               { _eventsChan      = eventQueue
               , _windowObject    = window'
@@ -305,7 +289,7 @@ adjustWindow = do
 
 
                    let hudtexid = state ^. gl.glHud.hudTexture
-                       maptexid = state ^. gl.glMap.mapTexture
+                       maptexid = state ^. gl.glMap.renderedMapTexture
                    allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
                                                                --default to ugly pink to see if
                                                                --somethings go wrong.

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)

src/Map/Creation.hs

@@ -2,15 +2,59 @@ 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
 --
 --   TODO:
 --   1. Should take Size -> Type -> Playmap
 --   2. plug together helper-functions for that terraintype
-newMap :: Int -> Int -> PlayMap
+newMap :: MapType -> (Int, Int) -> PlayMap
 newMap = undefined
 
+aplByPlace :: (Node -> Node) -> ((Int,Int) -> Bool) -> PlayMap -> PlayMap
+aplByPlace f g mp = array (bounds mp) (map (\(ab,c) -> if g ab then (ab, f c) else (ab,c)) (assocs mp))
+
+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)
@@ -24,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

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]

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,45 +3,21 @@ 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
-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]]
 
--- TODO: Stripify
 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]
+      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]
+      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]
+      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]
+      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]
+      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)
@@ -52,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
@@ -62,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
+      nodes    = [((a,b), Full (a,b)
-                            (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)

src/Map/Types.hs

@@ -1,7 +1,7 @@
 module Map.Types
 where
 
-import PioneerTypes
+import Types
 
 import Data.Array
 
@@ -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)

src/PioneerTypes.hs

@@ -1,62 +0,0 @@
-module PioneerTypes
-where
-
-data Structure = Flag           -- Flag
-               | Woodcutter     -- Huts
-               | Forester
-               | Stonemason
-               | Fisher
-               | Hunter
-               | Barracks
-               | Guardhouse
-               | LookoutTower
-               | Well
-               | Sawmill        -- Houses
-               | Slaughterhouse
-               | Mill
-               | Bakery
-               | IronSmelter
-               | Metalworks
-               | Armory
-               | Mint
-               | Shipyard
-               | Brewery
-               | Storehouse
-               | Watchtower
-               | Catapult
-               | GoldMine       -- Mines
-               | IronMine
-               | GraniteMine
-               | CoalMine
-               | Farm           -- Castles
-               | PigFarm
-               | DonkeyBreeder
-               | Harbor
-               | Fortress
-               deriving (Show, Eq)
-
-data Amount    = Infinite   -- Neverending supply
-               | Finite Int -- Finite supply
-
--- Extremely preliminary, expand when needed
-data Commodity = WoodPlank
-               | Sword
-               | Fish
-               deriving Eq
-
-data Resource  = Coal
-               | Iron
-               | Gold
-               | Granite
-               | Water
-               | Fishes
-               deriving (Show, Eq)
-
-instance Show Amount where
-    show (Infinite) = "inexhaustable supply"
-    show (Finite n) = show n ++ " left"
-
-instance Show Commodity where
-    show WoodPlank = "wooden plank"
-    show Sword     = "sword"
-    show Fish      = "fish"

src/Render/Render.hs

@@ -50,22 +50,11 @@ initBuffer varray =
            checkError "initBuffer"
            return bufferObject
 
-initMapShader :: IO (
+initMapShader ::
-                      Program           -- the GLSL-Program
+                Int                                -- ^ initial Tessallation-Factor
-                      , AttribLocation  -- color
+                -> (BufferObject,NumArrayIndices)  -- ^ Buffer with Data and DataDescriptor
-                      , AttribLocation  -- normal
+                -> IO GLMapState
-                      , AttribLocation  -- vertex
+initMapShader tessFac (buf, vertDes) = do
-                      , UniformLocation -- ProjectionMat
-                      , UniformLocation -- ViewMat
-                      , UniformLocation -- ModelMat
-                      , UniformLocation -- NormalMat
-                      , UniformLocation -- TessLevelInner
-                      , UniformLocation -- TessLevelOuter
-                      , TextureObject   -- Texture where to draw into
-                      ) -- ^ (the GLSL-Program, color, normal, vertex, ProjectionMat, ViewMat,
-                        --    ModelMat, NormalMat, TessLevelInner, TessLevelOuter,
-                        --    Texture where to draw into)
-initMapShader = do
    ! vertexSource <- B.readFile mapVertexShaderFile
    ! tessControlSource <- B.readFile mapTessControlShaderFile
    ! tessEvalSource <- B.readFile mapTessEvalShaderFile
@@ -120,9 +109,30 @@ initMapShader = do
    putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)]
 
    tex <- genObjectName
+   overTex <- genObjectName
+
+   texts <- genObjectNames 6
+   
 
    checkError "initShader"
-   return (program, colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex, normalMatrixIndex, tessLevelInner, tessLevelOuter, tex)
+   return GLMapState
+        { _mapProgram         = program
+        , _shdrColorIndex     = colorIndex
+        , _shdrNormalIndex    = normalIndex
+        , _shdrVertexIndex    = vertexIndex
+        , _shdrProjMatIndex   = projectionMatrixIndex
+        , _shdrViewMatIndex   = viewMatrixIndex
+        , _shdrModelMatIndex  = modelMatrixIndex
+        , _shdrNormalMatIndex = normalMatrixIndex
+        , _shdrTessInnerIndex = tessLevelInner
+        , _shdrTessOuterIndex = tessLevelOuter
+        , _renderedMapTexture = tex
+        , _stateTessellationFactor = tessFac
+        , _stateMap           = buf
+        , _mapVert            = vertDes
+        , _overviewTexture    = overTex
+        , _mapTextures        = texts
+        }
 
 initHud :: IO GLHud
 initHud = do
@@ -193,13 +203,13 @@ renderOverview = do
                 DepthAttachment
                 Renderbuffer
                 (state ^. gl.glRenderbuffer)
-        textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture)
+        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
 
         framebufferTexture2D
                 Framebuffer
                 (ColorAttachment 0)
                 Texture2D
-                (state ^. gl.glMap.mapTexture)
+                (state ^. gl.glMap.renderedMapTexture)
                 0
 
         -- Render to FrameBufferObject
@@ -285,13 +295,13 @@ render = do
                 DepthAttachment
                 Renderbuffer
                 (state ^. gl.glRenderbuffer)
-        textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture)
+        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
 
         framebufferTexture2D
                 Framebuffer
                 (ColorAttachment 0)
                 Texture2D
-                (state ^. gl.glMap.mapTexture)
+                (state ^. gl.glMap.renderedMapTexture)
                 0
 
         -- Render to FrameBufferObject
@@ -371,7 +381,7 @@ render = do
         uniform (hud ^. hudTexIndex) $= Index1 (0::GLint)
 
         activeTexture  $= TextureUnit 1
-        textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture)
+        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
         uniform (hud ^. hudBackIndex) $= Index1 (1::GLint)
 
         bindBuffer ArrayBuffer $= Just (hud ^. hudVBO)

src/Types.hs

@@ -76,6 +76,26 @@ data KeyboardState = KeyboardState
     { _arrowsPressed        :: !ArrowKeyState
     }
 
+-- | State in which all map-related Data is stored
+--
+--   The map itself is rendered with mapProgram and the shaders given here directly
+--   This does not include any objects on the map - only the map itself
+--
+--   _mapTextures must contain the following Textures (in this ordering) after initialisation:
+--
+--     1. Grass
+--
+--     2. Sand
+--
+--     3. Water
+--
+--     4. Stone
+--
+--     5. Snow
+--
+--     6. Dirt (blended on grass)
+
+
 data GLMapState = GLMapState
     { _shdrVertexIndex      :: !GL.AttribLocation
     , _shdrColorIndex       :: !GL.AttribLocation
@@ -90,8 +110,9 @@ data GLMapState = GLMapState
     , _stateMap             :: !GL.BufferObject
     , _mapVert              :: !GL.NumArrayIndices
     , _mapProgram           :: !GL.Program
-    , _mapTexture           :: !TextureObject
+    , _renderedMapTexture   :: !TextureObject --TODO: Probably move to UI?
     , _overviewTexture      :: !TextureObject
+    , _mapTextures          :: ![TextureObject] --TODO: Fix size on list?
     }
 
 data GLHud = GLHud
@@ -147,3 +168,63 @@ $(makeLenses ''Position)
 $(makeLenses ''Env)
 $(makeLenses ''UIState)
 
+data Structure = Flag           -- Flag
+               | Woodcutter     -- Huts
+               | Forester
+               | Stonemason
+               | Fisher
+               | Hunter
+               | Barracks
+               | Guardhouse
+               | LookoutTower
+               | Well
+               | Sawmill        -- Houses
+               | Slaughterhouse
+               | Mill
+               | Bakery
+               | IronSmelter
+               | Metalworks
+               | Armory
+               | Mint
+               | Shipyard
+               | Brewery
+               | Storehouse
+               | Watchtower
+               | Catapult
+               | GoldMine       -- Mines
+               | IronMine
+               | GraniteMine
+               | CoalMine
+               | Farm           -- Castles
+               | PigFarm
+               | DonkeyBreeder
+               | Harbor
+               | Fortress
+               deriving (Show, Eq)
+
+data Amount    = Infinite   -- Neverending supply
+               | Finite Int -- Finite supply
+
+-- Extremely preliminary, expand when needed
+data Commodity = WoodPlank
+               | Sword
+               | Fish
+               deriving Eq
+
+data Resource  = Coal
+               | Iron
+               | Gold
+               | Granite
+               | Water
+               | Fishes
+               deriving (Show, Eq)
+
+instance Show Amount where
+    show (Infinite) = "inexhaustable supply"
+    show (Finite n) = show n ++ " left"
+
+instance Show Commodity where
+    show WoodPlank = "wooden plank"
+    show Sword     = "sword"
+    show Fish      = "fish"
+