diff --git a/affection.cabal b/affection.cabal index 1cec0ee..c5772cf 100644 --- a/affection.cabal +++ b/affection.cabal @@ -117,6 +117,7 @@ library , stm , uuid , vector + , resourcet -- This example shows the message system. only makes sense when compiling with -- verbose flag. diff --git a/cabal.project b/cabal.project index aac861d..7659ea4 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -constraints: affection +verbose +constraints: affection +verbose +examples profiling: true packages: ./. diff --git a/src/Affection.hs b/src/Affection.hs index 4a62193..e99f1e9 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} @@ -30,6 +29,7 @@ import System.Clock import Control.Monad.Loops import Control.Monad.State.Strict +import Control.Monad.Trans.Resource -- internal imports @@ -47,47 +47,83 @@ withAffection :: forall us. (Affectionate us) => AffectionConfig us -- ^ Configuration of the Game and its engine. -> IO () -withAffection AffectionConfig{..} = do +withAffection AffectionConfig{..} = runResourceT $ 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!" + renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + liftIO $ logIO Warn "Linear texture filtering not enabled!" void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer))) + -- construct window liftIO $ logIO Debug "Creating Window(s)" - windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$> + windows <- mapM - (SDL.createWindow windowTitle . (\(_,y,_) -> y)) - windowConfigs <*> - pure (map (\(_,_,z) -> z) windowConfigs) + (\(_, sdlWindowConfig, mode) -> do + (windowKey, window) <- + allocate + (SDL.createWindow windowTitle sdlWindowConfig) + (\window -> do + logIO Debug "Destroying Window" + SDL.destroyWindow window + ) + return $ AffectionWindow window windowKey mode + ) + windowConfigs + + -- Show windows + mapM_ (SDL.showWindow . awWindow) windows + + -- set modes of windows + mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows + + -- Make GL context shareable + void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 + + -- Create OpenGL contexts + contexts <- + mapM + (\(AffectionWindow window _ _) -> do + (contextKey, context) <- + allocate + (SDL.glCreateContext window) + (\context -> do + logIO Debug "Destroying context" + SDL.glDeleteContext context + ) + return $ AffectionContext context contextKey + ) + windows - 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 - mapM_ (\w -> SDL.setWindowMode ((\(_,y,_) -> y) w) ((\(_,_,z) -> z) w)) windows -- sync updates with monitor -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows - liftIO $ logIO Debug "Getting Time" + -- print current used GL Version - version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION - print (B.pack version) + version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION + liftIO $ print (B.pack version) + -- get current time - execTime <- getTime Monotonic + liftIO $ logIO Debug "Getting Time" + execTime <- liftIO $ getTime Monotonic liftIO $ logIO Debug "Loading initial data container" + -- construct game data object from provided Affectionate instance - gameData <- loadState @us + (gameDataKey, gameData) <- + allocate + (liftIO $ loadState @us) + (liftIO . cleanUp) -- build state container let initContainer = AffectionData { drawWindows = windows @@ -97,11 +133,12 @@ withAffection AffectionConfig{..} = do , sysTime = execTime , pausedTime = False } + -- initialize and run state - (_, _) <- runStateT - (A.runState + void $ liftIO $ runAffection initContainer (do liftIO $ logIO Debug "Running Pre-Loop stage" + -- run preLoop function from Affectionate preLoop gameData liftIO $ logIO Debug "Starting Loop" @@ -109,31 +146,40 @@ withAffection AffectionConfig{..} = do (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 liftIO SDL.pumpEvents 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 + mapM_ (SDL.glSwapWindow . awWindow) windows + -- save new time ad3 <- get when (sysTime ad == sysTime ad3) ( @@ -143,11 +189,16 @@ withAffection AffectionConfig{..} = do ) ) ) - ) initContainer + -- Cleanup works liftIO $ logIO Debug "Loop ended. Cleaning" - cleanUp gameData - liftIO $ logIO Debug "Destroying Window" - mapM_ (SDL.glDeleteContext . snd) contexts - mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows + release gameDataKey + -- 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" + +runAffection + :: AffectionData + -> AffectionState AffectionData ResIO a + -> IO (a, AffectionData) +runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index a7d8eb4..e4fd82a 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -5,6 +5,8 @@ module Affection.Types , AffectionData(..) , AffectionStateInner , AffectionState(..) + , AffectionWindow(..) + , AffectionContext(..) , InitComponents(..) , Angle -- | SDL reexports @@ -23,6 +25,7 @@ import qualified Data.Text as T import Control.Monad.IO.Class import Control.Monad.State.Strict +import Control.Monad.Trans.Resource import qualified Control.Monad.Parallel as MP import System.Clock (TimeSpec) @@ -50,35 +53,35 @@ data InitComponents -- | Main type for defining the look, feel and action of the whole application. data AffectionData = AffectionData - { drawWindows :: - [ - ( Word -- --^ Window identifier - , SDL.Window -- --^ Window linked with identifier - , SDL.WindowMode -- -- ^ current screen mode - ) - ] -- ^ SDL windows - , glContext :: - [ - ( Word -- --^ Window identifier - , SDL.GLContext -- --^ Associated OpenGL context - ) - ] -- ^ OpenGL rendering contexts - , elapsedTime :: Double -- ^ Elapsed time in seconds - , deltaTime :: Double -- ^ Elapsed time in seconds since last tick - , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) - , pausedTime :: Bool -- ^ Should the update loop be executed? + { drawWindows :: [ AffectionWindow ] -- ^ SDL windows + , glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts + , elapsedTime :: Double -- ^ Elapsed time in seconds + , deltaTime :: Double -- ^ Elapsed time in seconds since last tick + , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) + , pausedTime :: Bool -- ^ Should the update loop be executed? } -- | Inner 'StateT' monad for the update state -type AffectionStateInner sd a = StateT sd a +type AffectionStateInner sd m = StateT sd m -- | Affection's state monad newtype AffectionState sd m a = AffectionState { runState :: AffectionStateInner sd m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadState sd) + deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource) instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m) -type Affection a = AffectionState AffectionData IO a +type Affection a = AffectionState AffectionData ResIO a type Angle = Double + +data AffectionWindow = AffectionWindow + { awWindow :: SDL.Window + , awReleaseKey :: ReleaseKey + , awMode :: SDL.WindowMode + } + +data AffectionContext = AffectionContext + { acContext :: SDL.GLContext + , acReleaseKey :: ReleaseKey + } diff --git a/src/Affection/Util.hs b/src/Affection/Util.hs index 763f0ee..465620c 100644 --- a/src/Affection/Util.hs +++ b/src/Affection/Util.hs @@ -39,32 +39,35 @@ getDelta = gets deltaTime toggleScreen :: Word -> Affection () toggleScreen windowIdent = do ad <- get - let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad) - case mwindow of - Just (ident, window, mode) -> do - newMode <- case mode of - SDL.FullscreenDesktop -> do - SDL.setWindowMode window SDL.Windowed - return SDL.Windowed - SDL.Windowed -> do - SDL.setWindowMode window SDL.FullscreenDesktop - return SDL.FullscreenDesktop - x -> do - liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) - return x - now <- liftIO $ getTime Monotonic - put ad - { sysTime = now - , drawWindows = map - (\e@(lid, win, _) -> - if lid == ident - then (lid, win, newMode) - else e - ) - (drawWindows ad) - } - Nothing -> do - liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent)) + (stop, alteredWindowList) <- foldM + (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do + if stop || num == windowIdent + then do + newMode <- case mode of + SDL.FullscreenDesktop -> do + liftIO $ SDL.setWindowMode window SDL.Windowed + return SDL.Windowed + SDL.Windowed -> do + liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop + return SDL.FullscreenDesktop + x -> do + liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) + return x + return (True, resWindows ++ [aw { awMode = newMode }]) + else + return (stop, resWindows ++ [aw]) + ) + (False, []) + (zip [0..] (drawWindows ad)) + if stop + then do + now <- liftIO $ getTime Monotonic + put ad + { sysTime = now + , drawWindows = alteredWindowList + } + else + liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent)) -- | Fit the GL Viewport to Window size fitViewport