{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} module Affection ( withAffection , getAffection , putAffection -- , withWindow -- , withDefaultWindow , delaySec , module A ) where 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 qualified Control.Monad.Parallel as MP 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.Misc as A 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 -- 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) = 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 execTime <- getTime Monotonic initContainer <- (\x -> AffectionData { quitEvent = False , userState = x , drawWindow = window , windowRenderer = renderer , drawTexture = texture , drawFormat = format , drawDimensions = case canvasSize of Just (cw, ch) -> (cw, ch) Nothing -> (w, h) , 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 drawLoop -- handle all new draw requests ad2 <- get clear <- catMaybes <$> MP.mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2) -- save all draw requests to clear in next run put $ ad2 { drawStack = clear } -- actual drawing 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