Merge branch 'master' into ui

Conflicts:
	src/UI/Callbacks.hs

caused by using TMVar for camera state

Pioneers.cabal

@@ -16,7 +16,6 @@ executable Pioneers
                    Map.Types,
                    Map.Graphics,
                    Map.Creation,
-                   Map.StaticMaps,
                    Importer.IQM.Types,
                    Importer.IQM.Parser,
                    Render.Misc,

shaders/map/fragmentShadow.shader

@@ -0,0 +1,15 @@
+#version 330
+
+smooth in vec3 teNormal;
+smooth in vec3 tePosition;
+smooth in float fogDist;
+smooth in float gmix;
+in vec4 teColor;
+in vec3 tePatchDistance;
+
+uniform mat4 ViewMatrix;
+uniform mat4 ProjectionMatrix;
+
+void main(void)
+{
+}

src/Importer/IQM/Parser.hs

@@ -13,6 +13,8 @@ import Data.ByteString.Char8 (pack)
 import Data.ByteString (split, null, ByteString)
 import Data.ByteString.Unsafe (unsafeUseAsCString)
 import qualified Data.ByteString as B
+import Graphics.GLUtil
+import Graphics.Rendering.OpenGL.GL.BufferObjects
 import Data.Word
 import Data.Int
 import Unsafe.Coerce
@@ -211,10 +213,29 @@ parseIQM a =
 	-- Fill Vertex-Arrays with data of Offsets
 	let 	va = vertexArrays raw
 	va' <- mapM (readInVAO f) va
-	return $ raw {
+        vbo <- sequence $ map toVBOfromVAO va
-		vertexArrays = va'
+	return $ raw
+		{ vertexArrays = va'
+                , vertexArrayObjects = vbo
 		}
 
+-- | Creates a BufferObject on the Graphicscard for each BufferObject
+
+toVBOfromVAO :: IQMVertexArray -> IO BufferObject
+toVBOfromVAO (IQMVertexArray type' _ _ num _ ptr) =
+	fromPtr (toBufferTargetfromVAType type') (fromIntegral num) ptr
+
+-- | translates from VA-type to BufferTarget
+
+toBufferTargetfromVAType :: IQMVertexArrayType -> BufferTarget
+toBufferTargetfromVAType IQMPosition      = ArrayBuffer
+toBufferTargetfromVAType IQMTexCoord      = TextureBuffer
+toBufferTargetfromVAType IQMNormal        = ArrayBuffer
+toBufferTargetfromVAType IQMBlendIndexes  = ElementArrayBuffer
+toBufferTargetfromVAType IQMBlendWeights  = ArrayBuffer
+toBufferTargetfromVAType IQMColor         = ArrayBuffer
+toBufferTargetfromVAType _                = ArrayBuffer
+
 -- | Allocates memory for the Vertex-data and copies it over there
 --   from the given input-String
 --
@@ -254,6 +275,7 @@ doIQMparse =
 	                , texts = filter (not.null) (split (unsafeCoerce '\0') text)
 	                , meshes = meshes'
 			, vertexArrays = vaf
+                        , vertexArrayObjects = [] --initialized later, after vaf get allocated.
 	                }
 
 -- | Helper-Function for Extracting a random substring out of a Bytestring

src/Importer/IQM/Types.hs

@@ -13,6 +13,7 @@ import Graphics.Rendering.OpenGL.Raw.Types
 import Prelude as P
 import Foreign.Storable
 import Foreign.C.Types
+import Graphics.Rendering.OpenGL.GL.BufferObjects hiding (Offset)
 
 -- | Mesh-Indices to distinguish the meshes referenced
 newtype Mesh = Mesh Word32 deriving (Show, Eq)
@@ -108,6 +109,7 @@ data IQM = IQM
         , texts                 :: [ByteString]
         , meshes                :: [IQMMesh]
         , vertexArrays          :: [IQMVertexArray]
+        , vertexArrayObjects    :: [BufferObject]
         } deriving (Show, Eq)
 
 -- | Different Vertex-Array-Types in IQM

src/Main.hs

@@ -12,8 +12,8 @@ import           Control.Arrow                        ((***))
 
 -- data consistency/conversion
 import           Control.Concurrent                   (threadDelay)
-import           Control.Concurrent.STM               (TQueue,
+import           Control.Concurrent.STM               (TQueue, newTQueueIO, atomically)
-                                                       newTQueueIO)
+import           Control.Concurrent.STM.TVar          (newTVarIO, writeTVar, readTVar)
 
 import           Control.Monad.RWS.Strict             (ask, evalRWST, get, liftIO, modify)
 import           Data.Functor                         ((<$>))
@@ -43,6 +43,7 @@ import           Render.Render                        (initRendering,
 import           Render.Types
 import           UI.Callbacks
 import           Map.Graphics
+import           Map.Creation                          (exportedMap)
 import           Types
 import qualified UI.UIBase as UI
 import           Importer.IQM.Parser
@@ -54,7 +55,7 @@ import           Importer.IQM.Parser
 --------------------------------------------------------------------------------
 
 testParser :: String -> IO ()
-testParser a = putStrLn . show  =<< parseIQM a
+testParser a = print  =<< parseIQM a
 {-do
         f <- B.readFile a
         putStrLn "reading in:"
@@ -86,22 +87,33 @@ main =
         (SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window'
         initRendering
         --generate map vertices
-        glMap' <- initMapShader 4 =<< getMapBufferObject
+        curMap <- exportedMap
+        glMap' <- initMapShader 4 =<< getMapBufferObject curMap
         eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
         now <- getCurrentTime
         --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
         --TTF.setFontStyle font TTFNormal
         --TTF.setFontHinting font TTFHNormal
-
+        let
-        glHud' <- initHud
-        let zDistClosest'  = 1
-            zDistFarthest' = zDistClosest' + 50
-            --TODO: Move near/far/fov to state for runtime-changability & central storage
             fov           = 90  --field of view
             near          = 1   --near plane
             far           = 500 --far plane
             ratio         = fromIntegral fbWidth / fromIntegral fbHeight
             frust         = createFrustum fov near far ratio
+        cam' <- newTVarIO CameraState
+                        { _xAngle              = pi/6
+                        , _yAngle              = pi/2
+                        , _zDist               = 10
+                        , _frustum             = frust
+                        , _camObject           = createFlatCam 25 25 curMap
+                        }
+        game' <- newTVarIO GameState
+                        { _currentMap          = curMap
+                        }
+        glHud' <- initHud
+        let zDistClosest'  = 2
+            zDistFarthest' = zDistClosest' + 10
+            --TODO: Move near/far/fov to state for runtime-changability & central storage
             (guiMap, guiRoots) = createGUI
             aks = ArrowKeyState {
                   _up       = False
@@ -121,17 +133,11 @@ main =
                         , _height              = fbHeight
                         , _shouldClose         = False
                         }
-              , _camera              = CameraState
-                        { _xAngle              = pi/6
-                        , _yAngle              = pi/2
-                        , _zDist               = 10
-                        , _frustum             = frust
-                        , _camObject           = createFlatCam 25 25
-                        }
               , _io                  = IOState
                         { _clock               = now
                         , _tessClockFactor     = 0
                         }
+              , _camera              = cam'
               , _mouse               = MouseState
                         { _isDragging          = False
                         , _dragStartX          = 0
@@ -152,9 +158,7 @@ main =
                         , _glRenderbuffer      = renderBuffer
                         , _glFramebuffer       = frameBuffer
                         }
-              , _game                = GameState
+              , _game                = game'
-                        {
-                        }
               , _ui                  = UIState
                         { _uiHasChanged        = True
                         , _uiMap = guiMap
@@ -204,20 +208,26 @@ run = do
                   | otherwise          = newYAngle'
               newYAngle' = sodya + myrot/100
 
-          modify $ ((camera.xAngle) .~ newXAngle)
+          liftIO $ atomically $ do
-                 . ((camera.yAngle) .~ newYAngle)
+              cam <- readTVar (state ^. camera)
+              cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
+              writeTVar (state ^. camera) cam'
 
     -- get cursor-keys - if pressed
     --TODO: Add sin/cos from stateYAngle
     (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
-    let
+    liftIO $ atomically $ do
-        multc = cos $ state ^. camera.yAngle
+        cam <- readTVar (state ^. camera)
-        mults = sin $ state ^. camera.yAngle
+        game' <- readTVar (state ^. game)
-        modx x' = x' - 0.2 * kxrot * multc
+        let
-                     - 0.2 * kyrot * mults
+            multc = cos $ cam ^. yAngle
-        mody y' = y' + 0.2 * kxrot * mults
+            mults = sin $ cam ^. yAngle
-                     - 0.2 * kyrot * multc
+            modx x' = x' - 0.2 * kxrot * multc
-    modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)))
+                         - 0.2 * kyrot * mults
+            mody y' = y' + 0.2 * kxrot * mults
+                         - 0.2 * kyrot * multc
+        cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam
+        writeTVar (state ^. camera) cam'
 
     {-
     --modify the state with all that happened in mt time.
@@ -233,7 +243,7 @@ run = do
 		targetFrametime = 1.0/targetFramerate
 		--targetFrametimeμs = targetFrametime * 1000000.0
         now <- getCurrentTime
-        let diff  = diffUTCTime now (state ^. io.clock) -- get time-diffs
+        let diff  = max 0.1 $ diffUTCTime now (state ^. io.clock) -- get time-diffs
             title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
             ddiff = double diff
         SDL.setWindowTitle (env ^. windowObject) title
@@ -287,7 +297,10 @@ adjustWindow = do
         ratio         = fromIntegral fbWidth / fromIntegral fbHeight
         frust         = createFrustum fov near far ratio
     liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
-    modify $ camera.frustum .~ frust
+    liftIO $ atomically $ do
+        cam <- readTVar (state ^. camera)
+        cam' <- return $ frustum .~ frust $ cam
+        writeTVar (state ^. camera) cam'
     rb <- liftIO $ do
                    -- bind ints to CInt for lateron.
                    let fbCWidth  = (fromInteger.toInteger) fbWidth
@@ -305,6 +318,7 @@ adjustWindow = do
 
                    let hudtexid = state ^. gl.glHud.hudTexture
                        maptexid = state ^. gl.glMap.renderedMapTexture
+                       smaptexid = state ^. gl.glMap.shadowMapTexture
                    allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
                                                                --default to ugly pink to see if
                                                                --somethings go wrong.
@@ -321,6 +335,13 @@ adjustWindow = do
                         textureFilter  Texture2D GL.$= ((Linear', Nothing), Linear')
                         texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
                                                 (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
+                   allocaBytes (2048*2048) $ \ptr -> do
+                        let smapdata = genColorData (2048*2048) [0]
+                        pokeArray ptr smapdata
+                        textureBinding Texture2D GL.$= Just smaptexid
+                        textureFilter  Texture2D GL.$= ((Nearest,Nothing), Nearest)
+                        texImage2D Texture2D GL.NoProxy 0 GL.DepthComponent16 (GL.TextureSize2D 2048 2048) 0
+                                                (GL.PixelData GL.DepthComponent GL.UnsignedByte ptr)
                    checkError "setting up HUD-Tex"
                    return renderBuffer
     modify $ gl.glRenderbuffer .~ rb

src/Map/Creation.hs

@@ -2,21 +2,13 @@ module Map.Creation
 where
 
 import Map.Types
-import Map.StaticMaps
--- import Map.Map unused (for now)
 
 import Data.Array
 import System.Random
 
--- preliminary
+-- entirely empty map, only uses the minimal constructor
-infix 5 ->-
+mapEmpty :: PlayMap
-(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
+mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]]
-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
@@ -52,18 +44,7 @@ gauss3Dgeneral :: Floating q =>
                   -> 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)))))
+gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int)))))
-
--- 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)
@@ -72,9 +53,9 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d)
 heightToTerrain :: MapType -> YCoord -> TileType
 heightToTerrain GrassIslandMap y
                 | y < 0.1   = Ocean
-                | y < 1     = Beach
+                | y < 0.2   = Beach
-                | y < 5     = Grass
+                | y < 1.5   = Grass
-                | y < 10    = Hill
+                | y < 3     = Hill
                 | otherwise = Mountain
 heightToTerrain _ _ = undefined
 
@@ -87,26 +68,23 @@ river = undefined
 
 mnt :: IO [PlayMap -> PlayMap]
 mnt = do g <- newStdGen
-         let seeds = take 10 $ randoms g
+         let seeds = take 50 $ randoms g
-         return $ map (gaussMountain) seeds
+         return $ map gaussMountain seeds
 
 gaussMountain :: Int -> PlayMap -> PlayMap
 gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
   where
-    g   = mkStdGen seed
+    gs  = map mkStdGen (map (*seed) [1..])
-    c   = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g)))
+    c   = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
-    amp = head $ randomRs (5.0, 20.0) g
+    amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
-    sig = head $ randomRs (5.0, 25.0) g
+    sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3)
-    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
+    liftUp (gx,gz) (Node (x,z) (rx,rz,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
+                                                          in  Node (x,z) (rx, rz, 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)
+      where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz
-    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

src/Map/Graphics.hs

@@ -30,9 +30,8 @@ import Linear
 import Control.Arrow         ((***))
 
 import Map.Types
-import Map.Creation
 
-type Height = Float
+type Height = Double
 
 type MapEntry = (
                 Height,
@@ -50,16 +49,14 @@ stripify :: (Int,Int) -> (Int,Int)
 stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2)
 
 strp :: Node -> Node
-strp (Full    xz y tt bi pli p ri si) = Full    (stripify xz) y tt bi pli p ri si
+strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si
-strp (Minimal xz                    ) = Minimal (stripify xz)
 
 -- extract graphics information from Playmap
 convertToGraphicsMap :: PlayMap -> GraphicsMap
 convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp]
     where
       graphicsyfy :: Node -> MapEntry
-      graphicsyfy (Minimal _               ) = (1.0, Grass)
+      graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t)
-      graphicsyfy (Full    _ y t _ _ _ _ _ ) = (y, t)
 
 lineHeight :: GLfloat
 lineHeight = 0.8660254
@@ -87,9 +84,8 @@ fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
 fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
 fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
 
-getMapBufferObject :: IO (BufferObject, NumArrayIndices)
+getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices)
-getMapBufferObject = do
+getMapBufferObject eMap = do
-        eMap    <- exportedMap
         myMap'  <- return $ convertToGraphicsMap $ convertToStripeMap eMap
         ! myMap <- return $ generateTriangles myMap'
         len <- return $ fromIntegral $ P.length myMap `div` numComponents
@@ -203,8 +199,8 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
                                 Beach           -> (0.90, 0.85, 0.70)
                                 Desert          -> (1.00, 0.87, 0.39)
                                 Grass           -> (0.30, 0.90, 0.10)
-                                Hill            -> (0.80, 0.80, 0.80)
+                                Mountain        -> (0.80, 0.80, 0.80)
-                                Mountain        -> (0.50, 0.50, 0.50)
+                                Hill            -> (0.50, 0.50, 0.50)
 
 coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat
 coordLookup (x,z) y =

src/Map/Map.hs

@@ -2,8 +2,8 @@ module Map.Map where
 
 import Map.Types
 
-import Data.Array (bounds)
+import Data.Array    (bounds, (!))
-import Data.List  (sort, group)
+import Data.List     (sort, group)
 
 -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
 unsafeGiveNeighbours :: (Int, Int)  -- ^ original coordinates
@@ -36,6 +36,57 @@ 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
 
+-- | Calculates the height of any given point on the map.
+-- Does not add camera distance to ground to that.
+giveMapHeight :: PlayMap
+             -> (Double, Double)
+             -> Double
+giveMapHeight mop (x, z)
+  | outsideMap (x,z') = 0.0
+  | otherwise         = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups
+  where
+    z' = z * 2/(sqrt 3)
+
+    outsideMap :: (Double, Double) -> Bool
+    outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop
+                              fr = fromIntegral
+                          in  mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d)
+
+    -- Height LookUp on PlayMap
+    hlu :: (Int, Int) -> Double
+    hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
+
+    -- reference Points
+    refs :: [(Int, Int)]
+    refs = remdups $ map clmp $ map (tadd (floor x, floor z')) mods
+      where
+        mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)]
+        tadd (a,b) (c,d) = (a+b,c+d)
+
+    -- tupels with reference point and distance
+    tups = map (\t -> (t, dist (x,z') t)) refs
+
+    -- total distance of all for reference point from the point in question
+    totald = sum $ map (\(_,d) -> d) tups
+
+    -- clamp, as she is programmed
+    clamp :: (Ord a) => a -> a -> a -> a
+    clamp mn mx = max mn . min mx
+
+    -- clamp for tupels
+    clmp :: (Int, Int) -> (Int, Int)
+    clmp (a,b) = let ((xmin,zmin),(xmax,zmax)) = bounds mop
+                 in  ((clamp (xmin+2) (xmax-2) a),(clamp (zmin+2) (zmax-2) b))
+
+    -- Real distance on PlayMap
+    dist :: (Double, Double) -> (Int, Int) -> Double
+    dist (x1,z1) pmp = let xf = x1 - realx 
+                           zf = z1 - realz
+                       in  sqrt $ xf*xf + zf*zf
+      where
+        realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp)
+        realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp)
+
 -- removing duplicates in O(n log n), losing order and adding Ord requirement
 remdups :: Ord a => [a] -> [a]
 remdups = map head . group . sort

src/Map/StaticMaps.hs

@@ -1,49 +0,0 @@
-module Map.StaticMaps
-where
-
-import Map.Types
-import Data.Array
-
--- 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]
-
---      g2d :: Int -> Int -> Float
---      g2d x y = gauss3D (fromIntegral x) (fromIntegral y)
-
---      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
-
--- 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)

src/Map/Types.hs

@@ -1,15 +1,15 @@
 module Map.Types
 where
 
-import Types
-
 import Data.Array
 
-type PlayMap = Array (XCoord, ZCoord) Node 
+type PlayMap = Array (Xindex, Zindex) Node 
 
-type XCoord  = Int
+type Xindex  = Int
-type ZCoord  = Int
+type Zindex  = Int
-type YCoord  = Float
+type XCoord  = Double
+type ZCoord  = Double
+type YCoord  = Double
 
 data MapType    = GrassIslandMap
                 | DesertMap
@@ -66,7 +66,67 @@ data TileType   = Ocean
                 | Mountain -- ^ Not accessible
                 deriving (Show, Eq)
 
--- TODO: Record Syntax
+-- TODO: Record Syntax?
-data Node = Full    (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo
+data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo
-          | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1
           deriving (Show)
+
+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/Misc.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
 module Render.Misc where
 
 import           Control.Monad
@@ -75,6 +74,16 @@ createFrustum fov n' f' rat =
                        (V4    0         0    (-((f+n)/(f-n)))  (-((2*f*n)/(f-n))))
                        (V4    0         0          (-1)                  0)
 
+-- | Creates an orthogonal frustum with given width, height, near and far-plane
+createFrustumOrtho :: Float -> Float -> Float -> Float -> M44 CFloat
+createFrustumOrtho w' h' n' f' = 
+                 let [w,h,n,f] = map realToFrac [w',h',n',f']
+                 in
+                    V4 (V4 (0.5/w)    0        0        0)
+                       (V4    0    (0.5/h)     0        0)
+                       (V4    0       0    (-2/(f-n))   ((-f+n)/(f-n)))
+                       (V4    0       0        0        1)
+
 -- from vmath.h
 lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
 lookAt eye center up' =
@@ -128,5 +137,4 @@ tryWithTexture t f fail' =
 genColorData ::      Int  -- ^ Amount
                 -> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet.
                 -> [Int8]
-genColorData n c = take ((length c)*n) (cycle c)
+genColorData n c = take (length c*n) (cycle c)
-

src/Render/Render.hs

@@ -7,11 +7,13 @@ import           Foreign.Storable
 import           Graphics.Rendering.OpenGL.GL
 import           Graphics.Rendering.OpenGL.Raw.Core31
 import           Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
-import           Graphics.GLUtil.BufferObjects        (offset0)
+import           Graphics.GLUtil.BufferObjects        
 import qualified Linear as L
 import           Control.Lens                               ((^.))
 import           Control.Monad.RWS.Strict             (liftIO)
 import qualified Control.Monad.RWS.Strict as RWS      (get)
+import           Control.Concurrent.STM.TVar          (readTVarIO)
+import           Control.Concurrent.STM               (atomically)
 import           Data.Distributive                    (distribute, collect)
 -- FFI
 import           Foreign                              (Ptr, castPtr, with)
@@ -24,6 +26,7 @@ import           Render.Types
 import           Graphics.GLUtil.BufferObjects              (makeBuffer)
 import		 Importer.IQM.Parser
 import           Importer.IQM.Types
+import           Map.Map                               (giveMapHeight)
 
 mapVertexShaderFile :: String
 mapVertexShaderFile = "shaders/map/vertex.shader"
@@ -33,6 +36,8 @@ mapTessEvalShaderFile :: String
 mapTessEvalShaderFile = "shaders/map/tessEval.shader"
 mapFragmentShaderFile :: String
 mapFragmentShaderFile = "shaders/map/fragment.shader"
+mapFragmentShaderShadowMapFile :: String
+mapFragmentShaderShadowMapFile = "shaders/map/fragmentShadow.shader"
 
 objectVertexShaderFile :: String
 objectVertexShaderFile = "shaders/mapobjects/vertex.shader"
@@ -66,6 +71,7 @@ initMapShader tessFac (buf, vertDes) = do
    ! tessControlSource <- B.readFile mapTessControlShaderFile
    ! tessEvalSource <- B.readFile mapTessEvalShaderFile
    ! fragmentSource <- B.readFile mapFragmentShaderFile
+   ! fragmentShadowSource <- B.readFile mapFragmentShaderShadowMapFile
    vertexShader <- compileShaderSource VertexShader vertexSource
    checkError "compile Vertex"
    tessControlShader <- compileShaderSource TessControlShader tessControlSource
@@ -74,7 +80,10 @@ initMapShader tessFac (buf, vertDes) = do
    checkError "compile TessEval"
    fragmentShader <- compileShaderSource FragmentShader fragmentSource
    checkError "compile Frag"
+   fragmentShadowShader <- compileShaderSource FragmentShader fragmentShadowSource
+   checkError "compile Frag"
    program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader]
+   shadowProgram <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShadowShader]
    checkError "compile Program"
 
    currentProgram $= Just program
@@ -119,6 +128,8 @@ initMapShader tessFac (buf, vertDes) = do
    overTex <- genObjectName
 
    texts <- genObjectNames 6
+
+   smap <- genObjectName
    
    testobj <- parseIQM "sample.iqm"
 
@@ -137,25 +148,31 @@ initMapShader tessFac (buf, vertDes) = do
    currentProgram $= Just objProgram
 
    checkError "initShader"
+   let sdata = MapShaderData
+           { shdrVertexIndex      = vertexIndex
+           , shdrColorIndex       = colorIndex
+           , shdrNormalIndex      = normalIndex
+           , shdrProjMatIndex     = projectionMatrixIndex
+           , shdrViewMatIndex     = viewMatrixIndex
+           , shdrModelMatIndex    = modelMatrixIndex
+           , shdrNormalMatIndex   = normalMatrixIndex
+           , shdrTessInnerIndex   = tessLevelInner
+           , shdrTessOuterIndex   = tessLevelOuter
+           }
+
    return GLMapState
         { _mapProgram         = program
-        , _shdrColorIndex     = colorIndex
+        , _mapShaderData      = sdata
-        , _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
+        , _shadowMapTexture   = smap
 	, _mapObjects         = objs
 	, _objectProgram      = objProgram
+        , _shadowMapProgram   = shadowProgram
         }
 
 initHud :: IO GLHud
@@ -190,7 +207,7 @@ initHud = do
    att <- get (activeAttribs program)
 
    putStrLn $ unlines $ "Attributes: ":map show att
-   putStrLn $ unlines $ ["Indices: ", show (texIndex)]
+   putStrLn $ unlines $ ["Indices: ", show texIndex]
 
    checkError "initHud"
    return GLHud
@@ -299,38 +316,126 @@ renderObject :: MapObject -> IO ()
 renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) = 
 	renderIQM model pos (L.V3 1 1 1)
 		
+drawMap :: Pioneers ()
+drawMap = do
+    state <- RWS.get
+    let 
+        d        = state ^. gl.glMap.mapShaderData
+        vi       = shdrVertexIndex d
+        ni       = shdrNormalIndex d
+        ci       = shdrColorIndex d
+        numVert  = state ^. gl.glMap.mapVert
+        map'     = state ^. gl.glMap.stateMap
+        tessFac  = state ^. gl.glMap.stateTessellationFactor
+        (UniformLocation tli)   = shdrTessInnerIndex d
+        (UniformLocation tlo)   = shdrTessOuterIndex d
+    liftIO $ do
+        glUniform1f tli (fromIntegral tessFac)
+        glUniform1f tlo (fromIntegral tessFac)
+
+        bindBuffer ArrayBuffer $= Just map'
+        vertexAttribPointer ci $= fgColorIndex
+        vertexAttribArray ci   $= Enabled
+        vertexAttribPointer ni $= fgNormalIndex
+        vertexAttribArray ni   $= Enabled
+        vertexAttribPointer vi $= fgVertexIndex
+        vertexAttribArray vi   $= Enabled
+        checkError "beforeDraw"
+
+        glPatchParameteri gl_PATCH_VERTICES 3
+
+        cullFace $= Just Front
+
+        glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
+
+        checkError "draw map"
+
+	---- RENDER MAPOBJECTS --------------------------------------------
+	
+	currentProgram $= Just (state ^. gl.glMap.objectProgram)
+
+	mapM_ renderObject (state ^. gl.glMap.mapObjects)
+
+        -- set sample 1 as target in renderbuffer
+        {-framebufferRenderbuffer
+                DrawFramebuffer              --write-only
+                (ColorAttachment 1)          --sample 1
+                Renderbuffer                 --const
+                rb                              --buffer-}
 
 render :: Pioneers ()
 render = do
     state <- RWS.get
-    let xa       = state ^. camera.xAngle
+    cam <- liftIO $ readTVarIO (state ^. camera)
-        ya       = state ^. camera.yAngle
+    let xa       = cam ^. xAngle
-        (UniformLocation proj)  = state ^. gl.glMap.shdrProjMatIndex
+        ya       = cam ^. yAngle
-        (UniformLocation nmat)  = state ^. gl.glMap.shdrNormalMatIndex
+        frust    = cam ^. Types.frustum
-        (UniformLocation vmat)  = state ^. gl.glMap.shdrViewMatIndex
+        camPos   = cam ^. camObject
-        (UniformLocation tli)   = state ^. gl.glMap.shdrTessInnerIndex
+        zDist'   = cam ^. zDist
-        (UniformLocation tlo)   = state ^. gl.glMap.shdrTessOuterIndex
+        d        = state ^. gl.glMap.mapShaderData
-        vi       = state ^. gl.glMap.shdrVertexIndex
+        (UniformLocation proj)  = shdrProjMatIndex d
-        ni       = state ^. gl.glMap.shdrNormalIndex
+        (UniformLocation nmat)  = shdrNormalMatIndex d
-        ci       = state ^. gl.glMap.shdrColorIndex
+        (UniformLocation vmat)  = shdrViewMatIndex d
-        numVert  = state ^. gl.glMap.mapVert
-        map'     = state ^. gl.glMap.stateMap
-        frust    = state ^. camera.Types.frustum
-        camPos   = state ^. camera.camObject
-        zDist'   = state ^. camera.zDist
-        tessFac  = state ^. gl.glMap.stateTessellationFactor
     liftIO $ do
         ---- RENDER MAP IN TEXTURE ------------------------------------------
 
         bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer)
-        bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
+        {-bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
         framebufferRenderbuffer
                 Framebuffer
                 DepthAttachment
                 Renderbuffer
-                (state ^. gl.glRenderbuffer)
+                (state ^. gl.glRenderbuffer)-}
-        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
+        
+        -- SHADOWMAP
+        textureBinding Texture2D $= Just (state ^. gl.glMap.shadowMapTexture)
+        framebufferTexture2D 
+                Framebuffer
+                DepthAttachment
+                Texture2D
+                (state ^. gl.glMap.shadowMapTexture)
+                0
 
+        drawBuffer $= NoBuffers --color-buffer is not needed but must(?) be set up
+        checkError "setup Render-Target"
+
+        clear [DepthBuffer]
+        checkError "clearing shadowmap-buffer"
+        
+        --TODO: simplified program for shadows?
+        currentProgram $= Just (state ^. gl.glMap.mapProgram)
+        checkError "setting up shadowmap-program"
+
+        --set up projection (= copy from state)
+        --TODO: Fix width/depth
+        with (distribute (createFrustumOrtho 20 20 0 100)) $ \ptr ->
+              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
+        checkError "copy shadowmap-projection"
+
+        --set up camera
+        --TODO: Fix magic constants... and camPos
+        let ! cam = getCam camPos 1 0.7 0
+        with (distribute cam) $ \ptr ->
+              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
+        checkError "copy shadowmap-cam"
+
+        --set up normal--Mat transpose((model*camera)^-1)
+        --needed?
+        let normal' = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
+                                             (Just a) -> a
+                                             Nothing  -> L.eye3) :: L.M33 CFloat
+            nmap = collect id normal' :: L.M33 CFloat --transpose...
+
+        with (distribute nmap) $ \ptr ->
+              glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))
+
+        checkError "nmat"
+    drawMap
+    liftIO $ do
+        checkError "draw ShadowMap"
+
+        -- COLORMAP
+        textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
         framebufferTexture2D
                 Framebuffer
                 (ColorAttachment 0)
@@ -371,38 +476,8 @@ render = do
 
         checkError "nmat"
 
-        glUniform1f tli (fromIntegral tessFac)
+    drawMap --draw map -> put to another function for readability
-        glUniform1f tlo (fromIntegral tessFac)
+    liftIO $ do
-
-        bindBuffer ArrayBuffer $= Just map'
-        vertexAttribPointer ci $= fgColorIndex
-        vertexAttribArray ci   $= Enabled
-        vertexAttribPointer ni $= fgNormalIndex
-        vertexAttribArray ni   $= Enabled
-        vertexAttribPointer vi $= fgVertexIndex
-        vertexAttribArray vi   $= Enabled
-        checkError "beforeDraw"
-
-        glPatchParameteri gl_PATCH_VERTICES 3
-
-        cullFace $= Just Front
-
-        glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
-
-        checkError "draw map"
-
-	---- RENDER MAPOBJECTS --------------------------------------------
-	
-	currentProgram $= Just (state ^. gl.glMap.objectProgram)
-
-	mapM_ renderObject (state ^. gl.glMap.mapObjects)
-
-        -- set sample 1 as target in renderbuffer
-        {-framebufferRenderbuffer
-                DrawFramebuffer              --write-only
-                (ColorAttachment 1)          --sample 1
-                Renderbuffer                 --const
-                rb                              --buffer-}
 
         ---- COMPOSE RENDERING --------------------------------------------
         -- Render to BackBuffer (=Screen)

src/Render/Types.hs

@@ -4,6 +4,10 @@ module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where
 import Linear
 import Foreign.C (CFloat)
 import Render.Misc (lookAt)
+import Map.Map (giveMapHeight)
+import Map.Types (PlayMap)
+import GHC.Float
+import qualified Debug.Trace as D
 
 type Distance = Double
 type Pitch = Double
@@ -11,30 +15,32 @@ type Yaw = Double
 
 class GLCamera a where
   getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat
-  moveBy :: a -> (Position -> Position) -> a
+  moveBy :: a -> (Position -> Position) -> PlayMap -> a
-  move   :: a -> Position -> a
+  move   :: a -> Position -> PlayMap -> a
 
 type Position = (Double, Double)
 
 type Radius = Double
 
-data Camera = Flat Position
+type Height = Double
+
+data Camera = Flat Position Height
             | Sphere Position Radius
 
 -- | create a Flatcam-Camera starting at given x/z-Coordinates
-createFlatCam :: Double -> Double -> Camera
+createFlatCam :: Double -> Double -> PlayMap -> Camera
-createFlatCam x z = Flat (x,z)
+createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
 
 -- | create a Flatcam-Camera starting at given pitch/azimuth/radius
 createSphereCam :: Double -> Double -> Double -> Camera
-createSphereCam p a r = Sphere (p,a) r
+createSphereCam p a = Sphere (p,a)
 
 
 instance GLCamera Camera where
-  getCam (Flat (x',z')) dist' xa' ya' =
+  getCam (Flat (x',z') y') dist' xa' ya' =
         lookAt (cpos ^+^ at') at' up
                      where
-                        at'   = V3 x 0 z
+                        at'   = V3 x (y+2) z
                         cpos  = crot !* (V3 0 0 (-dist))
                         crot  = (
                                 (fromQuaternion $ axisAngle upmap (xa::CFloat))
@@ -44,6 +50,7 @@ instance GLCamera Camera where
                         upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
                                 !* (V3 1 0 0)
                         x     = realToFrac x'
+                        y     = realToFrac y'
                         z     = realToFrac z'
                         dist  = realToFrac dist'
                         xa    = realToFrac xa'
@@ -68,12 +75,15 @@ instance GLCamera Camera where
                         dist  = realToFrac dist'
                         xa    = realToFrac xa'
                         ya    = realToFrac ya'
-  moveBy (Sphere (inc, az) r) f = undefined
+  moveBy (Sphere (inc, az) r) f map = undefined
-  moveBy (Flat (x', z')) f = Flat (f (x',z'))
+  moveBy (Flat (x', z') y) f map = Flat (x,z) y
-  move c (x', z') = moveBy c (\(x,z) -> (x+x',z+z'))
+				where
+					(x,z) = f (x', z')
+					y     = giveMapHeight map (x,z)
+  move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
 
 sphereToCart :: (Floating a) => a -> a -> a -> V3 a
 sphereToCart r inc az = V3
                                    (r * (sin inc) * (cos az))
                                    (r * (sin inc) * (sin az))
-                                   (r * (cos inc))
+                                   (r * (cos inc))

src/Types.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Types where
 
-import           Control.Concurrent.STM               (TQueue)
+import           Control.Concurrent.STM               (TQueue, TVar, readTVar, writeTVar, atomically)
 import qualified Graphics.Rendering.OpenGL.GL         as GL
 import           Graphics.UI.SDL                      as SDL (Event, Window)
 import           Foreign.C                            (CFloat)
@@ -9,12 +9,14 @@ import qualified Data.HashMap.Strict                  as Map
 import           Data.Time                            (UTCTime)
 import Linear.Matrix (M44)
 import Linear (V3)
-import Control.Monad.RWS.Strict (RWST)
+import Control.Monad.RWS.Strict (RWST, liftIO, get)
+import Control.Monad (when)
 import Control.Lens
 import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
 import Render.Types
 import Importer.IQM.Types
 import UI.UIBase
+import Map.Types (PlayMap)
 
 data Coord3D a = Coord3D a a a
 
@@ -56,7 +58,7 @@ data IOState = IOState
     }
 
 data GameState = GameState
-    {
+    { _currentMap          :: !PlayMap
     }
 
 data MouseState = MouseState
@@ -100,24 +102,30 @@ data KeyboardState = KeyboardState
 
 
 data GLMapState = GLMapState
-    { _shdrVertexIndex      :: !GL.AttribLocation
+    { _mapShaderData        :: !MapShaderData
-    , _shdrColorIndex       :: !GL.AttribLocation
-    , _shdrNormalIndex      :: !GL.AttribLocation
-    , _shdrProjMatIndex     :: !GL.UniformLocation
-    , _shdrViewMatIndex     :: !GL.UniformLocation
-    , _shdrModelMatIndex    :: !GL.UniformLocation
-    , _shdrNormalMatIndex   :: !GL.UniformLocation
-    , _shdrTessInnerIndex   :: !GL.UniformLocation
-    , _shdrTessOuterIndex   :: !GL.UniformLocation
     , _stateTessellationFactor :: !Int
     , _stateMap             :: !GL.BufferObject
     , _mapVert              :: !GL.NumArrayIndices
     , _mapProgram           :: !GL.Program
     , _renderedMapTexture   :: !TextureObject --TODO: Probably move to UI?
     , _overviewTexture      :: !TextureObject
+    , _shadowMapTexture     :: !TextureObject
     , _mapTextures          :: ![TextureObject] --TODO: Fix size on list?
     , _objectProgram        :: !GL.Program
     , _mapObjects           :: ![MapObject]
+    , _shadowMapProgram     :: !GL.Program
+    }
+
+data MapShaderData = MapShaderData
+    { shdrVertexIndex      :: !GL.AttribLocation
+    , shdrColorIndex       :: !GL.AttribLocation
+    , shdrNormalIndex      :: !GL.AttribLocation
+    , shdrProjMatIndex     :: !GL.UniformLocation
+    , shdrViewMatIndex     :: !GL.UniformLocation
+    , shdrModelMatIndex    :: !GL.UniformLocation
+    , shdrNormalMatIndex   :: !GL.UniformLocation
+    , shdrTessInnerIndex   :: !GL.UniformLocation
+    , shdrTessOuterIndex   :: !GL.UniformLocation
     }
 
 data MapObject = MapObject !IQM !MapCoordinates !MapObjectState
@@ -153,12 +161,12 @@ data UIState = UIState
 
 data State = State
     { _window              :: !WindowState
-    , _camera              :: !CameraState
+    , _camera              :: TVar CameraState
     , _io                  :: !IOState
     , _mouse               :: !MouseState
     , _keyboard            :: !KeyboardState
     , _gl                  :: !GLState
-    , _game                :: !GameState
+    , _game                :: TVar GameState
     , _ui                  :: !UIState
     }
 
@@ -180,63 +188,18 @@ $(makeLenses ''Position)
 $(makeLenses ''Env)
 $(makeLenses ''UIState)
 
-data Structure = Flag           -- Flag
+-- helper-functions for types
-               | 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
+-- | atomically change gamestate on condition
-               | Finite Int -- Finite supply
+changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers ()
+changeIfGamestate cond f = do
+	state <- get
+	liftIO $ atomically $ do
+		game' <- readTVar (state ^. game)
+		when (cond game') (writeTVar (state ^. game) (f game'))
 
--- Extremely preliminary, expand when needed
-data Commodity = WoodPlank
-               | Sword
-               | Fish
-               deriving Eq
 
-data Resource  = Coal
+-- | atomically change gamestate
-               | Iron
+changeGamestate :: (GameState -> GameState) -> Pioneers ()
-               | Gold
+changeGamestate = changeIfGamestate (const True) 
-               | 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/UI/Callbacks.hs

@@ -13,6 +13,8 @@ import           Data.Maybe
 import           Foreign.Marshal.Array                (pokeArray)
 import           Foreign.Marshal.Alloc                (allocaBytes)
 import qualified Graphics.UI.SDL                      as SDL
+import           Control.Concurrent.STM.TVar          (readTVar, readTVarIO, writeTVar)
+import           Control.Concurrent.STM               (atomically)
 
 
 import Render.Misc                                    (curb,genColorData)
@@ -102,6 +104,7 @@ eventCallback e = do
                         return ()
             SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
                 mouseMoveHandler (x, y)
+
             SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
                case state of
                     SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
@@ -110,8 +113,13 @@ eventCallback e = do
             SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
                 do -- TODO: MouseWheelHandler
                 state <- get
-                let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
+                liftIO $ atomically $ do
-                  modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
+                    cam <- readTVar (state ^. camera)
+                    let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
+                        zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
+                    cam' <- return $ zDist .~ zDist'' $ cam
+                    writeTVar (state ^. camera) cam'
+                  
             -- there is more (joystic, touchInterface, ...), but currently ignored
             SDL.Quit -> modify $ window.shouldClose .~ True
             _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
@@ -289,4 +297,4 @@ copyGUI tex (vX, vY) widget = do
                         mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
 
 --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
---TODO: Maybe queues are better?
+--TODO: Maybe queues are better?

src/UI/UIWidgets.hs

@@ -2,9 +2,10 @@
 
 module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
 
+import           Control.Concurrent.STM.TVar          (readTVarIO)
 import           Control.Lens                         ((^.), (.~), (%~), (&))
 import           Control.Monad
--- import           Control.Monad.IO.Class               (liftIO)
+import           Control.Monad.IO.Class               (liftIO)
 import           Control.Monad.RWS.Strict             (get, modify)
 import           Data.List
 import           Data.Maybe
@@ -57,11 +58,12 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
         let press btn' (x, y) _ w =
               do when (btn == btn') $ do
                      state <- get
+                     cam <- liftIO $ readTVarIO (state ^. camera)
                      modify $ mouse %~ (isDragging .~ True)
                                      . (dragStartX .~ fromIntegral x)
                                      . (dragStartY .~ fromIntegral y)
-                                     . (dragStartXAngle .~ (state ^. camera.xAngle))
+                                     . (dragStartXAngle .~ (cam ^. xAngle))
-                                     . (dragStartYAngle .~ (state ^. camera.yAngle))
+                                     . (dragStartYAngle .~ (cam ^. yAngle))
                                      . (mousePosition.Types._x .~ fromIntegral x)
                                      . (mousePosition.Types._y .~ fromIntegral y)
                  return w