vulkan-tutorial/extern/src/Affection.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
module Affection
    ( withAffection
    , get
    , put
    , liftIO
    , module A
    ) where

import SDL (($=))
import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL

import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
import qualified Graphics.GL as GLRaw

import Foreign.Marshal.Array

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8

import System.Clock

import Control.Monad.Loops
import Control.Monad.State.Strict

-- internal imports

import Affection.Types as A
import Affection.Class as A
import Affection.StateMachine as A
import Affection.Util as A
import Affection.MessageBus as A
import Affection.Subsystems as A

import Affection.Logging as A

-- | Main function which bootstraps everything else.
withAffection
  :: forall us. (Affectionate us)
  => AffectionConfig us -- ^ Configuration of the Game and its engine.
  -> IO ()
withAffection AffectionConfig{..} = do
  liftIO $ logIO Debug "Affection starting"
  liftIO $ logIO Debug "Initializing SDL"
  -- intialiaze SDL
  case initComponents of
    All ->
      SDL.initializeAll
    Only is ->
      SDL.initialize is
  -- give SDL render quality
  SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
  -- just checking…
  do
    renderQuality <- SDL.get SDL.HintRenderScaleQuality
    when (renderQuality /= SDL.ScaleLinear) $
      logIO Warn "Linear texture filtering not enabled!"
  -- construct window
  liftIO $ logIO Debug "Creating Window(s)"
  windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
    mapM
    (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
    windowConfigs <*>
    pure (map (\(_,_,z) -> z) windowConfigs)

  mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
  contexts <- zip (map (\(x,_,_) -> x) windows) <$>
    mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
  mapM_ (\w -> flip SDL.setWindowMode  ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows
  -- sync updates with monitor
  -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
  liftIO $ logIO Debug "Getting Time"
  -- print current used GL Version
  version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
  print (B.pack version)
  -- get current time
  execTime <- getTime Monotonic
  liftIO $ logIO Debug "Loading initial data container"
  -- construct game data object from provided Affectionate instance
  gameData <- loadState @us
  -- build state container
  let initContainer = AffectionData
        { drawWindows     = windows
        , glContext       = contexts
        , elapsedTime     = 0
        , deltaTime       = 0
        , sysTime         = execTime
        , pausedTime      = False
        }
  -- initialize and run state
  (_, _) <- runStateT
    (A.runState
      (do
        liftIO $ logIO Debug "Running Pre-Loop stage"
        -- run preLoop function from Affectionate
        preLoop gameData
        liftIO $ logIO Debug "Starting Loop"
        whileM_ (hasNextStep gameData)
          (do
            -- get state
            ad <- get
            -- Measure time difference form last run
            now      <- liftIO $ getTime Monotonic
            let lastTime = sysTime ad
            -- compute dt and update elapsedTime
            let dt = fromIntegral
                   (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
                ne = elapsedTime ad + dt
            -- update state data object with new time values
            put $ ad
              { elapsedTime = ne
              , deltaTime = dt
              }
            -- poll events
            liftIO SDL.pumpEvents
            evs <- preHandleEvents =<< liftIO SDL.pollEvents
            -- handle events
            handleEvents gameData evs
            -- execute user defined update loop
            unless (pausedTime ad) (update gameData dt)
            -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
            liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
            draw gameData
            liftIO GL.flush
            -- actual displaying of newly drawn frame
            mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
            -- save new time
            ad3 <- get
            when (sysTime ad == sysTime ad3) (
              put ad3
                { sysTime = now
                }
              )
            )
        )
      ) initContainer
  liftIO $ logIO Debug "Loop ended. Cleaning"
  cleanUp gameData
  liftIO $ logIO Debug "Destroying Window"
  mapM_ (SDL.glDeleteContext . snd) contexts
  mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
  -- SDL.quit -- <- This causes segfaults depending on hardware
  liftIO $ logIO Debug "This is the end"