Allow for concurrent effects

src/Loop.hs

@@ -8,6 +8,7 @@ This module sets up an SDL window which may be updated using a simple game loop.
 -}
 module Loop (
     setupLoop,
+    setupConLoop,
 ) where
 
 import Control.Concurrent
@@ -89,3 +90,78 @@ applyEventIO fn mw e = case eventPayload e of
     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
+    (world -> Maybe (IO (world -> 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 -> world) ->
+    -- | target msec per frame
+    Int ->
+    -- | The SDL window.
+    Window ->
+    -- | Concurrent effects
+    (world -> Maybe (IO (world -> 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 = do
+    startTicks <- ticks
+    mconupdate <- tryTakeMVar themvar
+    case coneffs startWorld of
+        Nothing -> return ()
+        Just acc -> do
+            _ <- forkIO $ do
+                up <- acc
+                putMVar themvar up
+            return ()
+    let startWorld' = case mconupdate of
+            Just conupdate -> conupdate startWorld
+            Nothing -> startWorld
+    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)
+            doConLoop themvar spf window coneffs worldSideEffects eventFn updatedWorld
+        Nothing -> return ()