now with joystick support

This commit is contained in:
nek0 2018-01-09 18:40:54 +01:00
parent 2ff97b7c66
commit 276966f80d
6 changed files with 228 additions and 29 deletions

View file

@ -6,7 +6,7 @@ name: affection
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
version: 0.0.0.8
version: 0.0.0.9
synopsis: A simple Game Engine using SDL
description: This package contains Affection, a simple game engine
written in Haskell using SDL.
@ -78,11 +78,13 @@ library
, Affection.MessageBus.Message.WindowMessage
, Affection.MessageBus.Message.KeyboardMessage
, Affection.MessageBus.Message.MouseMessage
, Affection.MessageBus.Message.JoystickMessage
, Affection.Subsystems
, Affection.Subsystems.Class
, Affection.Subsystems.AffectionWindow
, Affection.Subsystems.AffectionKeyboard
, Affection.Subsystems.AffectionMouse
, Affection.Subsystems.AffectionJoystick
default-extensions: OverloadedStrings
-- Modules included in this library but not exported.
@ -112,6 +114,7 @@ library
, OpenGL
, stm
, uuid
, vector
-- This example shows the message system. only makes sense when compiling with
-- verbose flag.

View file

@ -6,20 +6,33 @@ import qualified SDL
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)
newtype StateData = StateData
import Data.Maybe (isJust, fromJust)
data StateData = StateData
{ sdSubs :: Subsystems
, sdJoys :: [SDL.Joystick]
}
data Subsystems = Subsystems
{ subWindow :: Window
, subMouse :: Mouse
, subKeyboard :: Keyboard
, subJoystick :: Joystick
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
generalSubscribers
:: TVar [(UUID, msg -> Affection StateData ())]
-> Affection StateData [msg -> Affection StateData ()]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
@ -30,17 +43,21 @@ generalSubscribe t funct = do
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> UUID
-> Affection StateData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance Participant Window StateData where
type Mesg Window StateData = WindowMessage
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribers (Window t) = generalSubscribers t
partSubscribe (Window t) = generalSubscribe t
partUnSubscribe (Window t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Window StateData where
consumeSDLEvents = consumeSDLWindowEvents
@ -48,14 +65,11 @@ instance SDLSubsystem Window StateData where
instance Participant Mouse StateData where
type Mesg Mouse StateData = MouseMessage
partSubscribers (Mouse t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribers (Mouse t) = generalSubscribers t
partSubscribe (Mouse t) = generalSubscribe t
partUnSubscribe (Mouse t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
partUnSubscribe (Mouse t) = generalUnSubscribe t
instance SDLSubsystem Mouse StateData where
consumeSDLEvents = consumeSDLMouseEvents
@ -63,18 +77,27 @@ instance SDLSubsystem Mouse StateData where
instance Participant Keyboard StateData where
type Mesg Keyboard StateData = KeyboardMessage
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribers (Keyboard t) = generalSubscribers t
partSubscribe (Keyboard t) = generalSubscribe t
partUnSubscribe (Keyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents
instance Participant Joystick StateData where
type Mesg Joystick StateData = JoystickMessage
partSubscribers (Joystick t) = generalSubscribers t
partSubscribe (Joystick t) = generalSubscribe t
partUnSubscribe (Joystick t) = generalUnSubscribe t
instance SDLSubsystem Joystick StateData where
consumeSDLEvents = consumeSDLJoystickEvents
main :: IO ()
main = do
logIO Debug "Starting"
@ -98,20 +121,21 @@ main = do
withAffection conf
load :: IO StateData
load = do
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
return $ StateData $ Subsystems
(Window empty1)
(Mouse empty2)
(Keyboard empty3)
load =
StateData <$> (Subsystems
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
<*> (Keyboard <$> newTVarIO [])
<*> (Joystick <$> newTVarIO [])
)
<*> return []
pre :: Affection StateData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
_ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
_ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
return ()
exitOnQ :: KeyboardMessage -> Affection StateData ()
@ -130,12 +154,28 @@ exitOnWindowClose wm =
quit
_ -> return ()
joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
joyConnectDisconnect msg = do
mj <- joystickAutoConnect msg
when (isJust mj) $ do
sd <- getAffection
putAffection sd
{ sdJoys = fromJust mj : sdJoys sd
}
sd <- getAffection
njs <- joystickAutoDisconnect (sdJoys sd) msg
putAffection sd
{ sdJoys = njs
}
handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
(Subsystems a b c) <- sdSubs <$> getAffection
_ <- consumeSDLEvents a es
_ <- consumeSDLEvents b es
_ <- consumeSDLEvents c es
(Subsystems a b c d) <- sdSubs <$> getAffection
leftovers <- consumeSDLEvents a
=<< consumeSDLEvents b
=<< consumeSDLEvents c
=<< consumeSDLEvents d es
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
return ()
update _ = return ()

View file

@ -6,3 +6,4 @@ import Affection.MessageBus.Message.Class as M
import Affection.MessageBus.Message.WindowMessage as M
import Affection.MessageBus.Message.KeyboardMessage as M
import Affection.MessageBus.Message.MouseMessage as M
import Affection.MessageBus.Message.JoystickMessage as M

View file

@ -0,0 +1,60 @@
module Affection.MessageBus.Message.JoystickMessage
( JoystickMessage(..)
-- | SDL exports
, SDL.V2
, SDL.JoyHatPosition
, SDL.JoyButtonState
, SDL.JoyDeviceConnection
-- | Number exports
, Word8(..)
, Int16(..)
, Int32(..)
) where
import Affection.MessageBus.Message.Class
import Data.Word (Word8(..))
import Data.Int (Int32(..), Int16(..))
import qualified SDL
import Linear (V2(..))
data JoystickMessage
= MsgJoystickAxis
{ msgJAWhen :: Double
, msgJAWhich :: Int32
, msgJAAxis :: Word8
, msgJAValue :: Int16
}
| MsgJoystickBall
{ msgJBWhen :: Double
, msgJBWhich :: Int32
, msgJBBall :: Word8
, msgJBRelMotion :: SDL.V2 Int16
}
| MsgJoystickHat
{ msgJHWhen :: Double
, msgJHWhich :: Int32
, msgJHHat :: Word8
, msgJHPosition :: SDL.JoyHatPosition
}
| MsgJoystickButton
{ msgJBWhen :: Double
, msgJBWhich :: Int32
, msgJBButton :: Word8
, msgJBState :: SDL.JoyButtonState
}
| MsgJoystickDevice
{ msgJDWhen :: Double
, msgJDWhich :: Int32
, msgJDConnection :: SDL.JoyDeviceConnection
}
deriving (Show)
instance Message JoystickMessage where
msgTime (MsgJoystickAxis t _ _ _) = t
msgTime (MsgJoystickBall t _ _ _) = t
msgTime (MsgJoystickHat t _ _ _) = t
msgTime (MsgJoystickButton t _ _ _) = t
msgTime (MsgJoystickDevice t _ _) = t

View file

@ -6,3 +6,4 @@ import Affection.Subsystems.Class as S
import Affection.Subsystems.AffectionKeyboard as S
import Affection.Subsystems.AffectionWindow as S
import Affection.Subsystems.AffectionMouse as S
import Affection.Subsystems.AffectionJoystick as S

View file

@ -0,0 +1,94 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Affection.Subsystems.AffectionJoystick where
import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types
import Affection.Util
import Affection.Logging
import Control.Monad (filterM)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import qualified Data.Vector as V
import Foreign.C.Types (CInt(..))
import qualified SDL
consumeSDLJoystickEvents
:: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
=> am
-> [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
consumeSDLJoystickEvents am = doConsume
where
doConsume
:: [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
doConsume [] = return []
doConsume (e:es) = do
ts <- getElapsedTime
case e of
SDL.JoyAxisEvent dat -> do
partEmit am (MsgJoystickAxis
ts
(SDL.joyAxisEventWhich dat)
(SDL.joyAxisEventAxis dat)
(SDL.joyAxisEventValue dat)
)
doConsume es
SDL.JoyBallEvent dat -> do
partEmit am (MsgJoystickBall
ts
(SDL.joyBallEventWhich dat)
(SDL.joyBallEventBall dat)
(SDL.joyBallEventRelMotion dat)
)
doConsume es
SDL.JoyHatEvent dat -> do
partEmit am (MsgJoystickHat
ts
(SDL.joyHatEventWhich dat)
(SDL.joyHatEventHat dat)
(SDL.joyHatEventValue dat)
)
doConsume es
SDL.JoyButtonEvent dat -> do
partEmit am (MsgJoystickButton
ts
(SDL.joyButtonEventWhich dat)
(SDL.joyButtonEventButton dat)
(SDL.joyButtonEventState dat)
)
doConsume es
SDL.JoyDeviceEvent dat -> do
partEmit am (MsgJoystickDevice
ts
(SDL.joyDeviceEventWhich dat)
(SDL.joyDeviceEventConnection dat)
)
doConsume es
_ -> fmap (e :) (doConsume es)
joystickAutoConnect :: JoystickMessage -> Affection us (Maybe SDL.Joystick)
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
[descr] <- V.toList <$>
(return . V.filter (\(SDL.JoystickDevice _ id) -> id == CInt which)
=<< SDL.availableJoysticks)
logIO Verbose $ "Connecting Joystick " ++ show which
Just <$> SDL.openJoystick descr
joystickAutoConnect _ = return Nothing
joystickAutoDisconnect :: [SDL.Joystick] -> JoystickMessage -> Affection us [SDL.Joystick]
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
liftIO $ do
[disc] <- filterM (\j -> return . (which ==) =<< SDL.getJoystickID j) js
logIO Verbose $ "Disconnecting Joystick " ++ show which
SDL.closeJoystick disc
filterM (\j -> return . (which /=) =<< SDL.getJoystickID j) js
joystickAutoDisconnect js _ = return js