introduce resourcet

This commit is contained in:
nek0 2022-07-10 04:18:22 +02:00
parent 60d38217c8
commit 1b8d754cd6
5 changed files with 133 additions and 75 deletions

View file

@ -117,6 +117,7 @@ library
, stm , stm
, uuid , uuid
, vector , vector
, resourcet
-- This example shows the message system. only makes sense when compiling with -- This example shows the message system. only makes sense when compiling with
-- verbose flag. -- verbose flag.

View file

@ -1,4 +1,4 @@
constraints: affection +verbose constraints: affection +verbose +examples
profiling: true profiling: true
packages: packages:
./. ./.

View file

@ -1,6 +1,5 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-} {-# LANGUAGE Strict #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
@ -30,6 +29,7 @@ import System.Clock
import Control.Monad.Loops import Control.Monad.Loops
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
-- internal imports -- internal imports
@ -47,47 +47,83 @@ withAffection
:: forall us. (Affectionate us) :: forall us. (Affectionate us)
=> AffectionConfig us -- ^ Configuration of the Game and its engine. => AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO () -> IO ()
withAffection AffectionConfig{..} = do withAffection AffectionConfig{..} = runResourceT $ do
liftIO $ logIO Debug "Affection starting" liftIO $ logIO Debug "Affection starting"
liftIO $ logIO Debug "Initializing SDL" liftIO $ logIO Debug "Initializing SDL"
-- intialiaze SDL -- intialiaze SDL
case initComponents of case initComponents of
All -> All ->
SDL.initializeAll SDL.initializeAll
Only is -> Only is ->
SDL.initialize is SDL.initialize is
-- give SDL render quality -- give SDL render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- just checking… -- just checking…
do renderQuality <- SDL.get SDL.HintRenderScaleQuality
renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $
when (renderQuality /= SDL.ScaleLinear) $ liftIO $ logIO Warn "Linear texture filtering not enabled!"
logIO Warn "Linear texture filtering not enabled!"
void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer))) void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
-- construct window -- construct window
liftIO $ logIO Debug "Creating Window(s)" liftIO $ logIO Debug "Creating Window(s)"
windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$> windows <-
mapM mapM
(SDL.createWindow windowTitle . (\(_,y,_) -> y)) (\(_, sdlWindowConfig, mode) -> do
windowConfigs <*> (windowKey, window) <-
pure (map (\(_,_,z) -> z) windowConfigs) 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 -- sync updates with monitor
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
liftIO $ logIO Debug "Getting Time"
-- print current used GL Version -- print current used GL Version
version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
print (B.pack version) liftIO $ print (B.pack version)
-- get current time -- get current time
execTime <- getTime Monotonic liftIO $ logIO Debug "Getting Time"
execTime <- liftIO $ getTime Monotonic
liftIO $ logIO Debug "Loading initial data container" liftIO $ logIO Debug "Loading initial data container"
-- construct game data object from provided Affectionate instance -- construct game data object from provided Affectionate instance
gameData <- loadState @us (gameDataKey, gameData) <-
allocate
(liftIO $ loadState @us)
(liftIO . cleanUp)
-- build state container -- build state container
let initContainer = AffectionData let initContainer = AffectionData
{ drawWindows = windows { drawWindows = windows
@ -97,11 +133,12 @@ withAffection AffectionConfig{..} = do
, sysTime = execTime , sysTime = execTime
, pausedTime = False , pausedTime = False
} }
-- initialize and run state -- initialize and run state
(_, _) <- runStateT void $ liftIO $ runAffection initContainer
(A.runState
(do (do
liftIO $ logIO Debug "Running Pre-Loop stage" liftIO $ logIO Debug "Running Pre-Loop stage"
-- run preLoop function from Affectionate -- run preLoop function from Affectionate
preLoop gameData preLoop gameData
liftIO $ logIO Debug "Starting Loop" liftIO $ logIO Debug "Starting Loop"
@ -109,31 +146,40 @@ withAffection AffectionConfig{..} = do
(do (do
-- get state -- get state
ad <- get ad <- get
-- Measure time difference form last run -- Measure time difference form last run
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic
let lastTime = sysTime ad let lastTime = sysTime ad
-- compute dt and update elapsedTime -- compute dt and update elapsedTime
let dt = fromIntegral let dt = fromIntegral
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
ne = elapsedTime ad + dt ne = elapsedTime ad + dt
-- update state data object with new time values -- update state data object with new time values
put $ ad put $ ad
{ elapsedTime = ne { elapsedTime = ne
, deltaTime = dt , deltaTime = dt
} }
-- poll events -- poll events
liftIO SDL.pumpEvents liftIO SDL.pumpEvents
evs <- preHandleEvents =<< liftIO SDL.pollEvents evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- handle events -- handle events
handleEvents gameData evs handleEvents gameData evs
-- execute user defined update loop -- execute user defined update loop
unless (pausedTime ad) (update gameData dt) unless (pausedTime ad) (update gameData dt)
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
draw gameData draw gameData
liftIO GL.flush liftIO GL.flush
-- actual displaying of newly drawn frame -- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows mapM_ (SDL.glSwapWindow . awWindow) windows
-- save new time -- save new time
ad3 <- get ad3 <- get
when (sysTime ad == sysTime ad3) ( when (sysTime ad == sysTime ad3) (
@ -143,11 +189,16 @@ withAffection AffectionConfig{..} = do
) )
) )
) )
) initContainer -- Cleanup works
liftIO $ logIO Debug "Loop ended. Cleaning" liftIO $ logIO Debug "Loop ended. Cleaning"
cleanUp gameData release gameDataKey
liftIO $ logIO Debug "Destroying Window" -- mapM_ (SDL.glDeleteContext . snd) contexts
mapM_ (SDL.glDeleteContext . snd) contexts -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
-- SDL.quit -- <- This causes segfaults depending on hardware -- SDL.quit -- <- This causes segfaults depending on hardware
liftIO $ logIO Debug "This is the end" 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

View file

@ -5,6 +5,8 @@ module Affection.Types
, AffectionData(..) , AffectionData(..)
, AffectionStateInner , AffectionStateInner
, AffectionState(..) , AffectionState(..)
, AffectionWindow(..)
, AffectionContext(..)
, InitComponents(..) , InitComponents(..)
, Angle , Angle
-- | SDL reexports -- | SDL reexports
@ -23,6 +25,7 @@ import qualified Data.Text as T
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
import qualified Control.Monad.Parallel as MP import qualified Control.Monad.Parallel as MP
import System.Clock (TimeSpec) import System.Clock (TimeSpec)
@ -50,35 +53,35 @@ data InitComponents
-- | Main type for defining the look, feel and action of the whole application. -- | Main type for defining the look, feel and action of the whole application.
data AffectionData = AffectionData data AffectionData = AffectionData
{ drawWindows :: { drawWindows :: [ AffectionWindow ] -- ^ SDL windows
[ , glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts
( Word -- --^ Window identifier , elapsedTime :: Double -- ^ Elapsed time in seconds
, SDL.Window -- --^ Window linked with identifier , deltaTime :: Double -- ^ Elapsed time in seconds since last tick
, SDL.WindowMode -- -- ^ current screen mode , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
) , pausedTime :: Bool -- ^ Should the update loop be executed?
] -- ^ 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?
} }
-- | Inner 'StateT' monad for the update state -- | 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 -- | Affection's state monad
newtype AffectionState sd m a = AffectionState newtype AffectionState sd m a = AffectionState
{ runState :: AffectionStateInner sd m a } { 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) 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 type Angle = Double
data AffectionWindow = AffectionWindow
{ awWindow :: SDL.Window
, awReleaseKey :: ReleaseKey
, awMode :: SDL.WindowMode
}
data AffectionContext = AffectionContext
{ acContext :: SDL.GLContext
, acReleaseKey :: ReleaseKey
}

View file

@ -39,32 +39,35 @@ getDelta = gets deltaTime
toggleScreen :: Word -> Affection () toggleScreen :: Word -> Affection ()
toggleScreen windowIdent = do toggleScreen windowIdent = do
ad <- get ad <- get
let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad) (stop, alteredWindowList) <- foldM
case mwindow of (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
Just (ident, window, mode) -> do if stop || num == windowIdent
newMode <- case mode of then do
SDL.FullscreenDesktop -> do newMode <- case mode of
SDL.setWindowMode window SDL.Windowed SDL.FullscreenDesktop -> do
return SDL.Windowed liftIO $ SDL.setWindowMode window SDL.Windowed
SDL.Windowed -> do return SDL.Windowed
SDL.setWindowMode window SDL.FullscreenDesktop SDL.Windowed -> do
return SDL.FullscreenDesktop liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
x -> do return SDL.FullscreenDesktop
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) x -> do
return x liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
now <- liftIO $ getTime Monotonic return x
put ad return (True, resWindows ++ [aw { awMode = newMode }])
{ sysTime = now else
, drawWindows = map return (stop, resWindows ++ [aw])
(\e@(lid, win, _) -> )
if lid == ident (False, [])
then (lid, win, newMode) (zip [0..] (drawWindows ad))
else e if stop
) then do
(drawWindows ad) now <- liftIO $ getTime Monotonic
} put ad
Nothing -> do { sysTime = now
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent)) , drawWindows = alteredWindowList
}
else
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
-- | Fit the GL Viewport to Window size -- | Fit the GL Viewport to Window size
fitViewport fitViewport