From dd4e048652f0facabee8a75344572c5efc6cd829 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 8 Oct 2018 18:54:23 +0200 Subject: [PATCH] prepare for joypad control --- src/Init.hs | 7 +++-- src/Main.hs | 5 ++-- src/MainGame/WorldMap.hs | 2 +- src/StateMachine.hs | 12 +++++--- src/Types/UserData.hs | 62 ++++++++++++++++++++++++---------------- 5 files changed, 54 insertions(+), 34 deletions(-) diff --git a/src/Init.hs b/src/Init.hs index 80ae01a..aa2bb25 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -28,9 +28,10 @@ foreign import ccall unsafe "glewInit" init :: IO UserData init = do subs <- Subsystems - <$> (Window <$> newTVarIO []) - <*> (Mouse <$> newTVarIO []) - <*> (Keyboard <$> newTVarIO []) + <$> (SubWindow <$> newTVarIO []) + <*> (SubMouse <$> newTVarIO []) + <*> (SubKeyboard <$> newTVarIO []) + <*> (SubJoypad <$> newTVarIO []) _ <- glewInit nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) return UserData diff --git a/src/Main.hs b/src/Main.hs index a835921..811f694 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -56,7 +56,7 @@ pre = do -- _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 threadCtx <- SDL.glCreateContext (drawWindow ad) SDL.glMakeCurrent (drawWindow ad) (glContext ad) - let Subsystems w m k = subsystems ud + let Subsystems w m k j = subsystems ud _ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w exitOnWindowClose _ <- partSubscribe k toggleFullScreen @@ -75,10 +75,11 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym) ad <- A.get ud <- getAffection when (state ud == Main WorldMap || state ud == Main MindMap) $ do - let Subsystems w m k = subsystems ud + let Subsystems w m k j = subsystems ud mapM_ (partUnSubscribe w) (uuid ud) mapM_ (partUnSubscribe m) (uuid ud) mapM_ (partUnSubscribe k) (uuid ud) + mapM_ (partUnSubscribe j) (uuid ud) SDL.glMakeCurrent (drawWindow ad) (glContext ad) (ws, _) <- yieldSystemT (0, defStorage) (return ()) putAffection ud diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 1fea1e1..d381e02 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -45,7 +45,7 @@ loadMap :: Affection UserData () loadMap = do ud <- getAffection ad <- get - let (Subsystems _ m k) = subsystems ud + let (Subsystems _ m k _) = subsystems ud uu1 <- partSubscribe m movePlayer uu2 <- partSubscribe k changeMaps uu3 <- partSubscribe m playerInteract diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 85f95a3..9f437ea 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -26,18 +26,22 @@ instance StateMachine State UserData where smDraw Load = drawLoad smEvent _ evs = do - Subsystems w m k <- subsystems <$> getAffection - _ <- consumeSDLEvents k =<< consumeSDLEvents w =<< consumeSDLEvents m evs + Subsystems w m k j <- subsystems <$> getAffection + _ <- consumeSDLEvents j =<< + consumeSDLEvents k =<< + consumeSDLEvents w =<< + consumeSDLEvents m evs return () smClean _ = do ud <- getAffection - let Subsystems w m k = subsystems ud - toClean = uuid ud + let Subsystems w m k j = subsystems ud + toClean = uuid ud mapM_ (\u -> do partUnSubscribe w u partUnSubscribe m u partUnSubscribe k u + partUnSubscribe j u ) toClean putAffection ud { uuid = [] diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 2977e12..dd85270 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -53,51 +53,65 @@ data SubMain deriving (Eq) data Subsystems = Subsystems - { subWindow :: Types.UserData.Window - , subMouse :: Mouse - , subkeyboard :: Keyboard + { subWindow :: SubWindow + , subMouse :: SubMouse + , subkeyboard :: SubKeyboard + , subJoypad :: SubJoypad } -newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())]) -newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) -newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) +newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())]) +newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) +newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) +newtype SubJoypad = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())]) -instance Participant Types.UserData.Window UserData where - type Mesg Types.UserData.Window UserData = WindowMessage +instance Participant SubWindow UserData where + type Mesg SubWindow UserData = WindowMessage - partSubscribers (Window t) = generalSubscribers t + partSubscribers (SubWindow t) = generalSubscribers t - partSubscribe (Window t) = generalSubscribe t + partSubscribe (SubWindow t) = generalSubscribe t - partUnSubscribe (Window t) = generalUnSubscribe t + partUnSubscribe (SubWindow t) = generalUnSubscribe t -instance SDLSubsystem Types.UserData.Window UserData where +instance SDLSubsystem SubWindow UserData where consumeSDLEvents = consumeSDLWindowEvents -instance Participant Mouse UserData where - type Mesg Mouse UserData = MouseMessage +instance Participant SubMouse UserData where + type Mesg SubMouse UserData = MouseMessage - partSubscribers (Mouse t) = generalSubscribers t + partSubscribers (SubMouse t) = generalSubscribers t - partSubscribe (Mouse t) = generalSubscribe t + partSubscribe (SubMouse t) = generalSubscribe t - partUnSubscribe (Mouse t) = generalUnSubscribe t + partUnSubscribe (SubMouse t) = generalUnSubscribe t -instance SDLSubsystem Mouse UserData where +instance SDLSubsystem SubMouse UserData where consumeSDLEvents = consumeSDLMouseEvents -instance Participant Keyboard UserData where - type Mesg Keyboard UserData = KeyboardMessage +instance Participant SubKeyboard UserData where + type Mesg SubKeyboard UserData = KeyboardMessage - partSubscribers (Keyboard t) = generalSubscribers t + partSubscribers (SubKeyboard t) = generalSubscribers t - partSubscribe (Keyboard t) = generalSubscribe t + partSubscribe (SubKeyboard t) = generalSubscribe t - partUnSubscribe (Keyboard t) = generalUnSubscribe t + partUnSubscribe (SubKeyboard t) = generalUnSubscribe t -instance SDLSubsystem Keyboard UserData where +instance SDLSubsystem SubKeyboard UserData where consumeSDLEvents = consumeSDLKeyboardEvents +instance Participant SubJoypad UserData where + type Mesg SubJoypad UserData = JoystickMessage + + partSubscribers (SubJoypad t) = generalSubscribers t + + partSubscribe (SubJoypad t) = generalSubscribe t + + partUnSubscribe (SubJoypad t) = generalUnSubscribe t + +instance SDLSubsystem SubJoypad UserData where + consumeSDLEvents = consumeSDLJoystickEvents + generalSubscribers :: TVar [(UUID, msg -> Affection UserData ())] -> Affection UserData [(msg -> Affection UserData ())]