still won't work
This commit is contained in:
nek0
parent
1cbda31499
commit
78f058db6b
15 changed files with 239 additions and 263 deletions
|
|
@ -70,6 +70,7 @@ library
|
|||
, Affection.MessageBus.Message.WindowMessage
|
||||
, Affection.MessageBus.Message.KeyboardMessage
|
||||
, Affection.MessageBus.Message.MouseMessage
|
||||
, Affection.Subsystems
|
||||
, Affection.Subsystems.Class
|
||||
, Affection.Subsystems.AffectionWindow
|
||||
, Affection.Subsystems.AffectionKeyboard
|
||||
|
|
@ -104,23 +105,26 @@ library
|
|||
, stm
|
||||
, uuid
|
||||
|
||||
-- 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 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 example01
|
||||
-- hs-source-dirs: examples
|
||||
-- main-is: example01.hs
|
||||
|
|
@ -209,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
|
||||
|
|
|
|||
|
|
@ -1,117 +1,71 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
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 Foreign.Storable (peek)
|
||||
import Foreign.C.Types (CInt(..))
|
||||
data StateData = StateData
|
||||
{ sdSubs :: Subsystems
|
||||
}
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
-- main :: IO ()
|
||||
-- main = withAllAffection $
|
||||
-- withDefaultWindow "test" $ do
|
||||
-- changeColor $ RGBA 255 255 255 255
|
||||
-- clear
|
||||
-- present
|
||||
-- liftIO $ delaySec 2
|
||||
data Subsystems = Subsystems
|
||||
{ subWindow :: AffectionWindow StateData
|
||||
, subMouse :: AffectionMouse StateData
|
||||
, subKeyboard :: AffectionKeyboard StateData
|
||||
}
|
||||
|
||||
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 ()
|
||||
, 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
|
||||
(AffectionWindow empty1)
|
||||
(AffectionMouse empty2)
|
||||
(AffectionKeyboard 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 -> quit
|
||||
otherwise -> 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 ()
|
||||
|
|
|
|||
|
|
@ -24,6 +24,9 @@ import Affection.StateMachine as A
|
|||
import Affection.MouseInteractable as A
|
||||
import Affection.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(..))
|
||||
|
||||
|
|
@ -45,7 +48,7 @@ withAffection AffectionConfig{..} = do
|
|||
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
|
||||
|
|
@ -94,7 +97,8 @@ withAffection AffectionConfig{..} = do
|
|||
}
|
||||
-- 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
|
||||
|
|
|
|||
|
|
@ -1,7 +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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
module Affection.MessageBus.Class
|
||||
( Participant(..)
|
||||
, genUUID
|
||||
|
|
@ -26,7 +26,7 @@ class (Show m, Message m) => Participant prt m where
|
|||
-- | Subscribe to the 'Participant''s events
|
||||
partSubscribe
|
||||
:: 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)
|
||||
-> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function
|
||||
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@ module Affection.MessageBus.Message.Class where
|
|||
import Data.Word (Word32(..))
|
||||
|
||||
class Message msg where
|
||||
msgTime :: msg -> Word32
|
||||
msgTime :: msg -> Double
|
||||
|
|
|
|||
|
|
@ -2,12 +2,10 @@ module Affection.MessageBus.Message.KeyboardMessage where
|
|||
|
||||
import Affection.MessageBus.Message.Class
|
||||
|
||||
import Data.Word (Word32(..))
|
||||
|
||||
import qualified SDL
|
||||
|
||||
data KeyboardMessage = MsgKeyboardEvent
|
||||
{ msgKbdWhen :: Word32
|
||||
{ msgKbdWhen :: Double
|
||||
, msgKbdWindow :: Maybe SDL.Window
|
||||
, msgKbdKeyMotion :: SDL.InputMotion
|
||||
, msgKbdLeyRepeat :: Bool
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ module Affection.MessageBus.Message.MouseMessage where
|
|||
|
||||
import Affection.MessageBus.Message.Class
|
||||
|
||||
import Data.Word (Word32(..), Word8(..))
|
||||
import Data.Word (Word8(..))
|
||||
import Data.Int (Int32(..))
|
||||
|
||||
import qualified SDL
|
||||
|
|
@ -11,7 +11,7 @@ import Linear (V2(..))
|
|||
|
||||
data MouseMessage
|
||||
= MsgMouseMotion
|
||||
{ msgMMWhen :: Word32
|
||||
{ msgMMWhen :: Double
|
||||
, msgMMWindow :: Maybe SDL.Window
|
||||
, msgMMWhich :: SDL.MouseDevice
|
||||
, msgMMState :: [SDL.MouseButton]
|
||||
|
|
@ -19,7 +19,7 @@ data MouseMessage
|
|||
, msgMMRelMotion :: V2 Int32
|
||||
}
|
||||
| MsgMouseButton
|
||||
{ msgMBWhen :: Word32
|
||||
{ msgMBWhen :: Double
|
||||
, msgMBWindow :: Maybe SDL.Window
|
||||
, msgMBWhich :: SDL.MouseDevice
|
||||
, msgMBButton :: SDL.MouseButton
|
||||
|
|
@ -27,7 +27,7 @@ data MouseMessage
|
|||
, msgMBPos :: V2 Int32
|
||||
}
|
||||
| MsgMouseWheel
|
||||
{ msgMWWhen :: Word32
|
||||
{ msgMWWhen :: Double
|
||||
, msgMWWhindow :: Maybe SDL.Window
|
||||
, msgMWWhich :: SDL.MouseDevice
|
||||
, msgMWPos :: V2 Int32
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@ module Affection.MessageBus.Message.WindowMessage where
|
|||
|
||||
import Affection.MessageBus.Message.Class
|
||||
|
||||
import Data.Word (Word32(..))
|
||||
import Data.Int (Int32(..))
|
||||
|
||||
import qualified SDL
|
||||
|
|
@ -10,63 +9,63 @@ import qualified SDL
|
|||
import Linear (V2(..))
|
||||
|
||||
data WindowMessage
|
||||
-- = MsgEngineReady Word32
|
||||
-- = MsgEngineReady Double
|
||||
= MsgWindowShow
|
||||
{ msgWSWhen :: Word32
|
||||
{ msgWSWhen :: Double
|
||||
, msgWSWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowHide
|
||||
{ msgWHWhen :: Word32
|
||||
{ msgWHWhen :: Double
|
||||
, msgWHWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowExpose
|
||||
{ msgWEWhen :: Word32
|
||||
{ msgWEWhen :: Double
|
||||
, msgWEWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowMove
|
||||
{ msgWMWhen :: Word32
|
||||
{ msgWMWhen :: Double
|
||||
, msgWMWindow :: SDL.Window
|
||||
, msgWMNewPos :: V2 Int32
|
||||
}
|
||||
| MsgWindowResize
|
||||
{ msgWRWhen :: Word32
|
||||
{ msgWRWhen :: Double
|
||||
, msgWRWindow :: SDL.Window
|
||||
, msgWRNewSize :: V2 Int32
|
||||
}
|
||||
| MsgWindowSizeChange
|
||||
{ msgWSCWhen :: Word32
|
||||
{ msgWSCWhen :: Double
|
||||
, msgWSCWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowMinimize
|
||||
{ msgWMinWhen :: Word32
|
||||
{ msgWMinWhen :: Double
|
||||
, msgWMinWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowMaximize
|
||||
{ msgWMaxWhen :: Word32
|
||||
{ msgWMaxWhen :: Double
|
||||
, msgWMaxWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowRestore
|
||||
{ msgWRestWhen :: Word32
|
||||
{ msgWRestWhen :: Double
|
||||
, msgWRestWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowGainMouseFocus
|
||||
{ msgWGMFWhen :: Word32
|
||||
{ msgWGMFWhen :: Double
|
||||
, msgWGMFWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowLoseMouseFocus
|
||||
{ msgWLMFWhen :: Word32
|
||||
{ msgWLMFWhen :: Double
|
||||
, msgWLMFWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowGainKeyboardFocus
|
||||
{ msgWGKFWhen :: Word32
|
||||
{ msgWGKFWhen :: Double
|
||||
, msgWGKFWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowLoseKeyboardFocus
|
||||
{ msgWLKFWhen :: Word32
|
||||
{ msgWLKFWhen :: Double
|
||||
, msgWLKFWindow :: SDL.Window
|
||||
}
|
||||
| MsgWindowClose
|
||||
{ msgWCWhen :: Word32
|
||||
{ msgWCWhen :: Double
|
||||
, msgWCWindow :: SDL.Window
|
||||
}
|
||||
deriving (Show)
|
||||
|
|
|
|||
8
src/Affection/Subsystems.hs
Normal file
8
src/Affection/Subsystems.hs
Normal 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
|
||||
|
|
@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionKeyboard where
|
|||
import Affection.MessageBus
|
||||
import Affection.Subsystems.Class
|
||||
import Affection.Types
|
||||
import Affection.Util
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Concurrent.STM as STM
|
||||
|
|
@ -30,13 +31,14 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where
|
|||
return $ map snd subTups
|
||||
|
||||
instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where
|
||||
consumeSDLEvents ak evs = doConsume evs
|
||||
consumeSDLEvents ak eps = doConsume eps
|
||||
where
|
||||
doConsume [] = return []
|
||||
doConsume (e:es) = case SDL.eventPayload e of
|
||||
doConsume (e:es) = do
|
||||
ts <- getElapsedTime
|
||||
case e of
|
||||
SDL.KeyboardEvent dat -> do
|
||||
partEmit ak (MsgKeyboardEvent
|
||||
(SDL.eventTimestamp e)
|
||||
ts
|
||||
(SDL.keyboardEventWindow dat)
|
||||
(SDL.keyboardEventKeyMotion dat)
|
||||
(SDL.keyboardEventRepeat dat)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ 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
|
||||
|
|
@ -32,13 +33,14 @@ instance Participant (AffectionMouse sd) MouseMessage where
|
|||
return $ map snd subTups
|
||||
|
||||
instance SDLSubsystem (AffectionMouse sd) MouseMessage where
|
||||
consumeSDLEvents am evs = doConsume evs
|
||||
consumeSDLEvents am eps = doConsume eps
|
||||
where
|
||||
doConsume [] = return []
|
||||
doConsume (e:es) = case SDL.eventPayload e of
|
||||
doConsume (e:es) = do
|
||||
ts <- getElapsedTime
|
||||
case e of
|
||||
SDL.MouseMotionEvent dat -> do
|
||||
partEmit am (MsgMouseMotion
|
||||
(SDL.eventTimestamp e)
|
||||
ts
|
||||
(SDL.mouseMotionEventWindow dat)
|
||||
(SDL.mouseMotionEventWhich dat)
|
||||
(SDL.mouseMotionEventState dat)
|
||||
|
|
@ -48,7 +50,7 @@ instance SDLSubsystem (AffectionMouse sd) MouseMessage where
|
|||
doConsume es
|
||||
SDL.MouseButtonEvent dat -> do
|
||||
partEmit am (MsgMouseButton
|
||||
(SDL.eventTimestamp e)
|
||||
ts
|
||||
(SDL.mouseButtonEventWindow dat)
|
||||
(SDL.mouseButtonEventWhich dat)
|
||||
(SDL.mouseButtonEventButton dat)
|
||||
|
|
@ -58,7 +60,7 @@ instance SDLSubsystem (AffectionMouse sd) MouseMessage where
|
|||
doConsume es
|
||||
SDL.MouseWheelEvent dat -> do
|
||||
partEmit am (MsgMouseWheel
|
||||
(SDL.eventTimestamp e)
|
||||
ts
|
||||
(SDL.mouseWheelEventWindow dat)
|
||||
(SDL.mouseWheelEventWhich dat)
|
||||
(SDL.mouseWheelEventPos dat)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
module Affection.Subsystems.AffectionWindow where
|
||||
|
||||
import Affection.Types
|
||||
import Affection.Util
|
||||
import Affection.MessageBus
|
||||
import Affection.Subsystems.Class
|
||||
|
||||
|
|
@ -30,50 +31,51 @@ instance Participant (AffectionWindow sd) WindowMessage where
|
|||
return $ map snd subTups
|
||||
|
||||
instance SDLSubsystem (AffectionWindow sd) WindowMessage where
|
||||
consumeSDLEvents aw evs = doConsume evs
|
||||
consumeSDLEvents aw eps = doConsume eps
|
||||
where
|
||||
doConsume [] = return []
|
||||
doConsume (e:es) = case SDL.eventPayload e of
|
||||
doConsume (e:es) = do
|
||||
ts <- getElapsedTime
|
||||
case e of
|
||||
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
|
||||
partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowShow ts window)
|
||||
doConsume es
|
||||
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
|
||||
partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowHide ts window)
|
||||
doConsume es
|
||||
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
|
||||
partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowExpose ts window)
|
||||
doConsume es
|
||||
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
|
||||
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
|
||||
partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize)
|
||||
partEmit aw (MsgWindowResize ts window newSize)
|
||||
doConsume es
|
||||
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
|
||||
partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowSizeChange ts window)
|
||||
doConsume es
|
||||
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
|
||||
partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowMinimize ts window)
|
||||
doConsume es
|
||||
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
|
||||
partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowMaximize ts window)
|
||||
doConsume es
|
||||
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
|
||||
partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowRestore ts window)
|
||||
doConsume es
|
||||
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
|
||||
partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowGainMouseFocus ts window)
|
||||
doConsume es
|
||||
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
|
||||
partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowLoseMouseFocus ts window)
|
||||
doConsume es
|
||||
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
|
||||
partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowGainKeyboardFocus ts window)
|
||||
doConsume es
|
||||
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
|
||||
partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowLoseKeyboardFocus ts window)
|
||||
doConsume es
|
||||
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
|
||||
partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window)
|
||||
partEmit aw (MsgWindowClose ts window)
|
||||
doConsume es
|
||||
_ -> fmap (e :) (doConsume es)
|
||||
|
|
|
|||
|
|
@ -8,4 +8,4 @@ import Affection.MessageBus
|
|||
import qualified SDL
|
||||
|
||||
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]
|
||||
|
|
|
|||
|
|
@ -64,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.
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in a new issue