should work - but GL crashes internally somewhere with unlimited allocation of memory

Pioneers.cabal

@@ -28,5 +28,6 @@ executable Pioneers
                    distributive >=0.3.2 && <0.4,
                    linear >=1.3.1 && <1.4,
                    lens >=3.10.1 && <3.11,
-                   SDL2 >= 0.1.0
+                   SDL2 >= 0.1.0,
+                   time >=1.4.0 && <1.5
 

src/Main.hs

@@ -5,14 +5,19 @@ module Main where
 import           Control.Applicative
 import           Control.Monad                        (unless, void, when)
 import           Control.Monad.Trans.Maybe            (MaybeT (..), runMaybeT)
--- data consistency
+
+-- data consistency/conversion
+import           Control.Concurrent                   (threadDelay)
 import           Control.Concurrent.STM               (TQueue, atomically,
                                                        newTQueueIO,
                                                        tryReadTQueue,
-                                                       writeTQueue)
+                                                       writeTQueue, isEmptyTQueue,
+                                                       STM)
 import           Control.Monad.RWS.Strict             (RWST, ask, asks,
                                                        evalRWST, get, liftIO,
                                                        modify, put)
+import           Data.Distributive                    (distribute, collect)
+
 -- FFI
 import           Foreign                              (Ptr, castPtr, with)
 import           Foreign.C                            (CFloat)
@@ -27,6 +32,7 @@ import           Graphics.UI.SDL as SDL
 -- Render
 import qualified Graphics.Rendering.OpenGL.GL         as GL
 import           Graphics.Rendering.OpenGL.Raw.Core31
+import           Data.Time                            (getCurrentTime, UTCTime, diffUTCTime)
 
 -- Our modules
 import           Map.Map
@@ -36,6 +42,8 @@ import           Render.Misc                          (checkError,
 import           Render.Render                        (initRendering,
                                                        initShader)
 
+import qualified Debug.Trace                          as D (trace)
+
 --Static Read-Only-State
 data Env = Env
     { envEventsChan    :: TQueue Event
@@ -49,6 +57,7 @@ data State = State
     { stateWindowWidth     :: !Int
     , stateWindowHeight    :: !Int
     , stateWinClose        :: !Bool
+    , stateClock           :: !UTCTime
     --- IO
     , stateXAngle          :: !Double
     , stateYAngle          :: !Double
@@ -81,21 +90,24 @@ type Pioneers = RWST Env () State IO
 --------------------------------------------------------------------------------
 main :: IO ()
 main = do
-        SDL.withInit [InitEverything] $ do --also: InitNoParachute -> faster, without parachute!
+        SDL.withInit [InitVideo, InitAudio] $ do --also: InitNoParachute -> faster, without parachute!
-        window <- SDL.createWindow "Pioneers" (Position 100 100) (Size 1024 768) [WindowOpengl     -- we want openGL
+        window <- SDL.createWindow "Pioneers" (Position 1500 100) (Size 1024 768) [WindowOpengl     -- we want openGL
                                                                              ,WindowShown      -- window should be visible
                                                                              ,WindowResizable  -- and resizable 
                                                                              ,WindowInputFocus -- focused (=> active)
                                                                              ,WindowMouseFocus -- Mouse into it
                                                                              --,WindowInputGrabbed-- never let go of input (KB/Mouse)
                                                                              ]
-
         (Size fbWidth fbHeight) <- glGetDrawableSize window
         initRendering
         --generate map vertices
         (mapBuffer, vert) <- getMapBufferObject
         (ci, ni, vi, pri, vii, mi, nmi) <- initShader
+        putStrLn "foo"
         eventQueue <- newTQueueIO :: IO (TQueue Event)
+        putStrLn "foo"
+        now <- getCurrentTime
+        putStrLn "foo"
 
         let zDistClosest  = 10
             zDistFarthest = zDistClosest + 20
@@ -135,23 +147,83 @@ main = do
               , mapVert              = vert
               , stateFrustum         = frust
               , stateWinClose        = False
+              , stateClock           = now
               }
+
+        putStrLn "init done."
         void $ evalRWST (adjustWindow >> run) env state
 
         destroyWindow window
 
+-- Render-Pipeline
+
+draw :: Pioneers ()
+draw = do
+    env   <- ask
+    state <- get
+    let xa       = stateXAngle          state
+        ya       = stateYAngle          state
+        (GL.UniformLocation proj)  = shdrProjMatIndex   state
+        (GL.UniformLocation nmat)  = shdrNormalMatIndex state
+        (GL.UniformLocation vmat)  = shdrViewMatIndex   state
+        vi       = shdrVertexIndex      state
+        ni       = shdrNormalIndex      state
+        ci       = shdrColorIndex       state
+        numVert  = mapVert              state
+        map'     = stateMap             state
+        frust    = stateFrustum         state
+        camX     = statePositionX       state
+        camY     = statePositionY       state
+        zDist    = stateZDist           state
+    liftIO $ do
+        --(vi,GL.UniformLocation proj) <- initShader
+        GL.clear [GL.ColorBuffer, GL.DepthBuffer]
+        checkError "foo"
+        --set up projection (= copy from state)
+        with (distribute $ frust) $ \ptr ->
+              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+        checkError "foo"
+
+        --set up camera
+        let ! cam = getCam (camX,camY) zDist xa ya
+        with (distribute $ cam) $ \ptr ->
+              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+        checkError "foo"
+              
+        --set up normal--Mat transpose((model*camera)^-1)
+        let normal = (case inv33 ((fmap (^._xyz) cam) ^. _xyz) of
+                                             (Just a) -> a
+                                             Nothing  -> eye3) :: M33 CFloat
+            nmap = (collect (fmap id) normal) :: M33 CFloat --transpose...
+        
+        with (distribute $ nmap) $ \ptr ->
+              glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat)))
+
+        checkError "nmat"
+
+        GL.bindBuffer GL.ArrayBuffer GL.$= Just map'
+        GL.vertexAttribPointer ci GL.$= fgColorIndex
+        GL.vertexAttribArray ci   GL.$= GL.Enabled
+        GL.vertexAttribPointer ni GL.$= fgNormalIndex
+        GL.vertexAttribArray ni   GL.$= GL.Enabled
+        GL.vertexAttribPointer vi GL.$= fgVertexIndex
+        GL.vertexAttribArray vi   GL.$= GL.Enabled
+        checkError "beforeDraw"
+
+        GL.drawArrays GL.Triangles 0 numVert
+        checkError "draw"
+
+
 -- Main game loop
 
 run :: Pioneers ()
 run = do
     win <- asks envWindow
-    events <- asks envEventsChan
 
     -- draw Scene
     --draw
     liftIO $ do
         glSwapWindow win
-        submitEvents events
     -- getEvents & process
     processEvents
 
@@ -209,9 +281,19 @@ run = do
       {
       }
     -}
-
+    mt <- liftIO $ do
-
+        now <- getCurrentTime
-    unless (stateWinClose state) run
+        diff <- return $ diffUTCTime now (stateClock state) -- get time-diffs
+        sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
+        threadDelay sleepAmount
+        return now
+    -- set state with new clock-time
+    modify $ \s -> s
+        {
+                stateClock = mt
+        }
+    shouldClose <- return $ stateWinClose state
+    unless shouldClose run
 
 adjustWindow :: Pioneers ()
 adjustWindow = do
@@ -229,16 +311,15 @@ adjustWindow = do
     }
 
 
--- | Writes all Events atomically to global Queue for further processing.
-submitEvents :: TQueue Event -> IO ()
-submitEvents q = do
-        event <- pollEvent
-        case event of 
-                Nothing -> return ()
-                Just e -> do
-                                atomically $ writeTQueue q e
-                                submitEvents q
-
 processEvents :: Pioneers ()
 processEvents = do
-                return ()
+    me <- liftIO pollEvent
+    case me of
+      Just e -> do
+          processEvent e
+          processEvents
+      Nothing -> return ()
+
+processEvent :: Event -> Pioneers ()
+processEvent e = do
+        liftIO $ putStrLn (show e)