From 13f67c6cd107323ff286bbc73a835895f0b580f1 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 4 May 2020 01:36:12 +0200 Subject: [PATCH] start with Affectionate --- src/Affection.hs | 58 +++++++++++++++++++++++------------------- src/Affection/Types.hs | 44 ++++++++++---------------------- src/Affection/Util.hs | 23 ++--------------- 3 files changed, 48 insertions(+), 77 deletions(-) diff --git a/src/Affection.hs b/src/Affection.hs index 3d79aae..7ad556e 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -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" diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 9cc11e7..f883a3d 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -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 diff --git a/src/Affection/Util.hs b/src/Affection/Util.hs index dff005e..8fb64fa 100644 --- a/src/Affection/Util.hs +++ b/src/Affection/Util.hs @@ -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))