pituicat/src/Affection.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
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 Control.Monad.IO.Class (liftIO)

import Foreign.C.Types (CInt(..))

import Debug.Trace

import Affection.Types as A
import Affection.StateMachine as A
import Affection.MouseInteractable 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
  :: 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"
  window <- SDL.createWindow windowTitle windowConfig
  SDL.showWindow window
  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
  context <- SDL.glCreateContext window
  let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
      (w, h) = case canvasSize of
        Just (cw, ch) -> (cw, ch)
        Nothing       -> (fromIntegral rw, fromIntegral rh)
  SDL.setWindowMode window initScreenMode
  -- 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"
  initContainer <- (\x -> AffectionData
    { quitEvent       = False
    , userState       = x
    , drawWindow      = window
    , glContext       = context
    , drawDimensions  = case canvasSize of
        Just (cw, ch) -> (cw, ch)
        Nothing       -> (w, h)
    , screenMode      = initScreenMode
    , elapsedTime     = 0
    , deltaTime       = 0
    , sysTime         = execTime
    , pausedTime      = False
    }) <$> loadState
  (_, nState) <- runStateT ( A.runState $ do
    liftIO $ logIO Debug "Starting Loop"
    preLoop
    whileM_ (do
        current <- get
        return $ not $ A.quitEvent current
      )
      (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
        put $ ad
          { elapsedTime = ne
          , deltaTime = dt
          }
        -- poll events
        evs <- preHandleEvents =<< liftIO SDL.pollEvents
        -- handle events
        eventLoop evs
        -- execute user defined update loop
        unless (pausedTime ad) (updateLoop dt)
        -- execute user defined draw loop
        liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
        drawLoop
        liftIO GL.flush
        -- actual displaying of newly drawn frame
        SDL.glSwapWindow window
        -- save new time
        ad3 <- get
        when (sysTime ad == sysTime ad3) (
          put ad3
            { sysTime = now
            }
          )
      )
    ) initContainer
  liftIO $ logIO Debug "Loop ended. Cleaning"
  cleanUp $ userState nState
  liftIO $ logIO Debug "Destroying Window"
  SDL.glDeleteContext context
  SDL.destroyWindow window
  -- SDL.quit -- <- This causes segfaults depending on hardware
  liftIO $ logIO Debug "This is the end"