116 lines
4.0 KiB
Haskell
116 lines
4.0 KiB
Haskell
{- |
|
|
Module : Loop
|
|
Description : Minimal 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 Foreign.C
|
|
import SDL
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
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 "A Minimal Game Loop") (winConfig xSize ySize))
|
|
destroyWindow
|
|
$ \window -> bracket
|
|
(glCreateContext window)
|
|
( \con -> GL.finish >> glDeleteContext con)
|
|
$ \_ -> bracket
|
|
initParams
|
|
paramCleanup
|
|
$ doLoop window startWorld sideEffects eventFn worldFn
|
|
|
|
-- | 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 delay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
|
|
threadDelay (delay * 1000 )
|
|
|
|
doLoop window updatedWorld worldSideEffects eventFn worldUpdate newParams
|
|
Nothing -> return ()
|
|
|
|
applyEventsIO
|
|
:: (world -> Event -> Maybe world)
|
|
-> world
|
|
-> [Event]
|
|
-> IO (Maybe world)
|
|
applyEventsIO fn w = foldM (applyEventIO fn) (Just w)
|
|
|
|
-- | 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 -> 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) >> return (mw >>= \w -> fn w e)
|
|
_ -> return $ mw >>= flip fn e
|
|
|
|
-- | Create an OpenGL SDL window configuration with a given x and y size.
|
|
winConfig :: Int -> Int -> WindowConfig
|
|
winConfig x y = defaultWindow
|
|
{ windowGraphicsContext
|
|
= OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
|
|
, glColorPrecision = V4 8 8 8 8
|
|
}
|
|
)
|
|
, windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
|
|
, windowResizable =True
|
|
}
|
|
|