Cleanup preload, add basic frame time checking

app/Main.hs

@@ -60,16 +60,17 @@ main = do
                                             (worldPictures w)
                       blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
                       renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w)
-                      endRenderTicks <- SDL.ticks
                       playSoundQueue (_soundData preData) (_soundQueue w)
                       newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
-                      endMixerTicks <- SDL.ticks
+
-                      return $ (preData {_soundData = newSoundData})
+                      endTicks <- SDL.ticks
-                                    & renderTime +~ (endRenderTicks - startTicks)
+                      let lastFrameTicks = _frameTimer preData
-                                    & mixerTime +~ (endMixerTicks - endRenderTicks)
+                      renderFoldable (_renderData preData) 
-                                    & renderLighting +~ (lightTicks - startTicks)
+                                     (picToLTree Nothing . setLayer 1 . setDepth (-1) 
-                                    & renderPicture +~ (endRenderTicks - lightTicks)
+                                       . translate 0 (-0.8) . scale 0.0005 0.0005 
-                                    & pokeTime +~ timeSpentPoking 
+                                       . text $ show (endTicks - lastFrameTicks))
+                      return $ preData & soundData  .~ newSoundData
+                                       & frameTimer .~ endTicks
         )
         (flip $ menuEvents $ flip handleEvent)
         (\w -> Just $ update w)

src/Loop.hs

@@ -47,43 +47,60 @@ setupLoop
             destroyWindow 
             $ \window -> bracket 
                 (glCreateContext window) 
-                (\con -> GL.finish >> glDeleteContext con)
+                ( \con -> GL.finish >> glDeleteContext con)
-                $ \_ -> bracket 
+                $ \_   -> bracket 
                     initParams 
                     paramCleanup 
-                    $ \setup -> doLoop setup window startWorld sideEffects eventFn worldFn
+                    $ doLoop window startWorld sideEffects eventFn worldFn
 
 doLoop 
-    :: params 
+    :: Window 
-    -> Window 
     -> world
     -> (params -> world -> IO params) 
     -> (world -> Event -> Maybe world) 
     -> (world -> Maybe world) 
+    -> params 
     -> IO ()
 doLoop 
-    setup 
     window 
     startWorld
     worldSideEffects 
     eventFn 
     worldUpdate 
+    startParams 
   = do
-    startLoopTicks <- ticks
+    startTicks <- ticks
-    newParams <- worldSideEffects setup startWorld
+    newParams <- worldSideEffects startParams startWorld
     glSwapWindow window
     events <- pollEvents
     maybeUpdatedWorld <- foldM (applyEventIO eventFn) (Just startWorld) events
     case maybeUpdatedWorld >>= worldUpdate of
         Just updatedWorld -> do 
             performGC
-            endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic)
+            endTicks <- ticks -- it might be better to use System.Clock (monotonic)
-            let delay = max 0 (20 + fromIntegral startLoopTicks - fromIntegral endLoopTicks)
+
+            let delay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
             threadDelay (delay * 1000 )
-            endTime <- ticks
+
-            doLoop newParams window updatedWorld worldSideEffects eventFn worldUpdate
+            doLoop window updatedWorld worldSideEffects eventFn worldUpdate newParams
         Nothing -> return ()
 
+applyEventsIO 
+    :: (world -> Event -> Maybe world)
+    -> world
+    -> [Event]
+    -> IO (Maybe world)
+applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es
+
+--eventCloseOrResize :: Event -> IO (Maybe Event)
+--eventCloseOrResize e = case eventPayload e of
+--    QuitEvent           -> return Nothing
+--    WindowClosedEvent _ -> return Nothing
+--    WindowSizeChangedEvent (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
+--                        -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (Just e)
+--    _                   -> return $ Just e
+--
+
 applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
 applyEventIO fn mw e = case eventPayload e of
     QuitEvent           -> return Nothing

src/Preload.hs

@@ -17,21 +17,9 @@ doPreload :: IO (PreloadData a)
 doPreload = do
     sData <- preloadSound
     rData <- preloadRender
-    return $ PreloadData rData sData 0 0 0 0 0 0 0 0 0
+    return $ PreloadData rData sData 0
 
 cleanUpPreload :: PreloadData a -> IO ()
 cleanUpPreload pd = do
     cleanUpRenderPreload $ _renderData pd
     cleanUpSoundPreload $ _soundData pd
-
-showTiming :: PreloadData a -> IO ()
-showTiming pd = do
-    putStrLn $ "Time rendering: " ++ show (_renderTime pd)
-    putStrLn $ "Time renderingLighting: " ++ show (_renderLighting pd)
-    putStrLn $ "Time renderingPicture: " ++ show (_renderPicture pd)
-    putStrLn $ "Time sim-ing: " ++ show (_simTime pd)
-    putStrLn $ "Time mixing: " ++ show (_mixerTime pd)
-    putStrLn $ "Time idle: " ++ show (_idleTime pd)
-    putStrLn $ "Time gc: " ++ show (_gcTime pd)
-    putStrLn $ "Time pokeing: " ++ show (_pokeTime pd)
-

src/Preload/Data.hs

@@ -10,15 +10,7 @@ import Sound.Preload
 data PreloadData a = PreloadData
     { _renderData :: RenderData
     , _soundData :: SoundData a
-    , _currentTime :: Word32
+    , _frameTimer :: Word32
-    , _renderTime :: Word32
-    , _renderLighting :: Word32
-    , _renderPicture :: Word32
-    , _simTime :: Word32
-    , _mixerTime :: Word32
-    , _idleTime :: Word32
-    , _gcTime :: Word32
-    , _pokeTime :: Word32
     }
 
 makeLenses ''PreloadData

src/Sound.hs

@@ -12,7 +12,6 @@ import qualified Data.Map as M
 
 import Control.Lens
 
-
 playSoundQueue :: SoundData a -> [Int] -> IO ()
 playSoundQueue sd ns = 
     forM_ ns $ \n -> playIfFree (_loadedChunks sd IM.! n) Mix.Once