Refactor, remove dependency of Loop on Preload

app/Main.hs

@@ -38,13 +38,17 @@ main :: IO ()
 main = do
     (sizex,sizey) <- loadConfig
     setupLoop 
-        "windowName"
+        (sizex,sizey)
-        sizex sizey
         (doPreload >>= resizeSpareFBO sizex sizey)
         cleanUpPreload
         (fmap (setWindowSize sizex sizey) firstWorld)
         ( \preData w -> do
                       startTicks <- SDL.ticks
+                      errs <- errors
+                      if length errs > 0 
+                        then putStrLn $ "GLerror during doLoop: " ++ (unwords $ map show errs)
+                        else return ()
+                      clear [ColorBuffer,DepthBuffer]
                       (lightTicks,timeSpentPoking) <- renderPicture' (_renderData preData) 
                                             (_cameraRot w) (_cameraZoom w) 
                                             (_cameraPos w)

src/Loop.hs

@@ -1,6 +1,5 @@
 module Loop
     ( setupLoop
---    , withExits
     ) where
 import SDL
 import qualified Data.Text as T
@@ -11,8 +10,6 @@ import Control.Monad
 import System.Mem
 import Foreign.C
 
-import Preload
-
 import Control.Lens ((.~),(&),(+~))
 
 winConfig :: Int -> Int -> WindowConfig
@@ -26,101 +23,72 @@ winConfig x y = defaultWindow
     , windowResizable =True
     }
 
-setupLoop :: String
+setupLoop 
-        -> Int
+    :: (Int,Int)
-        -> Int
+    -> IO params
-        -> IO (PreloadData a)
+    -> (params -> IO ())
-        -> (PreloadData a -> IO ())
+    -> IO world
-        -> IO world
+    -> (params -> world -> IO params)
-        -> (PreloadData a -> world -> IO (PreloadData a))
+    -> (world -> Event -> Maybe world)
-        -> (world -> Event -> Maybe world)
+    -> (world -> Maybe world)
-        -> (world -> Maybe world)
+    -> IO ()
-        -> IO ()
+setupLoop 
-setupLoop wName xSize ySize 
+    (xSize,ySize)
-            customInit initCleanup ioStartWorld sideEffects eventFn worldFn = do 
+    initParams 
-    startWorld <- ioStartWorld
+    paramCleanup 
-    initializeAll
+    ioStartWorld 
-    bracket (createWindow (T.pack wName) (winConfig xSize ySize)) destroyWindow
+    sideEffects 
-        (\window -> 
+    eventFn 
-            do bracket (glCreateContext window) (\con -> GL.finish >> glDeleteContext con)
+    worldFn = do 
-                 (\_ -> bracket customInit initCleanup $ \setup -> do --  setup <- customInit
+        startWorld <- ioStartWorld
---                            swapInterval $= ImmediateUpdates
+        initializeAll
-                            GL.blend $= GL.Enabled
+        bracket 
---                            GL.depthMask $= GL.Enabled
+            (createWindow (T.pack "A Minimal Game Loop") (winConfig xSize ySize)) 
-                            GL.blendEquation $= GL.FuncAdd
+            destroyWindow 
-                            GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha)
+            $ \window -> bracket 
-                            GL.clearColor $= GL.Color4 0 0.5 0 1
+                (glCreateContext window) 
-                            GL.clearDepth $= (200)
+                (\con -> GL.finish >> glDeleteContext con)
-                            swapInterval $= ImmediateUpdates
+                $ \_ -> bracket 
-                            GL.lineSmooth $= GL.Enabled
+                    initParams 
-                            doLoop setup window startWorld
+                    paramCleanup 
-                                   sideEffects eventFn worldFn
+                    $ \setup -> doLoop setup window startWorld sideEffects eventFn worldFn
-                 )
-        )
 
-
+doLoop 
---doLoop :: setupParams -> Window -> WorldView world0
+    :: params 
---            -> (setupParams -> WorldView world0 -> IO ()) 
+    -> Window 
---            -> (world0 -> Event -> Maybe world0) 
+    -> world
---            -> (world0 -> Maybe world0) 
+    -> (params -> world -> IO params) 
---            -> IO ()
+    -> (world -> Event -> Maybe world) 
-doLoop setup window startWorld
+    -> (world -> Maybe world) 
-        worldSideEffects 
+    -> IO ()
-        eventFn 
+doLoop 
-        worldUpdate 
+    setup 
+    window 
+    startWorld
+    worldSideEffects 
+    eventFn 
+    worldUpdate 
   = do
-    errs <- GL.errors
-    if length errs > 0 then putStrLn $ "GLerror during doLoop: " ++ (unwords $ map show errs)
-                       else return ()
     startLoopTicks <- ticks
-    GL.clear [GL.ColorBuffer,GL.DepthBuffer]
+    newParams <- worldSideEffects setup startWorld
-    newParams <- worldSideEffects (setup & currentTime .~ startLoopTicks) startWorld
     glSwapWindow window
-    endSideTicks <- ticks
     events <- pollEvents
-    maybeUpdatedWorld <- applyEventsIO eventFn startWorld events
+    maybeUpdatedWorld <- foldM (applyEventIO eventFn) (Just startWorld) events
     case maybeUpdatedWorld >>= worldUpdate of
         Just updatedWorld -> do 
-            endSimTicks <- ticks
             performGC
             endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic)
             let delay = max 0 (20 + fromIntegral startLoopTicks - fromIntegral endLoopTicks)
             threadDelay (delay * 1000 )
             endTime <- ticks
-            let newNewParams = newParams & idleTime +~ (endTime - endLoopTicks)
+            doLoop newParams window updatedWorld worldSideEffects eventFn worldUpdate
-                                         & gcTime +~ (endLoopTicks - endSimTicks)
+        Nothing -> return ()
-                                         & simTime +~ (endSimTicks - endSideTicks)
-            doLoop newNewParams window updatedWorld worldSideEffects eventFn worldUpdate
-        Nothing -> showTiming setup
-
-applyEvents :: (world0 -> Event -> Maybe world0)
-                -> world0 
-                -> [Event]
-                -> (world0 -> Maybe world0)
-                -> Maybe world0
-applyEvents eventFn startWorld events worldUpdate = 
-    case foldM (applyH eventFn) startWorld events of
-        Just w -> fmap (\w' -> w') $ worldUpdate w
-        Nothing -> Nothing
-    where
-        applyH :: (world0 -> Event -> Maybe world0) -> world0 -> Event -> Maybe world0
-        applyH f w e 
-            = case eventPayload e of
-                QuitEvent -> Nothing
-                WindowClosedEvent _ -> Nothing
-                _ -> f w e
 
 applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
 applyEventIO fn mw e = case eventPayload e of
-    QuitEvent -> return Nothing
+    QuitEvent           -> return Nothing
     WindowClosedEvent _ -> return Nothing
-    WindowSizeChangedEvent
+    WindowSizeChangedEvent (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
-     (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
+                        -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
-        -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
+    _                   -> return $ mw >>= flip fn e
-    _   -> return $ mw >>= flip fn e
 
-applyEventsIO :: (world0 -> Event -> Maybe world0)
-                -> world0 
-                -> [Event]
-                -> IO (Maybe world0)
-applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es

src/Picture/Preload.hs

@@ -92,6 +92,16 @@ preloadRender = do
         , _fboRenderbufferObject = fboRBO
         }
 
+-- potential drawing setup
+----                            swapInterval $= ImmediateUpdates
+--                            GL.blend $= GL.Enabled
+----                            GL.depthMask $= GL.Enabled
+--                            GL.blendEquation $= GL.FuncAdd
+--                            GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha)
+--                            GL.clearColor $= GL.Color4 0 0.5 0 1
+--                            GL.clearDepth $= (200)
+--                            swapInterval $= ImmediateUpdates
+--                            GL.lineSmooth $= GL.Enabled
 
 --------------------end preloadRender