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
*.hp
*.ps
*.swp

View file

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

View file

@ -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
logIO Debug "Starting"
let conf = AffectionConfig
{ initComponents = All
, windowTitle = "Affection: example00"
, windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow
, preLoop = return ()
{ 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
, loadState = load
, 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 ()

View file

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

View file

@ -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) : []

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 #-}
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

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

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

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