still won't work

This commit is contained in:
nek0 2017-12-13 15:19:53 +01:00
parent 1cbda31499
commit 78f058db6b
15 changed files with 239 additions and 263 deletions

View file

@ -70,6 +70,7 @@ library
, Affection.MessageBus.Message.WindowMessage , Affection.MessageBus.Message.WindowMessage
, Affection.MessageBus.Message.KeyboardMessage , Affection.MessageBus.Message.KeyboardMessage
, Affection.MessageBus.Message.MouseMessage , Affection.MessageBus.Message.MouseMessage
, Affection.Subsystems
, Affection.Subsystems.Class , Affection.Subsystems.Class
, Affection.Subsystems.AffectionWindow , Affection.Subsystems.AffectionWindow
, Affection.Subsystems.AffectionKeyboard , Affection.Subsystems.AffectionKeyboard
@ -104,23 +105,26 @@ library
, stm , stm
, uuid , uuid
-- executable example00 executable example00
-- hs-source-dirs: examples if flag(debug)
-- main-is: example00.hs cpp-options: -DDEBUG
-- ghc-options: -threaded -Wall if flag(warn)
-- default-language: Haskell2010 cpp-options: -DWARN
-- default-extensions: OverloadedStrings if flag(error)
-- if flag(examples) cpp-options: -DERROR
-- build-depends: base hs-source-dirs: examples
-- , affection main-is: example00.hs
-- , sdl2 ghc-options: -threaded -Wall
-- , gegl default-language: Haskell2010
-- , babl default-extensions: OverloadedStrings
-- , containers if flag(examples)
-- , mtl build-depends: base
-- else , affection
-- buildable: False , sdl2
-- , stm
else
buildable: False
-- executable example01 -- executable example01
-- hs-source-dirs: examples -- hs-source-dirs: examples
-- main-is: example01.hs -- main-is: example01.hs
@ -209,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,71 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
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 Foreign.Storable (peek) data StateData = StateData
import Foreign.C.Types (CInt(..)) { sdSubs :: Subsystems
}
import Debug.Trace data Subsystems = Subsystems
{ subWindow :: AffectionWindow StateData
-- main :: IO () , subMouse :: AffectionMouse StateData
-- main = withAllAffection $ , subKeyboard :: AffectionKeyboard StateData
-- withDefaultWindow "test" $ do }
-- changeColor $ RGBA 255 255 255 255
-- clear
-- present
-- liftIO $ delaySec 2
main :: IO () main :: IO ()
main = do main = do
conf <- return $ AffectionConfig logIO Debug "Starting"
let conf = AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Affection: example00" , windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow , windowConfig = SDL.defaultWindow
, preLoop = return () , initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle , eventLoop = handle
, updateLoop = update , updateLoop = update
, drawLoop = draw , drawLoop = draw
, loadState = load
, cleanUp = clean , 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 (AffectionWindow empty1)
prop "color1" $ G.RGBA 0.4 0.4 0.4 1 (AffectionMouse empty2)
prop "color2" $ G.RGBA 0.6 0.6 0.6 1 (AffectionKeyboard 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 -> quit
otherwise -> 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

@ -24,6 +24,9 @@ import Affection.StateMachine as A
import Affection.MouseInteractable as A import Affection.MouseInteractable as A
import Affection.Util as A import Affection.Util as A
import Affection.MessageBus 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 Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
@ -45,7 +48,7 @@ withAffection AffectionConfig{..} = do
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
@ -94,7 +97,8 @@ withAffection AffectionConfig{..} = do
} }
-- 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

View file

@ -1,7 +1,10 @@
module Affection.MessageBus module Affection.MessageBus
( module M ( module M
, module Msg
) where ) where
import Affection.MessageBus.Class as M import Affection.MessageBus.Class as M
import Affection.MessageBus.Message as M import Affection.MessageBus.Message as M
import Affection.MessageBus.Util as M import Affection.MessageBus.Util as M
import Affection.MessageBus.Message as Msg

View file

@ -1,6 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Rank2Types #-}
module Affection.MessageBus.Class module Affection.MessageBus.Class
( Participant(..) ( Participant(..)
, genUUID , genUUID
@ -26,7 +26,7 @@ class (Show m, Message m) => Participant prt m where
-- | Subscribe to the 'Participant''s events -- | Subscribe to the 'Participant''s events
partSubscribe partSubscribe
:: prt -- ^ The 'Participant' to subscribe to :: prt -- ^ The 'Participant' to subscribe to
-> (forall sd. m -> Affection sd ()) -- ^ What to do in case of a 'Message' -> (m -> Affection sd ()) -- ^ What to do in case of a 'Message'
-- (Subscriber function) -- (Subscriber function)
-> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function

View file

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

View file

@ -2,12 +2,10 @@ module Affection.MessageBus.Message.KeyboardMessage where
import Affection.MessageBus.Message.Class import Affection.MessageBus.Message.Class
import Data.Word (Word32(..))
import qualified SDL import qualified SDL
data KeyboardMessage = MsgKeyboardEvent data KeyboardMessage = MsgKeyboardEvent
{ msgKbdWhen :: Word32 { msgKbdWhen :: Double
, msgKbdWindow :: Maybe SDL.Window , msgKbdWindow :: Maybe SDL.Window
, msgKbdKeyMotion :: SDL.InputMotion , msgKbdKeyMotion :: SDL.InputMotion
, msgKbdLeyRepeat :: Bool , msgKbdLeyRepeat :: Bool

View file

@ -2,7 +2,7 @@ module Affection.MessageBus.Message.MouseMessage where
import Affection.MessageBus.Message.Class import Affection.MessageBus.Message.Class
import Data.Word (Word32(..), Word8(..)) import Data.Word (Word8(..))
import Data.Int (Int32(..)) import Data.Int (Int32(..))
import qualified SDL import qualified SDL
@ -11,7 +11,7 @@ import Linear (V2(..))
data MouseMessage data MouseMessage
= MsgMouseMotion = MsgMouseMotion
{ msgMMWhen :: Word32 { msgMMWhen :: Double
, msgMMWindow :: Maybe SDL.Window , msgMMWindow :: Maybe SDL.Window
, msgMMWhich :: SDL.MouseDevice , msgMMWhich :: SDL.MouseDevice
, msgMMState :: [SDL.MouseButton] , msgMMState :: [SDL.MouseButton]
@ -19,7 +19,7 @@ data MouseMessage
, msgMMRelMotion :: V2 Int32 , msgMMRelMotion :: V2 Int32
} }
| MsgMouseButton | MsgMouseButton
{ msgMBWhen :: Word32 { msgMBWhen :: Double
, msgMBWindow :: Maybe SDL.Window , msgMBWindow :: Maybe SDL.Window
, msgMBWhich :: SDL.MouseDevice , msgMBWhich :: SDL.MouseDevice
, msgMBButton :: SDL.MouseButton , msgMBButton :: SDL.MouseButton
@ -27,7 +27,7 @@ data MouseMessage
, msgMBPos :: V2 Int32 , msgMBPos :: V2 Int32
} }
| MsgMouseWheel | MsgMouseWheel
{ msgMWWhen :: Word32 { msgMWWhen :: Double
, msgMWWhindow :: Maybe SDL.Window , msgMWWhindow :: Maybe SDL.Window
, msgMWWhich :: SDL.MouseDevice , msgMWWhich :: SDL.MouseDevice
, msgMWPos :: V2 Int32 , msgMWPos :: V2 Int32

View file

@ -2,7 +2,6 @@ module Affection.MessageBus.Message.WindowMessage where
import Affection.MessageBus.Message.Class import Affection.MessageBus.Message.Class
import Data.Word (Word32(..))
import Data.Int (Int32(..)) import Data.Int (Int32(..))
import qualified SDL import qualified SDL
@ -10,63 +9,63 @@ import qualified SDL
import Linear (V2(..)) import Linear (V2(..))
data WindowMessage data WindowMessage
-- = MsgEngineReady Word32 -- = MsgEngineReady Double
= MsgWindowShow = MsgWindowShow
{ msgWSWhen :: Word32 { msgWSWhen :: Double
, msgWSWindow :: SDL.Window , msgWSWindow :: SDL.Window
} }
| MsgWindowHide | MsgWindowHide
{ msgWHWhen :: Word32 { msgWHWhen :: Double
, msgWHWindow :: SDL.Window , msgWHWindow :: SDL.Window
} }
| MsgWindowExpose | MsgWindowExpose
{ msgWEWhen :: Word32 { msgWEWhen :: Double
, msgWEWindow :: SDL.Window , msgWEWindow :: SDL.Window
} }
| MsgWindowMove | MsgWindowMove
{ msgWMWhen :: Word32 { msgWMWhen :: Double
, msgWMWindow :: SDL.Window , msgWMWindow :: SDL.Window
, msgWMNewPos :: V2 Int32 , msgWMNewPos :: V2 Int32
} }
| MsgWindowResize | MsgWindowResize
{ msgWRWhen :: Word32 { msgWRWhen :: Double
, msgWRWindow :: SDL.Window , msgWRWindow :: SDL.Window
, msgWRNewSize :: V2 Int32 , msgWRNewSize :: V2 Int32
} }
| MsgWindowSizeChange | MsgWindowSizeChange
{ msgWSCWhen :: Word32 { msgWSCWhen :: Double
, msgWSCWindow :: SDL.Window , msgWSCWindow :: SDL.Window
} }
| MsgWindowMinimize | MsgWindowMinimize
{ msgWMinWhen :: Word32 { msgWMinWhen :: Double
, msgWMinWindow :: SDL.Window , msgWMinWindow :: SDL.Window
} }
| MsgWindowMaximize | MsgWindowMaximize
{ msgWMaxWhen :: Word32 { msgWMaxWhen :: Double
, msgWMaxWindow :: SDL.Window , msgWMaxWindow :: SDL.Window
} }
| MsgWindowRestore | MsgWindowRestore
{ msgWRestWhen :: Word32 { msgWRestWhen :: Double
, msgWRestWindow :: SDL.Window , msgWRestWindow :: SDL.Window
} }
| MsgWindowGainMouseFocus | MsgWindowGainMouseFocus
{ msgWGMFWhen :: Word32 { msgWGMFWhen :: Double
, msgWGMFWindow :: SDL.Window , msgWGMFWindow :: SDL.Window
} }
| MsgWindowLoseMouseFocus | MsgWindowLoseMouseFocus
{ msgWLMFWhen :: Word32 { msgWLMFWhen :: Double
, msgWLMFWindow :: SDL.Window , msgWLMFWindow :: SDL.Window
} }
| MsgWindowGainKeyboardFocus | MsgWindowGainKeyboardFocus
{ msgWGKFWhen :: Word32 { msgWGKFWhen :: Double
, msgWGKFWindow :: SDL.Window , msgWGKFWindow :: SDL.Window
} }
| MsgWindowLoseKeyboardFocus | MsgWindowLoseKeyboardFocus
{ msgWLKFWhen :: Word32 { msgWLKFWhen :: Double
, msgWLKFWindow :: SDL.Window , msgWLKFWindow :: SDL.Window
} }
| MsgWindowClose | MsgWindowClose
{ msgWCWhen :: Word32 { msgWCWhen :: Double
, msgWCWindow :: SDL.Window , msgWCWindow :: SDL.Window
} }
deriving (Show) deriving (Show)

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

@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionKeyboard where
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class import Affection.Subsystems.Class
import Affection.Types import Affection.Types
import Affection.Util
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM as STM import Control.Concurrent.STM as STM
@ -30,13 +31,14 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where
return $ map snd subTups return $ map snd subTups
instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where
consumeSDLEvents ak evs = doConsume evs consumeSDLEvents ak eps = doConsume eps
where where
doConsume [] = return [] doConsume (e:es) = do
doConsume (e:es) = case SDL.eventPayload e of ts <- getElapsedTime
case e of
SDL.KeyboardEvent dat -> do SDL.KeyboardEvent dat -> do
partEmit ak (MsgKeyboardEvent partEmit ak (MsgKeyboardEvent
(SDL.eventTimestamp e) ts
(SDL.keyboardEventWindow dat) (SDL.keyboardEventWindow dat)
(SDL.keyboardEventKeyMotion dat) (SDL.keyboardEventKeyMotion dat)
(SDL.keyboardEventRepeat dat) (SDL.keyboardEventRepeat dat)

View file

@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionMouse where
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class import Affection.Subsystems.Class
import Affection.Types import Affection.Types
import Affection.Util
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM import Control.Concurrent.STM
@ -32,13 +33,14 @@ instance Participant (AffectionMouse sd) MouseMessage where
return $ map snd subTups return $ map snd subTups
instance SDLSubsystem (AffectionMouse sd) MouseMessage where instance SDLSubsystem (AffectionMouse sd) MouseMessage where
consumeSDLEvents am evs = doConsume evs consumeSDLEvents am eps = doConsume eps
where where
doConsume [] = return [] doConsume (e:es) = do
doConsume (e:es) = case SDL.eventPayload e of ts <- getElapsedTime
case e of
SDL.MouseMotionEvent dat -> do SDL.MouseMotionEvent dat -> do
partEmit am (MsgMouseMotion partEmit am (MsgMouseMotion
(SDL.eventTimestamp e) ts
(SDL.mouseMotionEventWindow dat) (SDL.mouseMotionEventWindow dat)
(SDL.mouseMotionEventWhich dat) (SDL.mouseMotionEventWhich dat)
(SDL.mouseMotionEventState dat) (SDL.mouseMotionEventState dat)
@ -48,7 +50,7 @@ instance SDLSubsystem (AffectionMouse sd) MouseMessage where
doConsume es doConsume es
SDL.MouseButtonEvent dat -> do SDL.MouseButtonEvent dat -> do
partEmit am (MsgMouseButton partEmit am (MsgMouseButton
(SDL.eventTimestamp e) ts
(SDL.mouseButtonEventWindow dat) (SDL.mouseButtonEventWindow dat)
(SDL.mouseButtonEventWhich dat) (SDL.mouseButtonEventWhich dat)
(SDL.mouseButtonEventButton dat) (SDL.mouseButtonEventButton dat)
@ -58,7 +60,7 @@ instance SDLSubsystem (AffectionMouse sd) MouseMessage where
doConsume es doConsume es
SDL.MouseWheelEvent dat -> do SDL.MouseWheelEvent dat -> do
partEmit am (MsgMouseWheel partEmit am (MsgMouseWheel
(SDL.eventTimestamp e) ts
(SDL.mouseWheelEventWindow dat) (SDL.mouseWheelEventWindow dat)
(SDL.mouseWheelEventWhich dat) (SDL.mouseWheelEventWhich dat)
(SDL.mouseWheelEventPos dat) (SDL.mouseWheelEventPos dat)

View file

@ -3,6 +3,7 @@
module Affection.Subsystems.AffectionWindow where module Affection.Subsystems.AffectionWindow where
import Affection.Types import Affection.Types
import Affection.Util
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class import Affection.Subsystems.Class
@ -30,50 +31,51 @@ instance Participant (AffectionWindow sd) WindowMessage where
return $ map snd subTups return $ map snd subTups
instance SDLSubsystem (AffectionWindow sd) WindowMessage where instance SDLSubsystem (AffectionWindow sd) WindowMessage where
consumeSDLEvents aw evs = doConsume evs consumeSDLEvents aw eps = doConsume eps
where where
doConsume [] = return [] doConsume (e:es) = do
doConsume (e:es) = case SDL.eventPayload e of ts <- getElapsedTime
case e of
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window) partEmit aw (MsgWindowShow ts window)
doConsume es doConsume es
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window) partEmit aw (MsgWindowHide ts window)
doConsume es doConsume es
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window) partEmit aw (MsgWindowExpose ts window)
doConsume es doConsume es
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
partEmit aw (MsgWindowMove (SDL.eventTimestamp e) window newPos) partEmit aw (MsgWindowMove ts window newPos)
doConsume es doConsume es
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize) partEmit aw (MsgWindowResize ts window newSize)
doConsume es doConsume es
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window) partEmit aw (MsgWindowSizeChange ts window)
doConsume es doConsume es
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window) partEmit aw (MsgWindowMinimize ts window)
doConsume es doConsume es
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window) partEmit aw (MsgWindowMaximize ts window)
doConsume es doConsume es
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window) partEmit aw (MsgWindowRestore ts window)
doConsume es doConsume es
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowGainMouseFocus ts window)
doConsume es doConsume es
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowLoseMouseFocus ts window)
doConsume es doConsume es
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowGainKeyboardFocus ts window)
doConsume es doConsume es
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowLoseKeyboardFocus ts window)
doConsume es doConsume es
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window) partEmit aw (MsgWindowClose ts window)
doConsume es doConsume es
_ -> fmap (e :) (doConsume es) _ -> fmap (e :) (doConsume es)

View file

@ -8,4 +8,4 @@ import Affection.MessageBus
import qualified SDL import qualified SDL
class (Message m, Participant s m) => SDLSubsystem s m where class (Message m, Participant s m) => SDLSubsystem s m where
consumeSDLEvents :: s -> [SDL.Event] -> Affection sd [SDL.Event] consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload]

View file

@ -64,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.
} }