affection/src/Affection.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
module Affection
    ( withAffection
    , get
    , getAffection
    , putAffection
    -- , withWindow
    -- , withDefaultWindow
    , delaySec
    , get
    , put
    , module A
    ) where

import SDL (($=))
import qualified SDL
import qualified SDL.Internal.Numbered as SDL (toNumber)
import qualified SDL.Raw as Raw
-- import qualified GEGL as G

import Data.Maybe
import Data.IORef

import System.Clock

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

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

import Debug.Trace

import Affection.Types as A
-- import Affection.Draw as A
-- import Affection.Particle as A
import Affection.StateMachine as A
import Affection.MouseInteractable as A
-- import Affection.Property as A
-- import Affection.Actor as A
-- import Affection.Animation as A
import Affection.Util as A
import Affection.MessageBus.Class as A
import Affection.MessageBus.Message as A
import Affection.MessageBus.Engine as A
import Affection.MessageBus.Util as A

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

-- import qualified BABL as B

-- | Main function which bootstraps everything else.
withAffection
  :: AffectionConfig us -- ^ Configuration of the Game and its engine.
  -> IO ()
withAffection AffectionConfig{..} = do
  -- intialiaze SDL
  case initComponents of
    All ->
      SDL.initializeAll
    Only is ->
      SDL.initialize is
  -- G.gegl_init
  -- give SDL render quality
  SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
  -- just checking…
  do
    renderQuality <- SDL.get SDL.HintRenderScaleQuality
    when (renderQuality /= SDL.ScaleLinear) $
      putStrLn "Warning: Linear texture filtering not enabled!"
  -- construct window
  window <- SDL.createWindow windowTitle windowConfig
  SDL.showWindow window
  context <- SDL.glCreateContext(window)
  -- -- create renderer
  -- renderer <- SDL.createRenderer
  --   window
  --   (-1)
  --   SDL.defaultRenderer
  -- -- make draw texture
  -- texture <- SDL.createTexture
  --   renderer
  --   SDL.ABGR8888
  --   SDL.TextureAccessStreaming
  --   (case canvasSize of
  --     Just (cw, ch) -> (SDL.V2
  --       (CInt $ fromIntegral cw)
  --       (CInt $ fromIntegral ch)
  --       )
  --     Nothing ->
  --       SDL.windowInitialSize windowConfig
  --     )
  -- -- make draw surface
  -- -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr
  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)
  --     -- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
  --     bablFormat = B.PixelFormat B.RGBA B.CFu8
  --     cpp        = B.babl_components_per_pixel bablFormat
  --     !stride    = cpp * w
  -- format <- B.babl_format bablFormat
  -- get current time
  SDL.setWindowMode window initScreenMode
  SDL.swapInterval $= SDL.SynchronizedUpdates
  execTime <- getTime Monotonic
  initContainer <- (\x -> AffectionData
    { quitEvent       = False
    , userState       = x
    , drawWindow      = window
    , glContext       = context
    -- , windowRenderer  = renderer
    -- , drawTexture     = texture
    -- , drawFormat      = format
    , drawDimensions  = case canvasSize of
        Just (cw, ch) -> (cw, ch)
        Nothing       -> (w, h)
    , screenMode      = initScreenMode
    -- , drawStride      = stride
    -- , drawCPP         = cpp
    -- , drawStack       = []
    , elapsedTime     = 0
    , deltaTime       = 0
    , sysTime         = execTime
    , pausedTime      = False
    }) <$> loadState
  (_, nState) <- runStateT ( A.runState $ do
    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
        -- -- clean draw requests from last run
        -- MP.mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad)
        -- clean the renderer form last time
        -- SDL.clear renderer
        -- compute dt and update elapsedTime
        let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9)
            !ne = elapsedTime ad + dt
        put $ ad
          -- { drawStack = []
          { elapsedTime = ne
          , deltaTime = dt
          }
        -- poll events
        evs <- preHandleEvents =<< liftIO SDL.pollEvents
        mapM_ eventLoop evs
        -- execute user defined update loop
        unless (pausedTime ad) (updateLoop dt)
        -- execute user defined draw loop
        liftIO $ GL.clear [ColorBuffer, DepthBuffer]
        drawLoop
        liftIO $ flush
        -- handle all new draw requests
        ad2 <- get
        -- clear <- catMaybes <$>
        --   mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2)
        -- -- save all draw requests to clear in next run
        -- put $ ad2
        --   { drawStack = clear }
        -- actual drawing
        SDL.glSwapWindow window
        -- SDL.present (windowRenderer ad2)
        -- save new time
        ad3 <- get
        when (sysTime ad == sysTime ad3) (
          put ad3
            { sysTime = now
            }
          )
      )
    ) initContainer
  -- G.gegl_exit
  cleanUp $ userState nState
  SDL.destroyWindow window
  SDL.quit