From eeb342eeba16e01c40fabc84dc263df5918ab9fc Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 29 Jul 2017 21:45:40 +0200 Subject: [PATCH] relocating --- affection.cabal | 1 + examples/example05.hs | 1 + src/Affection.hs | 62 +-------------------------------------- src/Affection/Misc.hs | 66 ++++++++++++++++++++++++++++++++++++++++++ src/Affection/Types.hs | 3 ++ 5 files changed, 72 insertions(+), 61 deletions(-) create mode 100644 src/Affection/Misc.hs diff --git a/affection.cabal b/affection.cabal index 866123f..ccef510 100644 --- a/affection.cabal +++ b/affection.cabal @@ -44,6 +44,7 @@ library , Affection.Property , Affection.Actor , Affection.Animation + , Affection.Misc default-extensions: OverloadedStrings -- Modules included in this library but not exported. diff --git a/examples/example05.hs b/examples/example05.hs index e95f660..9985d73 100644 --- a/examples/example05.hs +++ b/examples/example05.hs @@ -38,6 +38,7 @@ main = do (CInt $ fromIntegral resolution) } , canvasSize = Nothing + , initScreenMode = SDL.Windowed , preLoop = loadList , eventLoop = handle , updateLoop = Main.update diff --git a/src/Affection.hs b/src/Affection.hs index d4c2c5d..1766e63 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -7,11 +7,6 @@ module Affection -- , withWindow -- , withDefaultWindow , delaySec - , get - , put - , getElapsedTime - , getDelta - , quit , module A ) where @@ -42,6 +37,7 @@ import Affection.MouseInteractable as A import Affection.Property as A import Affection.Actor as A import Affection.Animation as A +import Affection.Misc as A import qualified BABL as B @@ -169,59 +165,3 @@ withAffection AffectionConfig{..} = do cleanUp $ userState nState SDL.destroyWindow window SDL.quit - -getSurfaces :: SDL.Window -> IO (SDL.Surface, SDL.Surface) -getSurfaces window = do - oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window - rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0 - let surface = SDL.Surface rawSurfacePtr Nothing - return (oldSurf, surface) - --- Prehandle SDL events in case any window events occur -preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload] -preHandleEvents evs = - -- mapM handle evs - -- where - -- handle e = - -- case SDL.eventPayload e of - -- SDL.WindowMovedEvent _ -> do - -- liftIO $ traceIO "I was moved" - -- return e - -- _ -> - -- return e - return $ map SDL.eventPayload evs - --- | Return the userstate to the user -getAffection :: Affection us us -getAffection = do - ad <- get - return $ userState ad - --- | 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 - -> IO () -delaySec dur = SDL.delay (fromIntegral $ dur * 1000) - --- | Get time since start but always the same in the current tick. -getElapsedTime :: Affection us Double -getElapsedTime = - elapsedTime <$> get - -getDelta :: Affection us Double -getDelta = - deltaTime <$> get - -quit :: Affection us () -quit = do - ad <- get - put $ ad { quitEvent = True } diff --git a/src/Affection/Misc.hs b/src/Affection/Misc.hs new file mode 100644 index 0000000..8a13398 --- /dev/null +++ b/src/Affection/Misc.hs @@ -0,0 +1,66 @@ +module Affection.Misc +where + +import Affection.Types + +import qualified SDL + +import System.Clock + +import Control.Monad.State + +-- Prehandle SDL events in case any window events occur +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 = do + ad <- get + return $ userState ad + +-- | 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 + -> IO () +delaySec dur = SDL.delay (fromIntegral $ dur * 1000) + +-- | Get time since start but always the same in the current tick. +getElapsedTime :: Affection us Double +getElapsedTime = + elapsedTime <$> get + +getDelta :: Affection us Double +getDelta = + deltaTime <$> get + +quit :: Affection us () +quit = do + ad <- get + put $ ad { quitEvent = True } + +toggleScreen :: Affection us () +toggleScreen = do + ad <- get + newMode <- case screenMode ad of + SDL.Windowed -> do + SDL.setWindowMode (drawWindow ad) SDL.Fullscreen + return SDL.Fullscreen + SDL.Fullscreen -> do + SDL.setWindowMode (drawWindow ad) SDL.Windowed + return SDL.Windowed + now <- liftIO $ getTime Monotonic + put ad + { sysTime = now + , screenMode = newMode + } diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 9638d4d..c94d2c5 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -59,6 +59,8 @@ data AffectionConfig us = AffectionConfig -- ^ Window configuration , canvasSize :: Maybe (Int, Int) -- ^ size of the texture canvas + , initScreenMode :: SDL.WindowMode + -- ^ Window mode to start in , preLoop :: Affection us () -- ^ Actions to be performed, before loop starts , eventLoop :: SDL.EventPayload -> Affection us () @@ -87,6 +89,7 @@ data AffectionData us = AffectionData , windowRenderer :: SDL.Renderer -- ^ Internal renderer of window , drawTexture :: SDL.Texture -- ^ SDL Texture to draw to , drawFormat :: B.BablFormatPtr -- ^ Target format + , screenMode :: SDL.WindowMode -- ^ current screen mode , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawDimensions :: (Int, Int) -- ^ Dimensions of target surface , drawStride :: Int -- ^ Stride of target buffer