92 lines
2.9 KiB
Haskell
92 lines
2.9 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
|
|
{- |
|
|
Module : Loop
|
|
Description : Simple game loop
|
|
|
|
This module sets up an SDL window which may be updated using a simple game loop.
|
|
-}
|
|
module Loop (
|
|
setupLoop,
|
|
) where
|
|
|
|
import Control.Concurrent
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import qualified Data.Text as T
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
import SDL
|
|
import System.Mem
|
|
|
|
-- | Create a game loop with an SDL window.
|
|
setupLoop ::
|
|
-- | Target seconds per frame
|
|
Int ->
|
|
-- | Window title
|
|
T.Text ->
|
|
WindowConfig ->
|
|
-- | Function for cleaning up parameters, applied when exiting loop.
|
|
(world -> IO ()) ->
|
|
-- | Initial simulation state.
|
|
IO world ->
|
|
-- | update, called once per frame. Allows for side effects such as rendering.
|
|
(world -> IO world) ->
|
|
-- | SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
|
|
(world -> Event -> IO (Maybe world)) ->
|
|
IO ()
|
|
setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do
|
|
initializeAll
|
|
bracket
|
|
(createWindow title winconfig)
|
|
destroyWindow
|
|
$ \window -> bracket
|
|
(glCreateContext window)
|
|
(\con -> GL.finish >> glDeleteContext con)
|
|
$ \_ ->
|
|
bracket
|
|
ioStartWorld
|
|
paramCleanup
|
|
(doLoop spf window sideEffects eventFn)
|
|
|
|
-- | The internal loop.
|
|
doLoop ::
|
|
-- | target msec per frame
|
|
Int ->
|
|
-- | The SDL window.
|
|
Window ->
|
|
-- | simulation update.
|
|
(world -> IO world) ->
|
|
-- | SDL Event handling.
|
|
(world -> Event -> IO (Maybe world)) ->
|
|
-- | Current simulation state.
|
|
world ->
|
|
IO ()
|
|
doLoop spf window worldSideEffects eventFn startWorld = do
|
|
startTicks <- ticks
|
|
worldAfterSimStep <- worldSideEffects startWorld
|
|
glSwapWindow window
|
|
maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep)
|
|
case maybeUpdatedWorld of
|
|
Just updatedWorld -> do
|
|
performGC
|
|
endTicks <- ticks -- it might be better to use System.Clock (monotonic)
|
|
let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks)
|
|
threadDelay (theDelay * 1000)
|
|
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.
|
|
-}
|
|
applyEventIO :: (world -> Event -> IO (Maybe world)) -> Maybe world -> Event -> IO (Maybe world)
|
|
applyEventIO fn mw 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)) >> mupdate
|
|
_ -> mupdate
|
|
where
|
|
mupdate = case mw of
|
|
Nothing -> return Nothing
|
|
Just w -> fn w e
|