From 3bc1b5e5c7fb347ee454625dc06b92f476e2a03a Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 24 Jun 2018 00:42:39 +0200 Subject: [PATCH] preparing for keyboard input --- src/Init.hs | 1 + src/Main.hs | 2 +- src/StateMachine.hs | 9 +++++---- src/Test.hs | 2 +- src/Types/UserData.hs | 18 ++++++++++++++++-- 5 files changed, 24 insertions(+), 8 deletions(-) diff --git a/src/Init.hs b/src/Init.hs index 4307186..fa6a135 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -46,6 +46,7 @@ init = do subs <- Subsystems <$> (Window <$> newTVarIO []) <*> (Mouse <$> newTVarIO []) + <*> (Keyboard <$> newTVarIO []) _ <- glewInit (ws, _) <- yieldSystemT (0, defStorage) (return ()) nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) diff --git a/src/Main.hs b/src/Main.hs index 9066b1a..92da103 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -50,7 +50,7 @@ pre = do -- _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 threadContext <- SDL.glCreateContext (drawWindow ad) SDL.glMakeCurrent (drawWindow ad) (glContext ad) - Subsystems w m <- subsystems <$> getAffection + Subsystems w m k <- subsystems <$> getAffection _ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w exitOnWindowClose putAffection ud diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 221b15f..3150d1e 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -23,17 +23,18 @@ instance StateMachine State UserData where smDraw Load = drawLoad smEvent _ evs = do - Subsystems w m <- subsystems <$> getAffection - _ <- consumeSDLEvents w =<< consumeSDLEvents m evs + Subsystems w m k <- subsystems <$> getAffection + _ <- consumeSDLEvents k =<< consumeSDLEvents w =<< consumeSDLEvents m evs return () smClean _ = do ud <- getAffection - let Subsystems w m = subsystems ud - toClean = uuid ud + let Subsystems w m k = subsystems ud + toClean = uuid ud mapM_ (\u -> do partUnSubscribe w u partUnSubscribe m u + partUnSubscribe k u ) toClean putAffection ud { uuid = [] diff --git a/src/Test.hs b/src/Test.hs index 2511a2f..57ac77e 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -35,7 +35,7 @@ import NPC loadMap :: Affection UserData () loadMap = do ud <- getAffection - let (Subsystems _ m) = subsystems ud + let (Subsystems _ m k) = subsystems ud ctx = nano ud uu <- partSubscribe m movePlayer future <- liftIO $ newEmptyMVar diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index ab2628c..5b47fb6 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -70,12 +70,14 @@ data NPCState } data Subsystems = Subsystems - { subWindow :: Window - , subMouse :: Mouse + { subWindow :: Window + , subMouse :: Mouse + , subkeyboard :: Keyboard } newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())]) newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) instance Participant Window UserData where type Mesg Window UserData = WindowMessage @@ -101,6 +103,18 @@ instance Participant Mouse UserData where instance SDLSubsystem Mouse UserData where consumeSDLEvents = consumeSDLMouseEvents +instance Participant Keyboard UserData where + type Mesg Keyboard UserData = KeyboardMessage + + partSubscribers (Keyboard t) = generalSubscribers t + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) = generalUnSubscribe t + +instance SDLSubsystem Keyboard UserData where + consumeSDLEvents = consumeSDLKeyboardEvents + generalSubscribers :: TVar [(UUID, msg -> Affection UserData ())] -> Affection UserData [(msg -> Affection UserData ())]