loop/src/Loop.hs

{-# LANGUAGE BangPatterns #-}

--{-# 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,
    setupConLoop,
) where

import Loop.Data
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

-- | Create a game loop with an SDL window.
setupConLoop ::
    -- | 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 ->
    ---- | Concurrent effects. Evaluating 'Nothing' exits the loop
    --(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
    (world -> ConcurrentEffect 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 ()
setupConLoop spf title winconfig paramCleanup ioStartWorld coneffs sideEffects eventFn = do
    initializeAll
    themvar <- newEmptyMVar
    bracket
        (createWindow title winconfig)
        destroyWindow
        $ \window -> bracket
            (glCreateContext window)
            (\con -> GL.finish >> glDeleteContext con)
            $ \_ ->
                bracket
                    ioStartWorld
                    paramCleanup
                    (doConLoop themvar spf window coneffs sideEffects eventFn)

-- | The internal loop.
doConLoop ::
    -- | The mvar for concurrency
    MVar (world -> Maybe world) ->
    -- | target msec per frame
    Int ->
    -- | The SDL window.
    Window ->
    ---- | Concurrent effects, the first function in the pair is applied
    ---- immediately
    --(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
    (world -> ConcurrentEffect world) ->
    -- | simulation update.
    (world -> IO world) ->
    -- | SDL Event handling.
    (world -> Event -> IO (Maybe world)) ->
    -- | Current simulation state.
    world ->
    IO ()
doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld
  where
    go sw = do
        startTicks <- ticks
        let mconeff = coneffs sw
        case mconeff of
            NoConcurrentEffect -> return ()
            ConcurrentEffect _ acc -> do
                _ <- forkIO $ do
                    up <- acc
                    putMVar themvar up
                return ()
        let startWorld'' = case mconeff of
                NoConcurrentEffect -> sw
                ConcurrentEffect immediatef _ -> immediatef sw
        mconupdate <- tryTakeMVar themvar
        let mstartWorld' = case mconupdate of
                Just conupdate -> conupdate startWorld''
                Nothing -> Just startWorld''
        case mstartWorld' of
            Nothing -> return ()
            Just startWorld' -> do
                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)
                        go $! updatedWorld
                    Nothing -> return ()