prepare for joypad control

This commit is contained in:
nek0 2018-10-08 18:54:23 +02:00
parent 3c016bbb17
commit dd4e048652
5 changed files with 54 additions and 34 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 = []

View file

@ -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 ())]