{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} 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 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 _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 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"