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"
{ initComponents = All let conf = AffectionConfig
, windowTitle = "Affection: example00" { initComponents = All
, windowConfig = SDL.defaultWindow , windowTitle = "affection: example00"
, preLoop = return () , windowConfig = SDL.defaultWindow
, eventLoop = handle , initScreenMode = SDL.Windowed
, updateLoop = update , canvasSize = Nothing
, drawLoop = draw , loadState = load
, loadState = load , preLoop = pre
, cleanUp = clean , 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 (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
@ -20,13 +20,13 @@ import Affection.Logging
class (Show m, Message m) => Participant prt m where class (Show m, Message m) => Participant prt m where
-- | Function to get the lsit of subscribers from the participant -- | Function to get the lsit of subscribers from the participant
partSubscribers partSubscribers
:: prt -- ^ the participant :: prt -- ^ the participant
-> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions -> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions
-- | 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,17 +31,18 @@ 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
SDL.KeyboardEvent dat -> do case e of
partEmit ak (MsgKeyboardEvent SDL.KeyboardEvent dat -> do
(SDL.eventTimestamp e) partEmit ak (MsgKeyboardEvent
(SDL.keyboardEventWindow dat) ts
(SDL.keyboardEventKeyMotion dat) (SDL.keyboardEventWindow dat)
(SDL.keyboardEventRepeat dat) (SDL.keyboardEventKeyMotion dat)
(SDL.keyboardEventKeysym dat) (SDL.keyboardEventRepeat dat)
) (SDL.keyboardEventKeysym dat)
doConsume es )
_ -> fmap (e :) (doConsume es) doConsume es
_ -> fmap (e :) (doConsume es)

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,37 +33,38 @@ 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
SDL.MouseMotionEvent dat -> do case e of
partEmit am (MsgMouseMotion SDL.MouseMotionEvent dat -> do
(SDL.eventTimestamp e) partEmit am (MsgMouseMotion
(SDL.mouseMotionEventWindow dat) ts
(SDL.mouseMotionEventWhich dat) (SDL.mouseMotionEventWindow dat)
(SDL.mouseMotionEventState dat) (SDL.mouseMotionEventWhich dat)
(unP $ SDL.mouseMotionEventPos dat) (SDL.mouseMotionEventState dat)
(SDL.mouseMotionEventRelMotion dat) (unP $ SDL.mouseMotionEventPos dat)
) (SDL.mouseMotionEventRelMotion dat)
doConsume es )
SDL.MouseButtonEvent dat -> do doConsume es
partEmit am (MsgMouseButton SDL.MouseButtonEvent dat -> do
(SDL.eventTimestamp e) partEmit am (MsgMouseButton
(SDL.mouseButtonEventWindow dat) ts
(SDL.mouseButtonEventWhich dat) (SDL.mouseButtonEventWindow dat)
(SDL.mouseButtonEventButton dat) (SDL.mouseButtonEventWhich dat)
(SDL.mouseButtonEventClicks dat) (SDL.mouseButtonEventButton dat)
(unP $ SDL.mouseButtonEventPos dat) (SDL.mouseButtonEventClicks dat)
) (unP $ SDL.mouseButtonEventPos dat)
doConsume es )
SDL.MouseWheelEvent dat -> do doConsume es
partEmit am (MsgMouseWheel SDL.MouseWheelEvent dat -> do
(SDL.eventTimestamp e) partEmit am (MsgMouseWheel
(SDL.mouseWheelEventWindow dat) ts
(SDL.mouseWheelEventWhich dat) (SDL.mouseWheelEventWindow dat)
(SDL.mouseWheelEventPos dat) (SDL.mouseWheelEventWhich dat)
(SDL.mouseWheelEventDirection dat) (SDL.mouseWheelEventPos dat)
) (SDL.mouseWheelEventDirection dat)
doConsume es )
_ -> fmap (e :) (doConsume es) doConsume es
_ -> fmap (e :) (doConsume es)

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
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do case e of
partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window) SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
doConsume es partEmit aw (MsgWindowShow ts window)
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do doConsume es
partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window) SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
doConsume es partEmit aw (MsgWindowHide ts window)
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do doConsume es
partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window) SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
doConsume es partEmit aw (MsgWindowExpose ts window)
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do doConsume es
partEmit aw (MsgWindowMove (SDL.eventTimestamp e) window newPos) SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
doConsume es partEmit aw (MsgWindowMove ts window newPos)
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do doConsume es
partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize) SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
doConsume es partEmit aw (MsgWindowResize ts window newSize)
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do doConsume es
partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window) SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
doConsume es partEmit aw (MsgWindowSizeChange ts window)
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do doConsume es
partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window) SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
doConsume es partEmit aw (MsgWindowMinimize ts window)
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do doConsume es
partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window) SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
doConsume es partEmit aw (MsgWindowMaximize ts window)
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do doConsume es
partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window) SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
doConsume es partEmit aw (MsgWindowRestore ts window)
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do doConsume es
partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window) SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
doConsume es partEmit aw (MsgWindowGainMouseFocus ts window)
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do doConsume es
partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window) SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
doConsume es partEmit aw (MsgWindowLoseMouseFocus ts window)
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do doConsume es
partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window) SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
doConsume es partEmit aw (MsgWindowGainKeyboardFocus ts window)
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do doConsume es
partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window) SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
doConsume es partEmit aw (MsgWindowLoseKeyboardFocus ts window)
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do doConsume es
partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window) SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
doConsume es partEmit aw (MsgWindowClose ts window)
_ -> fmap (e :) (doConsume es) 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.
} }