pituicat/extern/affection/src/Affection.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# 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 System.Clock

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

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

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


-- | 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
  -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
  liftIO $ logIO Debug "Getting Time"
  -- 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 "Starting Loop"
        -- run preLoop function from Affectionate
        preLoop gameData
        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
            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"