pituicat/src/Affection.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
{-# 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 Data.String (fromString)

import System.Clock

import Control.Monad.Loops
import Control.Monad.State.Strict
import Control.Monad.Trans.Resource

-- 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{..} = runResourceT $ 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…
  renderQuality <- SDL.get SDL.HintRenderScaleQuality
  when (renderQuality /= SDL.ScaleLinear) $
    liftIO $ logIO Warn "Linear texture filtering not enabled!"
  void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))

  -- construct window
  liftIO $ logIO Debug "Creating Window(s)"
  windows <-
    mapM
      (\(_, sdlWindowConfig, mode) -> do
        (windowKey, window) <-
          allocate
            (SDL.createWindow windowTitle sdlWindowConfig)
            (\window -> do
              logIO Debug "Destroying Window"
              SDL.destroyWindow window
              )
        return $ AffectionWindow window windowKey mode
        )
      windowConfigs

  -- Show windows
  mapM_ (SDL.showWindow . awWindow) windows

  -- set modes of windows
  mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows

  -- Make GL context shareable
  void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1

  -- Create OpenGL contexts
  contexts <-
    mapM
      (\(AffectionWindow window _ _) -> do
        (contextKey, context) <-
          allocate
            (SDL.glCreateContext window)
            (\context -> do
              logIO Debug "Destroying context"
              SDL.glDeleteContext context
              )
        return $ AffectionContext context contextKey
        )
      windows

  -- sync updates with monitor
  -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows

  -- print current used GL Version
  version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
  liftIO $ print (B.pack version)

  -- get current time
  liftIO $ logIO Debug "Getting Time"
  execTime <- liftIO $ getTime Monotonic
  liftIO $ logIO Debug "Loading initial data container"

  -- construct game data object from provided Affectionate instance
  (gameDataKey, gameData) <-
    allocate
      (liftIO $ loadState @us)
      (liftIO . cleanUp)
  -- build state container
  let initContainer = AffectionData
        { drawWindows     = windows
        , glContext       = contexts
        , elapsedTime     = 0
        , deltaTime       = 0
        , sysTime         = execTime
        , pausedTime      = False
        }

  -- initialize and run state
  void $ liftIO $ runAffection initContainer
      (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 . awWindow) windows

            -- save new time
            ad3 <- get
            when (sysTime ad == sysTime ad3) (
              put ad3
                { sysTime = now
                }
              )
            )
        )
  -- Cleanup works
  liftIO $ logIO Debug "Loop ended. Cleaning"
  release gameDataKey
  -- 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"

runAffection
  :: AffectionData
  -> AffectionState AffectionData ResIO a
  -> IO (a, AffectionData)
runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState