loop/src/Loop.hs

{-# 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
    , setupMiniLoop
    , setupLoop'
    ) where
import qualified Data.Text as T
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Maybe
import System.Mem
--import Foreign.C
import SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Fusion.Stream.Monadic as VS
--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 "Simple Game Loop") (winConfig xSize ySize)) 
            destroyWindow 
            $ \window -> bracket 
                (glCreateContext window) 
                ( \con -> GL.finish >> glDeleteContext con)
                $ \_   -> bracket 
                    initParams 
                    paramCleanup 
                    $ doLoop window startWorld sideEffects eventFn worldFn


-- | Create a game loop with an SDL window.
setupLoop'
    :: (Int,Int)            -- ^ The window size.
    -> (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 -> Maybe world)
                            -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
    -> IO ()
setupLoop' (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do 
    initializeAll
    bracket 
        (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize)) 
        destroyWindow 
        $ \window -> bracket 
            (glCreateContext window) 
            ( \con -> GL.finish >> glDeleteContext con)
            $ \_   -> bracket 
                ioStartWorld
                paramCleanup 
                $ doLoop' window sideEffects eventFn
-- | The internal loop.
doLoop'
    :: Window   -- ^ The SDL window.
    -> (world -> IO world) -- ^ simulation update. 
    -> (world -> Event -> Maybe world) -- ^ SDL Event handling.
    -> world    -- ^ Current simulation state.
    -> IO ()
doLoop' 
    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 (20 + fromIntegral startTicks - fromIntegral endTicks)
            threadDelay (theDelay * 1000 )

            doLoop' window worldSideEffects eventFn updatedWorld
        Nothing -> return ()
-- | 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 theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
            threadDelay (theDelay * 1000 )

            doLoop window updatedWorld worldSideEffects eventFn worldUpdate newParams
        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 -> 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
    }

setupMiniLoop
    :: (Int,Int)            -- ^ The window size.
    -> IO world             -- ^ Initial simulation state.
    -> (world -> IO ())      -- ^ Function for cleaning up parameters, applied when exiting loop.
    -> (world -> Event -> MaybeT IO world)
                            -- ^ Event handling
    -> (world -> MaybeT IO world)
                            -- ^ Simulation update
    -> IO ()
setupMiniLoop (xsize,ysize) initWorld cleanup eventUpdate simUpdate = do
    bracket     
        (createWindow (T.pack "Mini Loop") (winConfig xsize ysize))
        destroyWindow
        $ \window -> bracket
            (glCreateContext window)
            (\con -> GL.finish >> glDeleteContext con)
            $ \_ -> bracket
                initWorld
                cleanup
                (doMiniLoop window eventUpdate simUpdate)

doMiniLoop 
    :: Window
    -> (world -> Event -> MaybeT IO world)
    -> (world -> MaybeT IO world)
    -> world
    -> IO ()
doMiniLoop window eventUpdate simUpdate startWorld = do
    startTicks <- ticks
    glSwapWindow window
    mayWorld <- runMaybeT $ foldEventsT (plungeMaybe eventUpdate) startWorld >>= simUpdate
    case mayWorld of
        Just w -> do 
            performGC
            endTicks <- ticks -- it might be better to use System.Clock (monotonic)

            let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
            threadDelay (theDelay * 1000 )

            doMiniLoop window eventUpdate simUpdate w
        Nothing -> return ()

plungeMaybe :: (a -> b -> MaybeT IO a) -> Maybe a -> b -> IO (Maybe a)
plungeMaybe f a b = runMaybeT $ MaybeT (pure a) >>= flip f b

foldEventsT :: (Maybe world -> Event -> IO (Maybe world)) -> world -> MaybeT IO world
foldEventsT f w = MaybeT $ foldEvents f w

foldEvents :: (Maybe world -> Event -> IO (Maybe world)) -> world -> IO (Maybe world)
foldEvents f w = VS.foldlM' f (Just w) streamEvents

streamEvents :: VS.Stream IO Event
streamEvents = VS.unfoldrM pollEventSeed ()

pollEventSeed :: () -> IO (Maybe (Event,()))
pollEventSeed _ = fmap (fmap (,())) pollEvent