{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExplicitForAll #-} {-# 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 System.Clock import Control.Monad.Loops import Control.Monad.State.Strict import Control.Monad.IO.Class (liftIO) import Foreign.C.Types (CInt(..)) 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 import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) -- | Main function which bootstraps everything else. withAffection :: forall us. (Affectionate us) => 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(s)" windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$> mapM (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc)) windowConfigs <*> pure (map (\(_,_,z) -> z) windowConfigs) mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 contexts <- zip (map (\(x,_,_) -> x) windows) <$> mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows -- let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfigs -- (w, h) = case canvasSize of -- Just (cw, ch) -> (cw, ch) -- Nothing -> (fromIntegral rw, fromIntegral rh) mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows -- 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" -- construct game data object from provided Affectionate instance gameData <- loadState @us -- build state container let initContainer = AffectionData { drawWindows = windows , glContext = contexts , elapsedTime = 0 , deltaTime = 0 , sysTime = execTime , pausedTime = False } -- initialize and run state (_, nState) <- runStateT (A.runState (do liftIO $ logIO Debug "Starting Loop" -- run preLoop function from Affectionate preLoop gameData 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 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 . (\(_,y,_) -> y)) windows -- -- save new time -- ad3 <- get -- when (sysTime ad == sysTime ad3) ( -- put ad3 -- { sysTime = now -- } -- ) ) ) ) initContainer liftIO $ logIO Debug "Loop ended. Cleaning" cleanUp gameData liftIO $ logIO Debug "Destroying Window" 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"