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 BangPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Affection
( withAffection
, get
@ -22,6 +25,7 @@ import Control.Monad.IO.Class (liftIO)
import Foreign.C.Types (CInt(..))
import Affection.Types as A
import Affection.Class as A
import Affection.StateMachine as A
import Affection.Util 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.
withAffection
:: AffectionConfig us -- ^ Configuration of the Game and its engine.
:: (Affectionate us)
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO ()
withAffection AffectionConfig{..} = do
liftIO $ logIO Debug "Affection starting"
@ -54,38 +59,39 @@ withAffection AffectionConfig{..} = do
logIO Warn "Linear texture filtering not enabled!"
-- construct window
liftIO $ logIO Debug "Creating Window(s)"
windows <- zip (map fst windowConfigs) <$>
windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
mapM
(\wc -> SDL.createWindow windowTitle (snd wc))
windowConfigs
mapM_ (SDL.showWindow . snd) windows
(\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
windowConfigs <*>
pure (map (\(_,_,z) -> z) windowConfigs)
mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
_ <- 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
-- (w, h) = case canvasSize of
-- Just (cw, ch) -> (cw, ch)
-- 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
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
, drawWindows = windows
, glContext = contexts
, screenMode = initScreenMode
, elapsedTime = 0
, deltaTime = 0
, sysTime = execTime
, pausedTime = False
}) <$> loadState
gameData <- loadState :: forall us. IO (Data us)
let initContainer = AffectionData
{ drawWindows = windows
, glContext = contexts
, elapsedTime = 0
, deltaTime = 0
, sysTime = execTime
, pausedTime = False
}
(_, nState) <- runStateT ( A.runState $ do
liftIO $ logIO Debug "Starting Loop"
preLoop
whileM_ (not . A.quitEvent <$> get)
preLoop gameData
whileM_ (hasNextStep gameData)
(do
-- get state
ad <- get
@ -103,15 +109,15 @@ withAffection AffectionConfig{..} = do
-- poll events
evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- handle events
eventLoop evs
handleEvents gameData evs
-- execute user defined update loop
unless (pausedTime ad) (updateLoop dt)
unless (pausedTime ad) (update gameData dt)
-- execute user defined draw loop
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
drawLoop
draw gameData
liftIO GL.flush
-- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . snd) windows
mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
-- save new time
ad3 <- get
when (sysTime ad == sysTime ad3) (
@ -122,9 +128,9 @@ withAffection AffectionConfig{..} = do
)
) initContainer
liftIO $ logIO Debug "Loop ended. Cleaning"
cleanUp $ userState nState
cleanUp gameData
liftIO $ logIO Debug "Destroying Window"
mapM_ (SDL.glDeleteContext . snd) contexts
mapM_ (SDL.destroyWindow . snd) windows
mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
-- SDL.quit -- <- This causes segfaults depending on hardware
liftIO $ logIO Debug "This is the end"

View File

@ -35,27 +35,12 @@ data AffectionConfig us = AffectionConfig
-- ^ Window title
, windowConfigs ::
[
( Word -- ^ Window identifier
, SDL.WindowConfig -- ^ Window config for given window
( Word -- --^ Window identifier
, SDL.WindowConfig -- --^ Window config for given window
, SDL.WindowMode -- -- ^ Window mode to start in
)
]
-- ^ 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.
@ -65,18 +50,17 @@ data InitComponents
-- | Main type for defining the look, feel and action of the whole application.
data AffectionData us = AffectionData
{ quitEvent :: Bool -- ^ Loop breaker.
, userState :: us -- ^ State data provided by user
, drawWindows ::
{ drawWindows ::
[
( Word -- ^ Window identifier
, SDL.Window -- ^ Window linked with identifier
( 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
( Word -- --^ Window identifier
, SDL.GLContext -- --^ Associated OpenGL context
)
] -- ^ OpenGL rendering contexts
, screenMode :: SDL.WindowMode -- ^ current screen mode
@ -87,14 +71,14 @@ data AffectionData us = AffectionData
}
-- | 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
newtype AffectionState us m a = AffectionState
{ runState :: AffectionStateInner us m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState us)
newtype AffectionState sd m a = AffectionState
{ runState :: AffectionStateInner sd m a }
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

View File

@ -19,19 +19,6 @@ preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
preHandleEvents 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
delaySec
:: Int -- ^ Number of seconds
@ -46,12 +33,6 @@ getElapsedTime = gets elapsedTime
getDelta :: Affection us Double
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'.
-- Pauses the Engine in the process.
toggleScreen :: Affection us ()
@ -59,10 +40,10 @@ toggleScreen = do
ad <- get
newMode <- case screenMode ad of
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
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
x -> do
liftIO $ logIO Warn ("Unexpected Screen mode: " <> fromString (show x))