preparing for keyboard input

This commit is contained in:
nek0 2018-06-24 00:42:39 +02:00
parent 21461ade1f
commit 3bc1b5e5c7
5 changed files with 24 additions and 8 deletions

View file

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

View file

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

View file

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

View file

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

View file

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