Move debug flags to config, various perf improvements
This commit is contained in:
+12
-134
@@ -7,64 +7,27 @@ This module sets up an SDL window which may be updated using a simple game loop.
|
||||
-}
|
||||
module Loop
|
||||
( setupLoop
|
||||
, setupMiniLoop
|
||||
, setupLoop'
|
||||
) where
|
||||
import qualified Data.Text as T
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Maybe
|
||||
import System.Mem
|
||||
--import Foreign.C
|
||||
import SDL
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
||||
--import Control.Lens ((.~),(&),(+~))
|
||||
|
||||
-- | Create a game loop with an SDL window.
|
||||
setupLoop
|
||||
:: (Int,Int) -- ^ The window size.
|
||||
-> IO params -- ^ Initial parameters.
|
||||
-> (params -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop.
|
||||
-> IO world -- ^ Initial simulation state.
|
||||
-> (params -> world -> IO params) -- ^ Parameter update, called once per frame. Allows for side effects such as rendering.
|
||||
-> (world -> Event -> Maybe world)
|
||||
-- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
|
||||
-> (world -> Maybe world)
|
||||
-- ^ Simulation update, once per frame. 'Nothing' exits the loop.
|
||||
-> IO ()
|
||||
setupLoop
|
||||
(xSize,ySize)
|
||||
initParams
|
||||
paramCleanup
|
||||
ioStartWorld
|
||||
sideEffects
|
||||
eventFn
|
||||
worldFn = do
|
||||
startWorld <- ioStartWorld
|
||||
initializeAll
|
||||
bracket
|
||||
(createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize))
|
||||
destroyWindow
|
||||
$ \window -> bracket
|
||||
(glCreateContext window)
|
||||
( \con -> GL.finish >> glDeleteContext con)
|
||||
$ \_ -> bracket
|
||||
initParams
|
||||
paramCleanup
|
||||
$ doLoop window startWorld sideEffects eventFn worldFn
|
||||
|
||||
|
||||
-- | Create a game loop with an SDL window.
|
||||
setupLoop'
|
||||
:: (Int,Int) -- ^ The window size.
|
||||
:: Int -- ^ Target seconds per frame
|
||||
-> (Int,Int) -- ^ The window size.
|
||||
-> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop.
|
||||
-> IO world -- ^ Initial simulation state.
|
||||
-> (world -> IO world) -- ^ update, called once per frame. Allows for side effects such as rendering.
|
||||
-> (world -> Event -> Maybe world)
|
||||
-- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
|
||||
-> IO ()
|
||||
setupLoop' (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do
|
||||
setupLoop spf (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do
|
||||
initializeAll
|
||||
bracket
|
||||
(createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize))
|
||||
@@ -75,15 +38,17 @@ setupLoop' (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do
|
||||
$ \_ -> bracket
|
||||
ioStartWorld
|
||||
paramCleanup
|
||||
$ doLoop' window sideEffects eventFn
|
||||
$ doLoop spf window sideEffects eventFn
|
||||
-- | The internal loop.
|
||||
doLoop'
|
||||
:: Window -- ^ The SDL window.
|
||||
doLoop
|
||||
:: Int -- ^ target msec per frame
|
||||
-> Window -- ^ The SDL window.
|
||||
-> (world -> IO world) -- ^ simulation update.
|
||||
-> (world -> Event -> Maybe world) -- ^ SDL Event handling.
|
||||
-> world -- ^ Current simulation state.
|
||||
-> IO ()
|
||||
doLoop'
|
||||
doLoop
|
||||
spf
|
||||
window
|
||||
worldSideEffects
|
||||
eventFn
|
||||
@@ -99,42 +64,10 @@ doLoop'
|
||||
performGC
|
||||
endTicks <- ticks -- it might be better to use System.Clock (monotonic)
|
||||
|
||||
let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
|
||||
let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks)
|
||||
threadDelay (theDelay * 1000 )
|
||||
|
||||
doLoop' window worldSideEffects eventFn updatedWorld
|
||||
Nothing -> return ()
|
||||
-- | The internal loop.
|
||||
doLoop
|
||||
:: Window -- ^ The SDL window.
|
||||
-> world -- ^ Current simulation state.
|
||||
-> (params -> world -> IO params) -- ^ Parameter update.
|
||||
-> (world -> Event -> Maybe world) -- ^ SDL Event handling.
|
||||
-> (world -> Maybe world) -- ^ Simulation update
|
||||
-> params -- ^ Current parameters.
|
||||
-> IO ()
|
||||
doLoop
|
||||
window
|
||||
startWorld
|
||||
worldSideEffects
|
||||
eventFn
|
||||
worldUpdate
|
||||
startParams
|
||||
= do
|
||||
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
|
||||
endTicks <- ticks -- it might be better to use System.Clock (monotonic)
|
||||
|
||||
let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
|
||||
threadDelay (theDelay * 1000 )
|
||||
|
||||
doLoop window updatedWorld worldSideEffects eventFn worldUpdate newParams
|
||||
doLoop spf window worldSideEffects eventFn updatedWorld
|
||||
Nothing -> return ()
|
||||
-- | Handle quit events in a manner to exit the loop. Other events handled as
|
||||
-- determined by the custom function, although resize events also change the viewport.
|
||||
@@ -156,59 +89,4 @@ winConfig x y = defaultWindow
|
||||
, windowResizable =True
|
||||
}
|
||||
|
||||
setupMiniLoop
|
||||
:: (Int,Int) -- ^ The window size.
|
||||
-> IO world -- ^ Initial simulation state.
|
||||
-> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop.
|
||||
-> (world -> Event -> MaybeT IO world)
|
||||
-- ^ Event handling
|
||||
-> (world -> MaybeT IO world)
|
||||
-- ^ Simulation update
|
||||
-> IO ()
|
||||
setupMiniLoop (xsize,ysize) initWorld cleanup eventUpdate simUpdate = do
|
||||
bracket
|
||||
(createWindow (T.pack "Mini Loop") (winConfig xsize ysize))
|
||||
destroyWindow
|
||||
$ \window -> bracket
|
||||
(glCreateContext window)
|
||||
(\con -> GL.finish >> glDeleteContext con)
|
||||
$ \_ -> bracket
|
||||
initWorld
|
||||
cleanup
|
||||
(doMiniLoop window eventUpdate simUpdate)
|
||||
|
||||
doMiniLoop
|
||||
:: Window
|
||||
-> (world -> Event -> MaybeT IO world)
|
||||
-> (world -> MaybeT IO world)
|
||||
-> world
|
||||
-> IO ()
|
||||
doMiniLoop window eventUpdate simUpdate startWorld = do
|
||||
startTicks <- ticks
|
||||
glSwapWindow window
|
||||
mayWorld <- runMaybeT $ foldEventsT (plungeMaybe eventUpdate) startWorld >>= simUpdate
|
||||
case mayWorld of
|
||||
Just w -> do
|
||||
performGC
|
||||
endTicks <- ticks -- it might be better to use System.Clock (monotonic)
|
||||
|
||||
let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
|
||||
threadDelay (theDelay * 1000 )
|
||||
|
||||
doMiniLoop window eventUpdate simUpdate w
|
||||
Nothing -> return ()
|
||||
|
||||
plungeMaybe :: (a -> b -> MaybeT IO a) -> Maybe a -> b -> IO (Maybe a)
|
||||
plungeMaybe f a b = runMaybeT $ MaybeT (pure a) >>= flip f b
|
||||
|
||||
foldEventsT :: (Maybe world -> Event -> IO (Maybe world)) -> world -> MaybeT IO world
|
||||
foldEventsT f w = MaybeT $ foldEvents f w
|
||||
|
||||
foldEvents :: (Maybe world -> Event -> IO (Maybe world)) -> world -> IO (Maybe world)
|
||||
foldEvents f w = VS.foldlM' f (Just w) streamEvents
|
||||
|
||||
streamEvents :: VS.Stream IO Event
|
||||
streamEvents = VS.unfoldrM pollEventSeed ()
|
||||
|
||||
pollEventSeed :: () -> IO (Maybe (Event,()))
|
||||
pollEventSeed _ = fmap (fmap (,())) pollEvent
|
||||
|
||||
Reference in New Issue
Block a user