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

import Loop.Data
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.Text as T
import Graphics.GL.Core45
import SDL
import System.Mem
import Data.Foldable

-- | 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 -> glFinish >> 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} ->
        glViewport 0 0 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 -> glFinish >> glDeleteContext con)
            $ \_ ->
                bracket
                    ioStartWorld
                    paramCleanup
                    (doConLoop themvar spf window coneffs sideEffects eventFn)

-- | The internal loop.
-- Note that ImmediateEffect from ConcurrentEffect does not work properly.
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 ()
            ImmediateEffect _ -> return ()
            ConcurrentEffect _ acc -> do
                _ <- forkIO $ do
                    up <- acc
                    putMVar themvar up
                return ()
        let startWorld'' = case mconeff of
                NoConcurrentEffect -> sw
                ImmediateEffect _ -> sw
                ConcurrentEffect immediatef _ -> immediatef
        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 ()

-- | 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 -> ConcurrentEffect world) ->
    -- | update, called once per frame. Allows for side effects such as rendering.
    -- passes the window to allow buffer swapping
    (Window -> world -> IO world) ->
    -- | SDL Event handling, once per frame. Note no side effects.
    (world -> Event ->  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 -> glFinish >> 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 -> ConcurrentEffect world) ->
    -- | simulation update. Allows for side effects such as rendering.
    -- passes the window to allow buffer swapping at different times
    (Window -> world -> IO world) ->
    -- | SDL Event handling. Note no side effects.
    (world -> Event -> world) ->
    -- | Current simulation state.
    world ->
    IO ()
doConLoop' themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld
  where
    worldSideEffectsWindow = worldSideEffects window
    go sw = do
        startTicks <- ticks
        es <- pollEvents
        mworldAfterCon <- case coneffs sw of
            NoConcurrentEffect -> return $ Just sw
            ImmediateEffect msw -> msw
            ConcurrentEffect sw' acc -> do
                _ <- forkIO $ do
                    up <- acc
                    putMVar themvar up
                return $ Just sw'
        mconupdate <- tryTakeMVar themvar
        let mstartWorld' = case mconupdate of
                Just conupdate -> conupdate =<< mworldAfterCon
                Nothing -> mworldAfterCon
        case mstartWorld' of
            Nothing -> return ()
            Just startWorld' -> do
                worldAfterSimStep <- worldSideEffectsWindow startWorld'
--                glSwapWindow window
                let updatedWorld = foldl' eventFn worldAfterSimStep es
                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