{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} module Affection ( withAffection , get , put , liftIO , module A ) where import SDL (($=)) import qualified 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 -- renderer <- SDL.createRenderer -- window (-1) -- SDL.defaultRenderer -- { SDL.rendererTargetTexture = True -- } -- surface <- SDL.createRGBSurface -- (case canvasSize of -- Just (cw, ch) -> SDL.V2 -- (CInt $ fromIntegral cw) -- (CInt $ fromIntegral ch) -- Nothing -> -- SDL.windowInitialSize windowConfig -- ) -- SDL.RGBA8888 -- texture <- SDL.createTexture -- renderer -- SDL.RGBA8888 -- SDL.TextureAccessTarget -- (case canvasSize of -- Just (cw, ch) -> SDL.V2 -- (CInt $ fromIntegral cw) -- (CInt $ fromIntegral ch) -- Nothing -> -- SDL.windowInitialSize windowConfig -- ) -- SDL.rendererRenderTarget renderer $= Just texture 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 -- mapM_ eventLoop evs 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 -- handle all new draw requests ad2 <- get -- actual drawing SDL.glSwapWindow window -- SDL.copy renderer texture Nothing Nothing -- SDL.present renderer -- 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.destroyWindow window SDL.quit liftIO $ logIO Debug "This is the end"