99 lines
3.7 KiB
Haskell
99 lines
3.7 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 qualified Data.Text as T
|
|
import Control.Concurrent
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import System.Mem
|
|
import SDL
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
-- | Create a game loop with an SDL window.
|
|
setupLoop
|
|
:: Int -- ^ Target seconds per frame
|
|
-> (Int,Int) -- ^ The window size.
|
|
-> Maybe (Int,Int) -- ^ The window position.
|
|
-> (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 -> IO (Maybe world))
|
|
-- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
|
|
-> IO ()
|
|
setupLoop spf (xSize,ySize) winpos paramCleanup ioStartWorld sideEffects eventFn = do
|
|
initializeAll
|
|
bracket
|
|
(createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize winpos))
|
|
destroyWindow
|
|
$ \window -> bracket
|
|
(glCreateContext window)
|
|
( \con -> GL.finish >> glDeleteContext con)
|
|
$ \_ -> bracket
|
|
ioStartWorld
|
|
paramCleanup
|
|
$ doLoop spf window sideEffects eventFn
|
|
-- | The internal loop.
|
|
doLoop
|
|
:: Int -- ^ target msec per frame
|
|
-> Window -- ^ The SDL window.
|
|
-> (world -> IO world) -- ^ simulation update.
|
|
-> (world -> Event -> IO (Maybe world)) -- ^ SDL Event handling.
|
|
-> world -- ^ Current simulation state.
|
|
-> IO ()
|
|
doLoop
|
|
spf
|
|
window
|
|
worldSideEffects
|
|
eventFn
|
|
startWorld
|
|
= do
|
|
startTicks <- ticks
|
|
worldAfterSimStep <- worldSideEffects startWorld
|
|
glSwapWindow window
|
|
events <- pollEvents
|
|
maybeUpdatedWorld <- foldM (applyEventIO eventFn) (Just worldAfterSimStep) events
|
|
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
|
|
-- | Create an OpenGL SDL window configuration with a given x and y size.
|
|
winConfig :: Int -> Int -> Maybe (Int, Int) -> WindowConfig
|
|
winConfig x y winpos = defaultWindow
|
|
{ windowGraphicsContext = OpenGLContext $ defaultOpenGL
|
|
{ glProfile = Core Normal 4 3
|
|
, glColorPrecision = V4 8 8 8 8
|
|
}
|
|
, windowPosition = theWinPos
|
|
, windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
|
|
, windowResizable =True
|
|
}
|
|
where
|
|
theWinPos = case winpos of
|
|
Just (px,py) -> Absolute (P (V2 (fromIntegral px) (fromIntegral py)))
|
|
Nothing -> Wherever
|