diff --git a/.gitignore b/.gitignore index ced8b76..df67c56 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ dist/ *.aux *.hp *.ps +*.swp diff --git a/affection.cabal b/affection.cabal index cf45d46..00b97da 100644 --- a/affection.cabal +++ b/affection.cabal @@ -30,25 +30,51 @@ source-repository head type: git location: https://github.com/nek0/affection +flag debug + description: Enable debug messages + default: False + manual: True + +flag warn + description: Enable warning messages + default: False + manual: True + +flag error + description: Enable error messages + default: False + manual: True + flag examples description: Build example programs default: False library + if flag(debug) + cpp-options: -DDEBUG + if flag(warn) + cpp-options: -DWARN + if flag(error) + cpp-options: -DERROR exposed-modules: Affection - -- , Affection.Draw - -- , Affection.Particle + , Affection.Logging , Affection.Types , Affection.StateMachine , Affection.MouseInteractable - -- , Affection.Property - -- , Affection.Actor - -- , Affection.Animation , Affection.Util + , Affection.MessageBus , Affection.MessageBus.Util , Affection.MessageBus.Class - , Affection.MessageBus.Engine , Affection.MessageBus.Message + , Affection.MessageBus.Message.Class + , Affection.MessageBus.Message.WindowMessage + , Affection.MessageBus.Message.KeyboardMessage + , Affection.MessageBus.Message.MouseMessage + , Affection.Subsystems + , Affection.Subsystems.Class + , Affection.Subsystems.AffectionWindow + , Affection.Subsystems.AffectionKeyboard + , Affection.Subsystems.AffectionMouse default-extensions: OverloadedStrings -- Modules included in this library but not exported. @@ -66,11 +92,9 @@ library -- Other library packages from which modules are imported. build-depends: base >=4.9 , sdl2 + , linear , text , mtl - , time - -- , gegl - -- , babl , monad-loops , monad-parallel , containers @@ -79,25 +103,28 @@ library , bytestring , OpenGL , stm - -- , sdl2-image + , uuid + +executable example00 + if flag(debug) + cpp-options: -DDEBUG + if flag(warn) + cpp-options: -DWARN + if flag(error) + cpp-options: -DERROR + hs-source-dirs: examples + main-is: example00.hs + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base + , affection + , sdl2 + , stm + else + buildable: False --- executable example00 --- hs-source-dirs: examples --- main-is: example00.hs --- ghc-options: -threaded -Wall --- default-language: Haskell2010 --- default-extensions: OverloadedStrings --- if flag(examples) --- build-depends: base --- , affection --- , sdl2 --- , gegl --- , babl --- , containers --- , mtl --- else --- buildable: False --- -- executable example01 -- hs-source-dirs: examples -- main-is: example01.hs @@ -186,26 +213,26 @@ library -- , monad-parallel -- else -- buildable: False - -executable example05 - hs-source-dirs: examples - main-is: example05.hs - ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , unordered-containers - , mtl - , random - , matrix - , random - , monad-parallel - , parallel - else - buildable: False +-- +-- executable example05 +-- hs-source-dirs: examples +-- main-is: example05.hs +-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , unordered-containers +-- , mtl +-- , random +-- , matrix +-- , random +-- , monad-parallel +-- , parallel +-- else +-- buildable: False diff --git a/examples/example00.hs b/examples/example00.hs index def9f9e..d49eb94 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,117 +1,125 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} import Affection import qualified SDL -import qualified SDL.Raw as Raw -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M -import Control.Monad (when) +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) -import Foreign.Storable (peek) -import Foreign.C.Types (CInt(..)) +newtype StateData = StateData + { sdSubs :: Subsystems + } -import Debug.Trace +data Subsystems = Subsystems + { subWindow :: Window + , subMouse :: Mouse + , subKeyboard :: Keyboard + } --- main :: IO () --- main = withAllAffection $ --- withDefaultWindow "test" $ do --- changeColor $ RGBA 255 255 255 255 --- clear --- present --- liftIO $ delaySec 2 +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) +newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) + +instance Participant Window WindowMessage StateData where + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) = generalSubscribe t + + partUnSubscribe (Window t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Window StateData where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Mouse MouseMessage StateData where + partSubscribers (Mouse t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Mouse t) = generalSubscribe t + + partUnSubscribe (Mouse t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Mouse StateData where + consumeSDLEvents = consumeSDLMouseEvents + +instance Participant Keyboard KeyboardMessage StateData where + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Keyboard StateData where + consumeSDLEvents = consumeSDLKeyboardEvents + +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid main :: IO () main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = return () - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } + logIO Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example00" + , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + } + , initScreenMode = SDL.Windowed + , canvasSize = Nothing + , loadState = load + , preLoop = pre + , eventLoop = handle + , updateLoop = update + , drawLoop = draw + , cleanUp = clean + } withAffection conf -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - } - -load :: IO UserData +load :: IO StateData load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - text <- G.gegl_node_new_child root $ G.textOperation $ - props $ do - prop "string" ("Hello world!"::String) - prop "color" $ G.RGBA 0 0 1 0.5 - prop "size" (40::Int) - traceM "text" - G.gegl_node_link checkerboard over - G.gegl_node_connect_to text "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("checkerboard", checkerboard) - , ("text" , text) - ] - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - } + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())]) + empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) + return $ StateData $ Subsystems + (Window empty1) + (Mouse empty2) + (Keyboard empty3) -draw :: Affection UserData () -draw = do - traceM "drawing" - AffectionData{..} <- get - let UserData{..} = userState - liftIO $ SDL.lockSurface drawSurface - pixels <- liftIO $ SDL.surfacePixels drawSurface - let SDL.Surface rawSurfacePtr _ = drawSurface - rawSurface <- liftIO $ peek rawSurfacePtr - pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface - format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8) - SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface - let (w, h) = (fromIntegral rw, fromIntegral rh) - liftIO $ G.gegl_node_blit - (nodeGraph M.! "over" :: G.GeglNode) - 1 - (G.GeglRectangle 0 0 w h) - format - pixels - (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w) - [G.GeglBlitDefault] - liftIO $ SDL.unlockSurface drawSurface - liftIO $ SDL.updateWindowSurface drawWindow +pre :: Affection StateData () +pre = do + sd <- getAffection + _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ + return () -handle :: SDL.EventPayload -> Affection UserData () -handle = const $ return () +exitOnQ :: KeyboardMessage -> Affection StateData () +exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeQ -> do + liftIO $ logIO Debug "Yo dog I heard..." + quit + _ -> return () -update :: Double -> Affection UserData () -update sec = do - traceM "updating" - ad <- get - ud@UserData{..} <- getAffection +handle :: [SDL.EventPayload] -> Affection StateData () +handle es = do + (Subsystems a b c) <- sdSubs <$> getAffection + _ <- consumeSDLEvents a es + _ <- consumeSDLEvents b es + _ <- consumeSDLEvents c es + return () - -- sec <- getDelta - traceM $ (show $ 1 / sec) ++ " FPS" - when (elapsedTime ad > 5) $ - put $ ad - { quitEvent = True - } +update _ = return () + +draw = return () -clean :: UserData -> IO () clean _ = return () diff --git a/src/Affection.hs b/src/Affection.hs index 3dbb127..4988362 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -3,24 +3,12 @@ module Affection ( withAffection , get - , getAffection - , putAffection - -- , withWindow - -- , withDefaultWindow - , delaySec - , get , put , module A ) where import SDL (($=)) import qualified SDL -import qualified SDL.Internal.Numbered as SDL (toNumber) -import qualified SDL.Raw as Raw --- import qualified GEGL as G - -import Data.Maybe -import Data.IORef import System.Clock @@ -28,27 +16,20 @@ import Control.Monad.Loops import Control.Monad.State import Foreign.C.Types (CInt(..)) -import Foreign.Storable (peek) import Debug.Trace import Affection.Types as A --- import Affection.Draw as A --- import Affection.Particle as A import Affection.StateMachine as A import Affection.MouseInteractable as A --- import Affection.Property as A --- import Affection.Actor as A --- import Affection.Animation as A import Affection.Util as A -import Affection.MessageBus.Class as A -import Affection.MessageBus.Message as A -import Affection.MessageBus.Engine as A -import Affection.MessageBus.Util as A +import Affection.MessageBus as A +import Affection.Subsystems as A + +import Affection.Logging as A import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) --- import qualified BABL as B -- | Main function which bootstraps everything else. withAffection @@ -61,66 +42,34 @@ withAffection AffectionConfig{..} = do SDL.initializeAll Only is -> SDL.initialize is - -- G.gegl_init -- give SDL render quality SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear -- just checking… do renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $ - putStrLn "Warning: Linear texture filtering not enabled!" + logIO Warn "Linear texture filtering not enabled!" -- construct window window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window - context <- SDL.glCreateContext(window) - -- -- create renderer - -- renderer <- SDL.createRenderer - -- window - -- (-1) - -- SDL.defaultRenderer - -- -- make draw texture - -- texture <- SDL.createTexture - -- renderer - -- SDL.ABGR8888 - -- SDL.TextureAccessStreaming - -- (case canvasSize of - -- Just (cw, ch) -> (SDL.V2 - -- (CInt $ fromIntegral cw) - -- (CInt $ fromIntegral ch) - -- ) - -- Nothing -> - -- SDL.windowInitialSize windowConfig - -- ) - -- -- make draw surface - -- -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr + context <- SDL.glCreateContext window let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig (w, h) = case canvasSize of Just (cw, ch) -> (cw, ch) Nothing -> (fromIntegral rw, fromIntegral rh) - -- -- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w - -- bablFormat = B.PixelFormat B.RGBA B.CFu8 - -- cpp = B.babl_components_per_pixel bablFormat - -- !stride = cpp * w - -- format <- B.babl_format bablFormat - -- get current time SDL.setWindowMode window initScreenMode SDL.swapInterval $= SDL.SynchronizedUpdates + -- get current time execTime <- getTime Monotonic initContainer <- (\x -> AffectionData { quitEvent = False , userState = x , drawWindow = window , glContext = context - -- , windowRenderer = renderer - -- , drawTexture = texture - -- , drawFormat = format , drawDimensions = case canvasSize of Just (cw, ch) -> (cw, ch) Nothing -> (w, h) , screenMode = initScreenMode - -- , drawStride = stride - -- , drawCPP = cpp - -- , drawStack = [] , elapsedTime = 0 , deltaTime = 0 , sysTime = execTime @@ -138,37 +87,28 @@ withAffection AffectionConfig{..} = do -- Measure time difference form last run now <- liftIO $ getTime Monotonic let lastTime = sysTime ad - -- -- clean draw requests from last run - -- MP.mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad) - -- clean the renderer form last time - -- SDL.clear renderer -- compute dt and update elapsedTime - let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9) + let !dt = fromIntegral + (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) !ne = elapsedTime ad + dt put $ ad - -- { drawStack = [] { elapsedTime = ne , deltaTime = dt } -- poll events evs <- preHandleEvents =<< liftIO SDL.pollEvents - mapM_ eventLoop evs + -- mapM_ eventLoop evs + eventLoop evs -- execute user defined update loop unless (pausedTime ad) (updateLoop dt) -- execute user defined draw loop liftIO $ GL.clear [ColorBuffer, DepthBuffer] drawLoop - liftIO $ flush + liftIO flush -- handle all new draw requests ad2 <- get - -- clear <- catMaybes <$> - -- mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2) - -- -- save all draw requests to clear in next run - -- put $ ad2 - -- { drawStack = clear } -- actual drawing SDL.glSwapWindow window - -- SDL.present (windowRenderer ad2) -- save new time ad3 <- get when (sysTime ad == sysTime ad3) ( @@ -178,7 +118,6 @@ withAffection AffectionConfig{..} = do ) ) ) initContainer - -- G.gegl_exit cleanUp $ userState nState SDL.destroyWindow window SDL.quit diff --git a/src/Affection/Actor.hs b/src/Affection/Actor.hs index cff094f..0f98598 100644 --- a/src/Affection/Actor.hs +++ b/src/Affection/Actor.hs @@ -48,7 +48,7 @@ updateProperties ps act@Actor{..} = applyProperties :: (Show a, Ord a) => Actor a -> Affection us () applyProperties Actor{..} = - MP.mapM_ (\(ActorProperty{..}) -> + MP.mapM_ (\ActorProperty{..} -> maybe (return ()) (\m -> liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $ (G.Property (snd m) apValue) : [] diff --git a/src/Affection/Logging.hs b/src/Affection/Logging.hs new file mode 100644 index 0000000..0cf3032 --- /dev/null +++ b/src/Affection/Logging.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +module Affection.Logging where + +import Debug.Trace + +data LogLevel + = Debug + | Warn + | Error + +log :: LogLevel -> String -> a -> a +#if defined(DEBUG) +log Debug s = trace ("DEBUG: " ++ s) +#endif +#if defined(WARN) || defined(DEBUG) +log Warn s = trace ("WARN: " ++ s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) +log Error s = trace ("ERROR: " ++ s) +#endif +log _ _ = id + +logIO :: LogLevel -> String -> IO () +#if defined(DEBUG) +logIO Debug s = traceIO ("DEBUG: " ++ s) +#endif +#if defined(WARN) || defined(DEBUG) +logIO Warn s = traceIO ("WARN: " ++ s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) +logIO Error s = traceIO ("ERROR: " ++ s) +#endif +logIO _ _ = return () diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs new file mode 100644 index 0000000..d22edbb --- /dev/null +++ b/src/Affection/MessageBus.hs @@ -0,0 +1,10 @@ +module Affection.MessageBus + ( module M + , module Msg + ) where + +import Affection.MessageBus.Class as M +import Affection.MessageBus.Message as M +import Affection.MessageBus.Util as M + +import Affection.MessageBus.Message as Msg diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index c02687e..a715970 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,19 +1,61 @@ {-# LANGUAGE MultiParamTypeClasses #-} -module Affection.MessageBus.Class where - -import Control.Concurrent.STM as STM - -import Data.IORef +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Affection.MessageBus.Class + ( Participant(..) + , genUUID + , UUID + ) where import Affection.MessageBus.Message +import Affection.Types -newtype (Message msg) => Channel msg = Channel (TChan msg) +import Control.Monad.IO.Class (liftIO) -class (Message msg) => Participant prt msg where - partChannel :: prt -> IORef (Channel msg) +import Data.UUID +import Data.UUID.V4 - partConnectChannel :: prt -> Channel msg -> IO () +import Affection.Logging - partListen :: prt -> IO msg +class (Show m, Message m) => Participant prt m us where - partBroadcast :: prt -> msg -> IO () + -- | Function to get the list of subscribers from the participant + partSubscribers + :: prt + -- ^ the 'Participant''s subscriber storage + -> Affection us [m -> Affection us ()] + -- ^ List of Subscriber functions + + -- | Subscribe to the 'Participant''s events + partSubscribe + :: prt + -- ^ The 'Participant''s subscriber storage + -> (m -> Affection us ()) + -- ^ What to do in case of a 'Message' + -- (Subscriber function) + -> Affection us UUID + -- ^ 'UUID' of the registered subscriber Function + + -- | Unsubscribe a Subscriber function from Participant + partUnSubscribe + :: prt + -- ^ The 'Participant''s subscriber storage to unsubscribe from + -> UUID + -- ^ The subscriber function's 'UUID' + -> Affection us () + + -- | Get the 'Participant' to emit a 'Message' on all of its subscribers + partEmit + :: prt + -- ^ The 'Participant''s subscriber storage + -> m + -- ^ The 'Message' to emit + -> Affection us () + partEmit p m = do + liftIO $ logIO Debug $ "Emitting message: " ++ show m + l <- partSubscribers p + mapM_ ($ m) l + +-- | Helper function to generate new 'UUID's +genUUID :: Affection us UUID +genUUID = liftIO nextRandom diff --git a/src/Affection/MessageBus/Engine.hs b/src/Affection/MessageBus/Engine.hs deleted file mode 100644 index 9990a94..0000000 --- a/src/Affection/MessageBus/Engine.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Affection.MessageBus.Engine where - -import Affection.MessageBus.Class diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 8fe92fe..0af45ec 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -1,18 +1,8 @@ -{-# LANGUAGE RankNTypes #-} -module Affection.MessageBus.Message where +module Affection.MessageBus.Message + ( module M + ) where -import Data.Time.Clock (UTCTime(..)) - -class Message msg where - msgTime :: msg -> UTCTime - -data EngineMessage m - = MsgUserMessage - { msgPayload :: m - , msgWhen :: UTCTime - } -- ^ Generic user defined message with custom payload - | MsgEngineReady UTCTime - -instance Message (EngineMessage m) where - msgTime (MsgUserMessage _ t) = t - msgTime (MsgEngineReady t) = t +import Affection.MessageBus.Message.Class as M +import Affection.MessageBus.Message.WindowMessage as M +import Affection.MessageBus.Message.KeyboardMessage as M +import Affection.MessageBus.Message.MouseMessage as M diff --git a/src/Affection/MessageBus/Message/Class.hs b/src/Affection/MessageBus/Message/Class.hs new file mode 100644 index 0000000..bcb2651 --- /dev/null +++ b/src/Affection/MessageBus/Message/Class.hs @@ -0,0 +1,6 @@ +module Affection.MessageBus.Message.Class where + +import Data.Word (Word32(..)) + +class Message msg where + msgTime :: msg -> Double diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs new file mode 100644 index 0000000..6b90b0f --- /dev/null +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -0,0 +1,16 @@ +module Affection.MessageBus.Message.KeyboardMessage where + +import Affection.MessageBus.Message.Class + +import qualified SDL + +data KeyboardMessage = MsgKeyboardEvent + { msgKbdWhen :: Double + , msgKbdWindow :: Maybe SDL.Window + , msgKbdKeyMotion :: SDL.InputMotion + , msgKbdKeyRepeat :: Bool + , msgKbdKeysym :: SDL.Keysym + } deriving (Show) + +instance Message KeyboardMessage where + msgTime (MsgKeyboardEvent t _ _ _ _) = t diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs new file mode 100644 index 0000000..5833ae1 --- /dev/null +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -0,0 +1,41 @@ +module Affection.MessageBus.Message.MouseMessage where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word8(..)) +import Data.Int (Int32(..)) + +import qualified SDL + +import Linear (V2(..)) + +data MouseMessage + = MsgMouseMotion + { msgMMWhen :: Double + , msgMMWindow :: Maybe SDL.Window + , msgMMWhich :: SDL.MouseDevice + , msgMMState :: [SDL.MouseButton] + , msgMMPos :: V2 Int32 + , msgMMRelMotion :: V2 Int32 + } + | MsgMouseButton + { msgMBWhen :: Double + , msgMBWindow :: Maybe SDL.Window + , msgMBWhich :: SDL.MouseDevice + , msgMBButton :: SDL.MouseButton + , msgMBClicks :: Word8 + , msgMBPos :: V2 Int32 + } + | MsgMouseWheel + { msgMWWhen :: Double + , msgMWWhindow :: Maybe SDL.Window + , msgMWWhich :: SDL.MouseDevice + , msgMWPos :: V2 Int32 + , msgMWDIrection :: SDL.MouseScrollDirection + } + deriving (Show) + +instance Message MouseMessage where + msgTime (MsgMouseMotion t _ _ _ _ _) = t + msgTime (MsgMouseButton t _ _ _ _ _) = t + msgTime (MsgMouseWheel t _ _ _ _) = t diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs new file mode 100644 index 0000000..d857ed2 --- /dev/null +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -0,0 +1,88 @@ +module Affection.MessageBus.Message.WindowMessage where + +import Affection.MessageBus.Message.Class + +import Data.Int (Int32(..)) + +import qualified SDL + +import Linear (V2(..)) + +data WindowMessage + -- = MsgEngineReady Double + = MsgWindowShow + { msgWSWhen :: Double + , msgWSWindow :: SDL.Window + } + | MsgWindowHide + { msgWHWhen :: Double + , msgWHWindow :: SDL.Window + } + | MsgWindowExpose + { msgWEWhen :: Double + , msgWEWindow :: SDL.Window + } + | MsgWindowMove + { msgWMWhen :: Double + , msgWMWindow :: SDL.Window + , msgWMNewPos :: V2 Int32 + } + | MsgWindowResize + { msgWRWhen :: Double + , msgWRWindow :: SDL.Window + , msgWRNewSize :: V2 Int32 + } + | MsgWindowSizeChange + { msgWSCWhen :: Double + , msgWSCWindow :: SDL.Window + } + | MsgWindowMinimize + { msgWMinWhen :: Double + , msgWMinWindow :: SDL.Window + } + | MsgWindowMaximize + { msgWMaxWhen :: Double + , msgWMaxWindow :: SDL.Window + } + | MsgWindowRestore + { msgWRestWhen :: Double + , msgWRestWindow :: SDL.Window + } + | MsgWindowGainMouseFocus + { msgWGMFWhen :: Double + , msgWGMFWindow :: SDL.Window + } + | MsgWindowLoseMouseFocus + { msgWLMFWhen :: Double + , msgWLMFWindow :: SDL.Window + } + | MsgWindowGainKeyboardFocus + { msgWGKFWhen :: Double + , msgWGKFWindow :: SDL.Window + } + | MsgWindowLoseKeyboardFocus + { msgWLKFWhen :: Double + , msgWLKFWindow :: SDL.Window + } + | MsgWindowClose + { msgWCWhen :: Double + , msgWCWindow :: SDL.Window + } + deriving (Show) + +instance Message WindowMessage where + -- msgTime (MsgEngineReady t) = t + msgTime (MsgWindowShow t _) = t + msgTime (MsgWindowHide t _) = t + msgTime (MsgWindowExpose t _) = t + msgTime (MsgWindowMove t _ _) = t + msgTime (MsgWindowResize t _ _) = t + msgTime (MsgWindowSizeChange t _) = t + msgTime (MsgWindowMinimize t _) = t + msgTime (MsgWindowMaximize t _) = t + msgTime (MsgWindowRestore t _) = t + msgTime (MsgWindowGainMouseFocus t _) = t + msgTime (MsgWindowLoseMouseFocus t _) = t + msgTime (MsgWindowGainKeyboardFocus t _) = t + msgTime (MsgWindowLoseKeyboardFocus t _) = t + msgTime (MsgWindowClose t _) = t diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs index ed7c551..b2cae3e 100644 --- a/src/Affection/MessageBus/Util.hs +++ b/src/Affection/MessageBus/Util.hs @@ -1,8 +1,3 @@ module Affection.MessageBus.Util where -import Affection.MessageBus.Class -import Affection.MessageBus.Message -import Control.Concurrent.STM as STM - -newBroadcastChannel :: (Message msg) => IO (Channel msg) -newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan +-- zuru zuru diff --git a/src/Affection/Subsystems.hs b/src/Affection/Subsystems.hs new file mode 100644 index 0000000..ce9929f --- /dev/null +++ b/src/Affection/Subsystems.hs @@ -0,0 +1,8 @@ +module Affection.Subsystems + ( module S + ) where + +import Affection.Subsystems.Class as S +import Affection.Subsystems.AffectionKeyboard as S +import Affection.Subsystems.AffectionWindow as S +import Affection.Subsystems.AffectionMouse as S diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs new file mode 100644 index 0000000..3df62fd --- /dev/null +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +module Affection.Subsystems.AffectionKeyboard where + +import Affection.Types +import Affection.Util +import Affection.MessageBus +import Affection.Subsystems.Class + +import Control.Concurrent.STM as STM +import Control.Monad.IO.Class (liftIO) + +import qualified SDL + +consumeSDLKeyboardEvents + :: (Participant ak KeyboardMessage us) + => ak + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLKeyboardEvents ak = doConsume + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.KeyboardEvent dat -> do + partEmit ak (MsgKeyboardEvent + ts + (SDL.keyboardEventWindow dat) + (SDL.keyboardEventKeyMotion dat) + (SDL.keyboardEventRepeat dat) + (SDL.keyboardEventKeysym dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs new file mode 100644 index 0000000..dcbcf3a --- /dev/null +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +module Affection.Subsystems.AffectionMouse where + +import Affection.MessageBus +import Affection.Subsystems.Class +import Affection.Types +import Affection.Util + +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.STM + +import Linear.Affine (unP) + +import qualified SDL + +consumeSDLMouseEvents + :: (Participant am MouseMessage us) + => am + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLMouseEvents am = doConsume + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.MouseMotionEvent dat -> do + partEmit am (MsgMouseMotion + ts + (SDL.mouseMotionEventWindow dat) + (SDL.mouseMotionEventWhich dat) + (SDL.mouseMotionEventState dat) + (unP $ SDL.mouseMotionEventPos dat) + (SDL.mouseMotionEventRelMotion dat) + ) + doConsume es + SDL.MouseButtonEvent dat -> do + partEmit am (MsgMouseButton + ts + (SDL.mouseButtonEventWindow dat) + (SDL.mouseButtonEventWhich dat) + (SDL.mouseButtonEventButton dat) + (SDL.mouseButtonEventClicks dat) + (unP $ SDL.mouseButtonEventPos dat) + ) + doConsume es + SDL.MouseWheelEvent dat -> do + partEmit am (MsgMouseWheel + ts + (SDL.mouseWheelEventWindow dat) + (SDL.mouseWheelEventWhich dat) + (SDL.mouseWheelEventPos dat) + (SDL.mouseWheelEventDirection dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs new file mode 100644 index 0000000..6aadf0d --- /dev/null +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +module Affection.Subsystems.AffectionWindow where + +import Affection.Types +import Affection.Util +import Affection.MessageBus +import Affection.Subsystems.Class + +import Control.Concurrent.STM as STM +import Control.Monad.IO.Class (liftIO) + +import qualified SDL + +consumeSDLWindowEvents + :: (Participant aw WindowMessage us) + => aw + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLWindowEvents aw = doConsume + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do + partEmit aw (MsgWindowShow ts window) + doConsume es + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do + partEmit aw (MsgWindowHide ts window) + doConsume es + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do + partEmit aw (MsgWindowExpose ts window) + doConsume es + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do + partEmit aw (MsgWindowMove ts window newPos) + doConsume es + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do + partEmit aw (MsgWindowResize ts window newSize) + doConsume es + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do + partEmit aw (MsgWindowSizeChange ts window) + doConsume es + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do + partEmit aw (MsgWindowMinimize ts window) + doConsume es + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do + partEmit aw (MsgWindowMaximize ts window) + doConsume es + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do + partEmit aw (MsgWindowRestore ts window) + doConsume es + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do + partEmit aw (MsgWindowGainMouseFocus ts window) + doConsume es + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do + partEmit aw (MsgWindowLoseMouseFocus ts window) + doConsume es + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowGainKeyboardFocus ts window) + doConsume es + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowLoseKeyboardFocus ts window) + doConsume es + SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do + partEmit aw (MsgWindowClose ts window) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs new file mode 100644 index 0000000..7c52f8e --- /dev/null +++ b/src/Affection/Subsystems/Class.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Affection.Subsystems.Class where + +import Affection.Types +import Affection.MessageBus + +import qualified SDL + +class SDLSubsystem s us where + consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index df107dc..350c285 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -50,6 +50,8 @@ import System.Clock (TimeSpec) import Foreign.Ptr (Ptr) +import Affection.MessageBus.Message + -- | Configuration for the aplication. needed at startup. data AffectionConfig us = AffectionConfig { initComponents :: InitComponents @@ -62,16 +64,16 @@ data AffectionConfig us = AffectionConfig -- ^ 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 () + , 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. - , loadState :: IO us - -- ^ Provide your own load function to create this data. , cleanUp :: us -> IO () -- ^ Provide your own finisher function to clean your data. } @@ -100,6 +102,7 @@ data AffectionData us = AffectionData , 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? + -- , messageChannel :: Channel msg -- ^ The main broadcast channel to duplicate all others from } -- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated @@ -118,7 +121,7 @@ data AffectionData us = AffectionData -- | Inner 'StateT' monad for the update state -- type AffectionStateInner us m a = StateT (AffectionData us) m a -type AffectionStateInner us m a = StateT us m a +type AffectionStateInner us a = StateT us a -- | Affection's state monad newtype AffectionState us m a = AffectionState