now with joystick support

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.

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
+  partSubscribers (Window t) = generalSubscribers t
-    subTups <- liftIO $ readTVarIO t
-    return $ map snd subTups
 
   partSubscribe (Window t) = generalSubscribe t
 
-  partUnSubscribe (Window t) uuid =
+  partUnSubscribe (Window t) = generalUnSubscribe t
-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
 
 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
+  partSubscribers (Mouse t) = generalSubscribers t
-    subTups <- liftIO $ readTVarIO t
-    return $ map snd subTups
 
   partSubscribe (Mouse t) = generalSubscribe t
 
-  partUnSubscribe (Mouse t) uuid =
+  partUnSubscribe (Mouse t) = generalUnSubscribe t
-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
 
 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
+  partSubscribers (Keyboard t) = generalSubscribers t
-    subTups <- liftIO $ readTVarIO t
-    return $ map snd subTups
 
   partSubscribe (Keyboard t) = generalSubscribe t
 
-  partUnSubscribe (Keyboard t) uuid =
+  partUnSubscribe (Keyboard t) = generalUnSubscribe t
-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
 
 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
+load =
-  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
+  StateData <$> (Subsystems
-  empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
+    <$> (Window <$> newTVarIO [])
-  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
+    <*> (Mouse <$> newTVarIO [])
-  return $ StateData $ Subsystems
+    <*> (Keyboard <$> newTVarIO [])
-    (Window empty1)
+    <*> (Joystick <$> newTVarIO [])
-    (Mouse empty2)
+    )
-    (Keyboard empty3)
+    <*> 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
+  (Subsystems a b c d) <- sdSubs <$> getAffection
-  _ <- consumeSDLEvents a es
+  leftovers <- consumeSDLEvents a
-  _ <- consumeSDLEvents b es
+    =<< consumeSDLEvents b
-  _ <- consumeSDLEvents c es
+    =<< consumeSDLEvents c
+    =<< consumeSDLEvents d es
+  mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
   return ()
 
 update _ = return ()

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

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

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

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