diff --git a/affection.cabal b/affection.cabal index 64d1d7f..ecd9b6e 100644 --- a/affection.cabal +++ b/affection.cabal @@ -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. diff --git a/examples/example00/Main.hs b/examples/example00/Main.hs index c9090b8..ae1f9e0 100644 --- a/examples/example00/Main.hs +++ b/examples/example00/Main.hs @@ -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 () diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 0af45ec..abf0f0c 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -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 diff --git a/src/Affection/MessageBus/Message/JoystickMessage.hs b/src/Affection/MessageBus/Message/JoystickMessage.hs new file mode 100644 index 0000000..efb3311 --- /dev/null +++ b/src/Affection/MessageBus/Message/JoystickMessage.hs @@ -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 diff --git a/src/Affection/Subsystems.hs b/src/Affection/Subsystems.hs index ce9929f..e48fa3e 100644 --- a/src/Affection/Subsystems.hs +++ b/src/Affection/Subsystems.hs @@ -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 diff --git a/src/Affection/Subsystems/AffectionJoystick.hs b/src/Affection/Subsystems/AffectionJoystick.hs new file mode 100644 index 0000000..9951d1b --- /dev/null +++ b/src/Affection/Subsystems/AffectionJoystick.hs @@ -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