start with Affectionate

This commit is contained in:
nek0 2020-05-04 01:36:12 +02:00
parent 65d47f7477
commit 13f67c6cd1
3 changed files with 48 additions and 77 deletions

View file

@ -1,5 +1,8 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Affection module Affection
( withAffection ( withAffection
, get , get
@ -22,6 +25,7 @@ import Control.Monad.IO.Class (liftIO)
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
import Affection.Types as A import Affection.Types as A
import Affection.Class as A
import Affection.StateMachine as A import Affection.StateMachine as A
import Affection.Util as A import Affection.Util as A
import Affection.MessageBus as A import Affection.MessageBus as A
@ -34,7 +38,8 @@ import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- | Main function which bootstraps everything else. -- | Main function which bootstraps everything else.
withAffection withAffection
:: AffectionConfig us -- ^ Configuration of the Game and its engine. :: (Affectionate us)
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO () -> IO ()
withAffection AffectionConfig{..} = do withAffection AffectionConfig{..} = do
liftIO $ logIO Debug "Affection starting" liftIO $ logIO Debug "Affection starting"
@ -54,38 +59,39 @@ withAffection AffectionConfig{..} = do
logIO Warn "Linear texture filtering not enabled!" logIO Warn "Linear texture filtering not enabled!"
-- construct window -- construct window
liftIO $ logIO Debug "Creating Window(s)" liftIO $ logIO Debug "Creating Window(s)"
windows <- zip (map fst windowConfigs) <$> windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
mapM mapM
(\wc -> SDL.createWindow windowTitle (snd wc)) (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
windowConfigs windowConfigs <*>
mapM_ (SDL.showWindow . snd) windows pure (map (\(_,_,z) -> z) windowConfigs)
mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
_ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
contexts <- zip (map fst windows) <$> mapM (SDL.glCreateContext . snd) windows contexts <- zip (map (\(x,_,_) -> x) windows) <$>
mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
-- let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfigs -- let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfigs
-- (w, h) = case canvasSize of -- (w, h) = case canvasSize of
-- Just (cw, ch) -> (cw, ch) -- Just (cw, ch) -> (cw, ch)
-- Nothing -> (fromIntegral rw, fromIntegral rh) -- Nothing -> (fromIntegral rw, fromIntegral rh)
mapM_ (flip SDL.setWindowMode initScreenMode . snd) windows mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
liftIO $ logIO Debug "Getting Time" liftIO $ logIO Debug "Getting Time"
-- get current time -- get current time
execTime <- getTime Monotonic execTime <- getTime Monotonic
liftIO $ logIO Debug "Loading initial data container" liftIO $ logIO Debug "Loading initial data container"
initContainer <- (\x -> AffectionData gameData <- loadState :: forall us. IO (Data us)
{ quitEvent = False let initContainer = AffectionData
, userState = x { drawWindows = windows
, drawWindows = windows , glContext = contexts
, glContext = contexts , elapsedTime = 0
, screenMode = initScreenMode , deltaTime = 0
, elapsedTime = 0 , sysTime = execTime
, deltaTime = 0 , pausedTime = False
, sysTime = execTime }
, pausedTime = False
}) <$> loadState
(_, nState) <- runStateT ( A.runState $ do (_, nState) <- runStateT ( A.runState $ do
liftIO $ logIO Debug "Starting Loop" liftIO $ logIO Debug "Starting Loop"
preLoop preLoop gameData
whileM_ (not . A.quitEvent <$> get) whileM_ (hasNextStep gameData)
(do (do
-- get state -- get state
ad <- get ad <- get
@ -103,15 +109,15 @@ withAffection AffectionConfig{..} = do
-- poll events -- poll events
evs <- preHandleEvents =<< liftIO SDL.pollEvents evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- handle events -- handle events
eventLoop evs handleEvents gameData evs
-- execute user defined update loop -- execute user defined update loop
unless (pausedTime ad) (updateLoop dt) unless (pausedTime ad) (update gameData dt)
-- execute user defined draw loop -- execute user defined draw loop
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
drawLoop draw gameData
liftIO GL.flush liftIO GL.flush
-- actual displaying of newly drawn frame -- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . snd) windows mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
-- save new time -- save new time
ad3 <- get ad3 <- get
when (sysTime ad == sysTime ad3) ( when (sysTime ad == sysTime ad3) (
@ -122,9 +128,9 @@ withAffection AffectionConfig{..} = do
) )
) initContainer ) initContainer
liftIO $ logIO Debug "Loop ended. Cleaning" liftIO $ logIO Debug "Loop ended. Cleaning"
cleanUp $ userState nState cleanUp gameData
liftIO $ logIO Debug "Destroying Window" liftIO $ logIO Debug "Destroying Window"
mapM_ (SDL.glDeleteContext . snd) contexts mapM_ (SDL.glDeleteContext . snd) contexts
mapM_ (SDL.destroyWindow . snd) 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"

View file

@ -35,27 +35,12 @@ data AffectionConfig us = AffectionConfig
-- ^ Window title -- ^ Window title
, windowConfigs :: , windowConfigs ::
[ [
( Word -- ^ Window identifier ( Word -- --^ Window identifier
, SDL.WindowConfig -- ^ Window config for given window , SDL.WindowConfig -- --^ Window config for given window
, SDL.WindowMode -- -- ^ Window mode to start in
) )
] ]
-- ^ Window configurations -- ^ Window configurations
, canvasSize :: Maybe (Int, Int)
-- ^ size of the texture canvas
, initScreenMode :: SDL.WindowMode
-- ^ Window mode to start in
, loadState :: IO us
-- ^ Provide your own load function to create this data.
, preLoop :: Affection us ()
-- ^ Actions to be performed, before loop starts
, eventLoop :: [SDL.EventPayload] -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, updateLoop :: Double -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, drawLoop :: Affection us ()
-- ^ Function for updating graphics.
, cleanUp :: us -> IO ()
-- ^ Provide your own finisher function to clean your data.
} }
-- | Components to initialize in SDL. -- | Components to initialize in SDL.
@ -65,18 +50,17 @@ 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 us = AffectionData data AffectionData us = AffectionData
{ quitEvent :: Bool -- ^ Loop breaker. { drawWindows ::
, userState :: us -- ^ State data provided by user
, drawWindows ::
[ [
( Word -- ^ Window identifier ( Word -- --^ Window identifier
, SDL.Window -- ^ Window linked with identifier , SDL.Window -- --^ Window linked with identifier
, SDL.WindowMode -- -- ^ current screen mode
) )
] -- ^ SDL windows ] -- ^ SDL windows
, glContext :: , glContext ::
[ [
( Word -- ^ Window identifier ( Word -- --^ Window identifier
, SDL.GLContext -- ^ Associated OpenGL context , SDL.GLContext -- --^ Associated OpenGL context
) )
] -- ^ OpenGL rendering contexts ] -- ^ OpenGL rendering contexts
, screenMode :: SDL.WindowMode -- ^ current screen mode , screenMode :: SDL.WindowMode -- ^ current screen mode
@ -87,14 +71,14 @@ data AffectionData us = AffectionData
} }
-- | Inner 'StateT' monad for the update state -- | Inner 'StateT' monad for the update state
type AffectionStateInner us a = StateT us a type AffectionStateInner sd a = StateT sd a
-- | Affection's state monad -- | Affection's state monad
newtype AffectionState us m a = AffectionState newtype AffectionState sd m a = AffectionState
{ runState :: AffectionStateInner us m a } { runState :: AffectionStateInner sd m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState us) deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m) instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
type Affection us a = AffectionState (AffectionData us) IO a type Affection us a = AffectionState (AffectionData us) IO a

View file

@ -19,19 +19,6 @@ preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
preHandleEvents evs = preHandleEvents evs =
return $ map SDL.eventPayload evs return $ map SDL.eventPayload evs
-- | Return the userstate to the user
getAffection :: Affection us us
getAffection = gets userState
-- | Put altered user state back
putAffection
:: us -- User state
-> Affection us ()
putAffection us = do
ad <- get
put $ ad
{ userState = us }
-- | block a thread for a specified amount of time -- | block a thread for a specified amount of time
delaySec delaySec
:: Int -- ^ Number of seconds :: Int -- ^ Number of seconds
@ -46,12 +33,6 @@ getElapsedTime = gets elapsedTime
getDelta :: Affection us Double getDelta :: Affection us Double
getDelta = gets deltaTime getDelta = gets deltaTime
-- | Quit the engine loop
quit :: Affection us ()
quit = do
ad <- get
put $ ad { quitEvent = True }
-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'. -- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
-- Pauses the Engine in the process. -- Pauses the Engine in the process.
toggleScreen :: Affection us () toggleScreen :: Affection us ()
@ -59,10 +40,10 @@ toggleScreen = do
ad <- get ad <- get
newMode <- case screenMode ad of newMode <- case screenMode ad of
SDL.Windowed -> do SDL.Windowed -> do
mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) (drawWindows ad) mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . (\(_,y,_) -> y)) (drawWindows ad)
return SDL.FullscreenDesktop return SDL.FullscreenDesktop
SDL.FullscreenDesktop -> do SDL.FullscreenDesktop -> do
mapM_ (flip SDL.setWindowMode SDL.Windowed . snd) (drawWindows ad) mapM_ (flip SDL.setWindowMode SDL.Windowed . (\(_,y,_) -> y)) (drawWindows ad)
return SDL.Windowed return SDL.Windowed
x -> do x -> do
liftIO $ logIO Warn ("Unexpected Screen mode: " <> fromString (show x)) liftIO $ logIO Warn ("Unexpected Screen mode: " <> fromString (show x))