From 3a52f3feaf2132537499f0f70127942c90c10b11 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 24 Mar 2021 18:41:29 +0100 Subject: [PATCH] Cleanup preload, add basic frame time checking --- app/Main.hs | 17 +++++++++-------- src/Loop.hs | 41 +++++++++++++++++++++++++++++------------ src/Preload.hs | 14 +------------- src/Preload/Data.hs | 10 +--------- src/Sound.hs | 1 - 5 files changed, 40 insertions(+), 43 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 6a07bfaf3..24e8692c3 100644 --- a/app/Main.hs +++ b/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}) - & renderTime +~ (endRenderTicks - startTicks) - & mixerTime +~ (endMixerTicks - endRenderTicks) - & renderLighting +~ (lightTicks - startTicks) - & renderPicture +~ (endRenderTicks - lightTicks) - & pokeTime +~ timeSpentPoking + + endTicks <- SDL.ticks + let lastFrameTicks = _frameTimer preData + renderFoldable (_renderData preData) + (picToLTree Nothing . setLayer 1 . setDepth (-1) + . translate 0 (-0.8) . scale 0.0005 0.0005 + . text $ show (endTicks - lastFrameTicks)) + return $ preData & soundData .~ newSoundData + & frameTimer .~ endTicks ) (flip $ menuEvents $ flip handleEvent) (\w -> Just $ update w) diff --git a/src/Loop.hs b/src/Loop.hs index b8b10ebfb..7a25e9a0e 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -47,43 +47,60 @@ setupLoop destroyWindow $ \window -> bracket (glCreateContext window) - (\con -> GL.finish >> glDeleteContext con) - $ \_ -> bracket + ( \con -> GL.finish >> glDeleteContext con) + $ \_ -> 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 - newParams <- worldSideEffects setup startWorld + startTicks <- ticks + 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) - let delay = max 0 (20 + fromIntegral startLoopTicks - fromIntegral endLoopTicks) + endTicks <- ticks -- it might be better to use System.Clock (monotonic) + + 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 diff --git a/src/Preload.hs b/src/Preload.hs index 715e9b937..2900f2307 100644 --- a/src/Preload.hs +++ b/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) - diff --git a/src/Preload/Data.hs b/src/Preload/Data.hs index 4c21fbbe7..6b6e22314 100644 --- a/src/Preload/Data.hs +++ b/src/Preload/Data.hs @@ -10,15 +10,7 @@ import Sound.Preload data PreloadData a = PreloadData { _renderData :: RenderData , _soundData :: SoundData a - , _currentTime :: Word32 - , _renderTime :: Word32 - , _renderLighting :: Word32 - , _renderPicture :: Word32 - , _simTime :: Word32 - , _mixerTime :: Word32 - , _idleTime :: Word32 - , _gcTime :: Word32 - , _pokeTime :: Word32 + , _frameTimer :: Word32 } makeLenses ''PreloadData diff --git a/src/Sound.hs b/src/Sound.hs index 01a9c4b7d..60d207d35 100644 --- a/src/Sound.hs +++ b/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