Merge pull request #6 from nek0/messages

Messages
This commit is contained in:
rys ostrovid 2017-12-15 19:27:17 +01:00 committed by GitHub
commit 0b8eac27f4
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
21 changed files with 639 additions and 263 deletions

1
.gitignore vendored
View file

@ -10,3 +10,4 @@ dist/
*.aux *.aux
*.hp *.hp
*.ps *.ps
*.swp

View file

@ -30,25 +30,51 @@ source-repository head
type: git type: git
location: https://github.com/nek0/affection 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 flag examples
description: Build example programs description: Build example programs
default: False default: False
library library
if flag(debug)
cpp-options: -DDEBUG
if flag(warn)
cpp-options: -DWARN
if flag(error)
cpp-options: -DERROR
exposed-modules: Affection exposed-modules: Affection
-- , Affection.Draw , Affection.Logging
-- , Affection.Particle
, Affection.Types , Affection.Types
, Affection.StateMachine , Affection.StateMachine
, Affection.MouseInteractable , Affection.MouseInteractable
-- , Affection.Property
-- , Affection.Actor
-- , Affection.Animation
, Affection.Util , Affection.Util
, Affection.MessageBus
, Affection.MessageBus.Util , Affection.MessageBus.Util
, Affection.MessageBus.Class , Affection.MessageBus.Class
, Affection.MessageBus.Engine
, Affection.MessageBus.Message , 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 default-extensions: OverloadedStrings
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
@ -66,11 +92,9 @@ library
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 build-depends: base >=4.9
, sdl2 , sdl2
, linear
, text , text
, mtl , mtl
, time
-- , gegl
-- , babl
, monad-loops , monad-loops
, monad-parallel , monad-parallel
, containers , containers
@ -79,25 +103,28 @@ library
, bytestring , bytestring
, OpenGL , OpenGL
, stm , 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 -- executable example01
-- hs-source-dirs: examples -- hs-source-dirs: examples
-- main-is: example01.hs -- main-is: example01.hs
@ -186,26 +213,26 @@ library
-- , monad-parallel -- , monad-parallel
-- else -- else
-- buildable: False -- buildable: False
--
executable example05 -- executable example05
hs-source-dirs: examples -- hs-source-dirs: examples
main-is: example05.hs -- main-is: example05.hs
ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts -- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts
default-language: Haskell2010 -- default-language: Haskell2010
default-extensions: OverloadedStrings -- default-extensions: OverloadedStrings
if flag(examples) -- if flag(examples)
build-depends: base -- build-depends: base
, affection -- , affection
, sdl2 -- , sdl2
, gegl -- , gegl
, babl -- , babl
, containers -- , containers
, unordered-containers -- , unordered-containers
, mtl -- , mtl
, random -- , random
, matrix -- , matrix
, random -- , random
, monad-parallel -- , monad-parallel
, parallel -- , parallel
else -- else
buildable: False -- buildable: False

View file

@ -1,117 +1,125 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-}
import Affection import Affection
import qualified SDL 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) newtype StateData = StateData
import Foreign.C.Types (CInt(..)) { sdSubs :: Subsystems
}
import Debug.Trace data Subsystems = Subsystems
{ subWindow :: Window
, subMouse :: Mouse
, subKeyboard :: Keyboard
}
-- main :: IO () newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
-- main = withAllAffection $ newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
-- withDefaultWindow "test" $ do newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
-- changeColor $ RGBA 255 255 255 255
-- clear instance Participant Window WindowMessage StateData where
-- present partSubscribers (Window t) = do
-- liftIO $ delaySec 2 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 :: IO ()
main = do main = do
conf <- return $ AffectionConfig logIO Debug "Starting"
{ initComponents = All let conf = AffectionConfig
, windowTitle = "Affection: example00" { initComponents = All
, windowConfig = SDL.defaultWindow , windowTitle = "affection: example00"
, preLoop = return () , windowConfig = SDL.defaultWindow
, eventLoop = handle { SDL.windowOpenGL = Just SDL.defaultOpenGL
, updateLoop = update { SDL.glProfile = SDL.Core SDL.Normal 3 3
, drawLoop = draw }
, loadState = load }
, cleanUp = clean , initScreenMode = SDL.Windowed
} , canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf withAffection conf
data UserData = UserData load :: IO StateData
{ nodeGraph :: M.Map String G.GeglNode
}
load :: IO UserData
load = do load = do
traceM "loading" empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
root <- G.gegl_node_new empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
traceM "new root node" empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ return $ StateData $ Subsystems
props $ do (Window empty1)
prop "color1" $ G.RGBA 0.4 0.4 0.4 1 (Mouse empty2)
prop "color2" $ G.RGBA 0.6 0.6 0.6 1 (Keyboard empty3)
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
}
draw :: Affection UserData () pre :: Affection StateData ()
draw = do pre = do
traceM "drawing" sd <- getAffection
AffectionData{..} <- get _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
let UserData{..} = userState return ()
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
handle :: SDL.EventPayload -> Affection UserData () exitOnQ :: KeyboardMessage -> Affection StateData ()
handle = const $ return () exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeQ -> do
liftIO $ logIO Debug "Yo dog I heard..."
quit
_ -> return ()
update :: Double -> Affection UserData () handle :: [SDL.EventPayload] -> Affection StateData ()
update sec = do handle es = do
traceM "updating" (Subsystems a b c) <- sdSubs <$> getAffection
ad <- get _ <- consumeSDLEvents a es
ud@UserData{..} <- getAffection _ <- consumeSDLEvents b es
_ <- consumeSDLEvents c es
return ()
-- sec <- getDelta update _ = return ()
traceM $ (show $ 1 / sec) ++ " FPS"
when (elapsedTime ad > 5) $ draw = return ()
put $ ad
{ quitEvent = True
}
clean :: UserData -> IO ()
clean _ = return () clean _ = return ()

View file

@ -3,24 +3,12 @@
module Affection module Affection
( withAffection ( withAffection
, get , get
, getAffection
, putAffection
-- , withWindow
-- , withDefaultWindow
, delaySec
, get
, put , put
, module A , module A
) where ) where
import SDL (($=)) import SDL (($=))
import qualified 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 import System.Clock
@ -28,27 +16,20 @@ import Control.Monad.Loops
import Control.Monad.State import Control.Monad.State
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
import Foreign.Storable (peek)
import Debug.Trace import Debug.Trace
import Affection.Types as A import Affection.Types as A
-- import Affection.Draw as A
-- import Affection.Particle as A
import Affection.StateMachine as A import Affection.StateMachine as A
import Affection.MouseInteractable 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.Util as A
import Affection.MessageBus.Class as A import Affection.MessageBus as A
import Affection.MessageBus.Message as A import Affection.Subsystems as A
import Affection.MessageBus.Engine as A
import Affection.MessageBus.Util as A import Affection.Logging as A
import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- import qualified BABL as B
-- | Main function which bootstraps everything else. -- | Main function which bootstraps everything else.
withAffection withAffection
@ -61,66 +42,34 @@ withAffection AffectionConfig{..} = do
SDL.initializeAll SDL.initializeAll
Only is -> Only is ->
SDL.initialize is SDL.initialize is
-- G.gegl_init
-- give SDL render quality -- give SDL render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- just checking… -- just checking…
do do
renderQuality <- SDL.get SDL.HintRenderScaleQuality renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $ when (renderQuality /= SDL.ScaleLinear) $
putStrLn "Warning: Linear texture filtering not enabled!" logIO Warn "Linear texture filtering not enabled!"
-- construct window -- construct window
window <- SDL.createWindow windowTitle windowConfig window <- SDL.createWindow windowTitle windowConfig
SDL.showWindow window SDL.showWindow window
context <- SDL.glCreateContext(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
let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
(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)
-- -- 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.setWindowMode window initScreenMode
SDL.swapInterval $= SDL.SynchronizedUpdates SDL.swapInterval $= SDL.SynchronizedUpdates
-- get current time
execTime <- getTime Monotonic execTime <- getTime Monotonic
initContainer <- (\x -> AffectionData initContainer <- (\x -> AffectionData
{ quitEvent = False { quitEvent = False
, userState = x , userState = x
, drawWindow = window , drawWindow = window
, glContext = context , glContext = context
-- , windowRenderer = renderer
-- , drawTexture = texture
-- , drawFormat = format
, drawDimensions = case canvasSize of , drawDimensions = case canvasSize of
Just (cw, ch) -> (cw, ch) Just (cw, ch) -> (cw, ch)
Nothing -> (w, h) Nothing -> (w, h)
, screenMode = initScreenMode , screenMode = initScreenMode
-- , drawStride = stride
-- , drawCPP = cpp
-- , drawStack = []
, elapsedTime = 0 , elapsedTime = 0
, deltaTime = 0 , deltaTime = 0
, sysTime = execTime , sysTime = execTime
@ -138,37 +87,28 @@ withAffection AffectionConfig{..} = do
-- Measure time difference form last run -- Measure time difference form last run
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic
let lastTime = sysTime ad 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 -- 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 !ne = elapsedTime ad + dt
put $ ad put $ ad
-- { drawStack = []
{ elapsedTime = ne { elapsedTime = ne
, deltaTime = dt , deltaTime = dt
} }
-- poll events -- poll events
evs <- preHandleEvents =<< liftIO SDL.pollEvents evs <- preHandleEvents =<< liftIO SDL.pollEvents
mapM_ eventLoop evs -- mapM_ eventLoop evs
eventLoop evs
-- execute user defined update loop -- execute user defined update loop
unless (pausedTime ad) (updateLoop dt) unless (pausedTime ad) (updateLoop dt)
-- execute user defined draw loop -- execute user defined draw loop
liftIO $ GL.clear [ColorBuffer, DepthBuffer] liftIO $ GL.clear [ColorBuffer, DepthBuffer]
drawLoop drawLoop
liftIO $ flush liftIO flush
-- handle all new draw requests -- handle all new draw requests
ad2 <- get 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 -- actual drawing
SDL.glSwapWindow window SDL.glSwapWindow window
-- SDL.present (windowRenderer ad2)
-- save new time -- save new time
ad3 <- get ad3 <- get
when (sysTime ad == sysTime ad3) ( when (sysTime ad == sysTime ad3) (
@ -178,7 +118,6 @@ withAffection AffectionConfig{..} = do
) )
) )
) initContainer ) initContainer
-- G.gegl_exit
cleanUp $ userState nState cleanUp $ userState nState
SDL.destroyWindow window SDL.destroyWindow window
SDL.quit SDL.quit

View file

@ -48,7 +48,7 @@ updateProperties ps act@Actor{..} =
applyProperties :: (Show a, Ord a) => Actor a -> Affection us () applyProperties :: (Show a, Ord a) => Actor a -> Affection us ()
applyProperties Actor{..} = applyProperties Actor{..} =
MP.mapM_ (\(ActorProperty{..}) -> MP.mapM_ (\ActorProperty{..} ->
maybe (return ()) (\m -> maybe (return ()) (\m ->
liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $ liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $
(G.Property (snd m) apValue) : [] (G.Property (snd m) apValue) : []

33
src/Affection/Logging.hs Normal file
View file

@ -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 ()

View file

@ -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

View file

@ -1,19 +1,61 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
module Affection.MessageBus.Class where {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
import Control.Concurrent.STM as STM module Affection.MessageBus.Class
( Participant(..)
import Data.IORef , genUUID
, UUID
) where
import Affection.MessageBus.Message 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 import Data.UUID
partChannel :: prt -> IORef (Channel msg) 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

View file

@ -1,3 +0,0 @@
module Affection.MessageBus.Engine where
import Affection.MessageBus.Class

View file

@ -1,18 +1,8 @@
{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Message
module Affection.MessageBus.Message where ( module M
) where
import Data.Time.Clock (UTCTime(..)) import Affection.MessageBus.Message.Class as M
import Affection.MessageBus.Message.WindowMessage as M
class Message msg where import Affection.MessageBus.Message.KeyboardMessage as M
msgTime :: msg -> UTCTime import Affection.MessageBus.Message.MouseMessage as M
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

View file

@ -0,0 +1,6 @@
module Affection.MessageBus.Message.Class where
import Data.Word (Word32(..))
class Message msg where
msgTime :: msg -> Double

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -1,8 +1,3 @@
module Affection.MessageBus.Util where module Affection.MessageBus.Util where
import Affection.MessageBus.Class -- zuru zuru
import Affection.MessageBus.Message
import Control.Concurrent.STM as STM
newBroadcastChannel :: (Message msg) => IO (Channel msg)
newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan

View file

@ -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

View file

@ -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)

View file

@ -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)

View file

@ -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)

View file

@ -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]

View file

@ -50,6 +50,8 @@ import System.Clock (TimeSpec)
import Foreign.Ptr (Ptr) import Foreign.Ptr (Ptr)
import Affection.MessageBus.Message
-- | Configuration for the aplication. needed at startup. -- | Configuration for the aplication. needed at startup.
data AffectionConfig us = AffectionConfig data AffectionConfig us = AffectionConfig
{ initComponents :: InitComponents { initComponents :: InitComponents
@ -62,16 +64,16 @@ data AffectionConfig us = AffectionConfig
-- ^ size of the texture canvas -- ^ size of the texture canvas
, initScreenMode :: SDL.WindowMode , initScreenMode :: SDL.WindowMode
-- ^ Window mode to start in -- ^ Window mode to start in
, loadState :: IO us
-- ^ Provide your own load function to create this data.
, preLoop :: Affection us () , preLoop :: Affection us ()
-- ^ Actions to be performed, before loop starts -- ^ 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. -- ^ Main update function. Takes fractions of a second as input.
, updateLoop :: Double -> Affection us () , updateLoop :: Double -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input. -- ^ Main update function. Takes fractions of a second as input.
, drawLoop :: Affection us () , drawLoop :: Affection us ()
-- ^ Function for updating graphics. -- ^ Function for updating graphics.
, loadState :: IO us
-- ^ Provide your own load function to create this data.
, cleanUp :: us -> IO () , cleanUp :: us -> IO ()
-- ^ Provide your own finisher function to clean your data. -- ^ 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 , deltaTime :: Double -- ^ Elapsed time in seconds since last tick
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
, pausedTime :: Bool -- ^ Should the update loop be executed? , 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 -- -- | 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 -- | Inner 'StateT' monad for the update state
-- type AffectionStateInner us m a = StateT (AffectionData us) m a -- 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 -- | Affection's state monad
newtype AffectionState us m a = AffectionState newtype AffectionState us m a = AffectionState