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 subs <- Subsystems
<$> (Window <$> newTVarIO []) <$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO []) <*> (Mouse <$> newTVarIO [])
<*> (Keyboard <$> newTVarIO [])
_ <- glewInit _ <- glewInit
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) 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 -- _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
threadContext <- SDL.glCreateContext (drawWindow ad) threadContext <- SDL.glCreateContext (drawWindow ad)
SDL.glMakeCurrent (drawWindow ad) (glContext 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 (fitViewport (1280/720))
_ <- partSubscribe w exitOnWindowClose _ <- partSubscribe w exitOnWindowClose
putAffection ud putAffection ud

View file

@ -23,17 +23,18 @@ instance StateMachine State UserData where
smDraw Load = drawLoad smDraw Load = drawLoad
smEvent _ evs = do smEvent _ evs = do
Subsystems w m <- subsystems <$> getAffection Subsystems w m k <- subsystems <$> getAffection
_ <- consumeSDLEvents w =<< consumeSDLEvents m evs _ <- consumeSDLEvents k =<< consumeSDLEvents w =<< consumeSDLEvents m evs
return () return ()
smClean _ = do smClean _ = do
ud <- getAffection ud <- getAffection
let Subsystems w m = subsystems ud let Subsystems w m k = subsystems ud
toClean = uuid ud toClean = uuid ud
mapM_ (\u -> do mapM_ (\u -> do
partUnSubscribe w u partUnSubscribe w u
partUnSubscribe m u partUnSubscribe m u
partUnSubscribe k u
) toClean ) toClean
putAffection ud putAffection ud
{ uuid = [] { uuid = []

View file

@ -35,7 +35,7 @@ import NPC
loadMap :: Affection UserData () loadMap :: Affection UserData ()
loadMap = do loadMap = do
ud <- getAffection ud <- getAffection
let (Subsystems _ m) = subsystems ud let (Subsystems _ m k) = subsystems ud
ctx = nano ud ctx = nano ud
uu <- partSubscribe m movePlayer uu <- partSubscribe m movePlayer
future <- liftIO $ newEmptyMVar future <- liftIO $ newEmptyMVar

View file

@ -70,12 +70,14 @@ data NPCState
} }
data Subsystems = Subsystems data Subsystems = Subsystems
{ subWindow :: Window { subWindow :: Window
, subMouse :: Mouse , subMouse :: Mouse
, subkeyboard :: Keyboard
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Window UserData where instance Participant Window UserData where
type Mesg Window UserData = WindowMessage type Mesg Window UserData = WindowMessage
@ -101,6 +103,18 @@ instance Participant Mouse UserData where
instance SDLSubsystem Mouse UserData where instance SDLSubsystem Mouse UserData where
consumeSDLEvents = consumeSDLMouseEvents 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 generalSubscribers
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection UserData ())]
-> Affection UserData [(msg -> Affection UserData ())] -> Affection UserData [(msg -> Affection UserData ())]