{-# 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