Added multi-touch support.

Author: svenpanne

Graphics/UI/GLUT/Callbacks/Registration.hs

@@ -42,6 +42,8 @@ data CallbackType
    | MenuStatusCB      | IdleCB
    -- freeglut-only callback types
    | CloseCB           | MouseWheelCB      | PositionCB
+   | MultiEntryCB      | MultiMotionCB     | MultiButtonCB
+   | MultiPassiveCB
    deriving ( Eq, Ord )
 
 isGlobal :: CallbackType -> Bool

Graphics/UI/GLUT/Callbacks/Window.hs

@@ -60,7 +60,14 @@ module Graphics.UI.GLUT.Callbacks.Window (
 
    -- * Joystick callback
    JoystickButtons(..), JoystickPosition(..),
-   JoystickCallback, joystickCallback
+   JoystickCallback, joystickCallback,
+
+   -- * Multi-touch support
+   TouchID,
+   MultiMouseCallback, multiMouseCallback,
+   MultiCrossingCallback, multiCrossingCallback,
+   MultiMotionCallback, multiMotionCallback, multiPassiveMotionCallback
+
 ) where
 
 import Data.Bits hiding ( shift )
@@ -294,15 +301,20 @@ windowStateCallback = makeSettableStateVar $
 
 --------------------------------------------------------------------------------
 
+-- | A window close callback
+
 type CloseCallback = IO ()
 
+-- | Controls the window close callback for the /current window/.
+
 closeCallback :: SettableStateVar (Maybe CloseCallback)
 closeCallback = makeSettableStateVar $
    setCallback CloseCB glutCloseFunc makeCloseFunc
 
 --------------------------------------------------------------------------------
 
 -- | A keyboard callback
+
 type KeyboardCallback = Char -> Position -> IO ()
 
 setKeyboardCallback :: Maybe KeyboardCallback -> IO ()
@@ -313,6 +325,7 @@ setKeyboardCallback =
 
 -- | Controls the keyboard callback for the /current window/. This is
 -- activated only when a key is pressed.
+
 keyboardCallback :: SettableStateVar (Maybe KeyboardCallback)
 keyboardCallback = makeSettableStateVar setKeyboardCallback
 
@@ -327,8 +340,10 @@ setKeyboardUpCallback =
 
 -- | Controls the keyboard callback for the /current window/. This is
 -- activated only when a key is released.
+
 keyboardUpCallback :: SettableStateVar (Maybe KeyboardCallback)
 keyboardUpCallback = makeSettableStateVar setKeyboardUpCallback
+
 --------------------------------------------------------------------------------
 
 -- | Special keys
@@ -406,6 +421,7 @@ unmarshalSpecialKey x
 --------------------------------------------------------------------------------
 
 -- | A special key callback
+
 type SpecialCallback = SpecialKey -> Position -> IO ()
 
 setSpecialCallback :: Maybe SpecialCallback -> IO ()
@@ -416,8 +432,10 @@ setSpecialCallback =
 
 -- | Controls the special key callback for the /current window/. This is
 -- activated only when a special key is pressed.
+
 specialCallback :: SettableStateVar (Maybe SpecialCallback)
 specialCallback = makeSettableStateVar setSpecialCallback
+
 --------------------------------------------------------------------------------
 
 setSpecialUpCallback :: Maybe SpecialCallback -> IO ()
@@ -428,8 +446,10 @@ setSpecialUpCallback =
 
 -- | Controls the special key callback for the /current window/. This is
 -- activated only when a special key is released.
+
 specialUpCallback :: SettableStateVar (Maybe SpecialCallback)
 specialUpCallback = makeSettableStateVar setSpecialUpCallback
+
 --------------------------------------------------------------------------------
 
 -- | The current state of a key or button
@@ -448,6 +468,7 @@ unmarshalKeyState x
 --------------------------------------------------------------------------------
 
 -- | A mouse callback
+
 type MouseCallback = MouseButton -> KeyState -> Position -> IO ()
 
 setMouseCallback :: Maybe MouseCallback -> IO ()
@@ -458,8 +479,10 @@ setMouseCallback =
                                    (Position (fromIntegral x) (fromIntegral y))
 
 -- | Controls the mouse callback for the /current window/.
+
 mouseCallback :: SettableStateVar (Maybe MouseCallback)
 mouseCallback = makeSettableStateVar setMouseCallback
+
 --------------------------------------------------------------------------------
 
 -- | The state of the keyboard modifiers
@@ -867,3 +890,56 @@ joystickCallback =
                                     (JoystickPosition (fromIntegral x)
                                                       (fromIntegral y)
                                                       (fromIntegral z))
+
+--------------------------------------------------------------------------------
+
+-- | A description where the multi-touch event is coming from, the freeglut
+-- specs are very vague about the actual semantics. It contains the device ID
+-- and\/or the cursor\/finger ID.
+
+type TouchID = Int
+
+-- | A multi-touch variant of 'MouseCallback'.
+
+type MultiMouseCallback = TouchID -> MouseCallback
+
+-- | (/freeglut only/) A multi-touch variant of 'mouseCallback'.
+
+multiMouseCallback :: SettableStateVar (Maybe MultiMouseCallback)
+multiMouseCallback = makeSettableStateVar $
+   setCallback MultiButtonCB glutMultiButtonFunc (makeMultiButtonFunc . unmarshal)
+   where unmarshal cb d x y b s = cb (fromIntegral d)
+                                     (unmarshalMouseButton b)
+                                     (unmarshalKeyState s)
+                                     (Position (fromIntegral x) (fromIntegral y))
+
+-- | A multi-touch variant of 'CrossingCallback'.
+
+type MultiCrossingCallback = TouchID -> CrossingCallback
+
+-- | (/freeglut only/) A multi-touch variant of 'crossingCallback'.
+
+multiCrossingCallback :: SettableStateVar (Maybe MultiCrossingCallback)
+multiCrossingCallback = makeSettableStateVar $
+   setCallback MultiEntryCB glutMultiEntryFunc (makeMultiEntryFunc . unmarshal)
+   where unmarshal cb d c = cb (fromIntegral d) (unmarshalCrossing c)
+
+-- | A multi-touch variant of 'MotionCallback'.
+
+type MultiMotionCallback = TouchID -> MotionCallback
+
+-- | (/freeglut only/) A multi-touch variant of 'motionCallback'.
+
+multiMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)
+multiMotionCallback = makeSettableStateVar $
+   setCallback MultiMotionCB glutMultiMotionFunc (makeMultiMotionFunc . unmarshal)
+   where unmarshal cb d x y =
+            cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))
+
+-- | (/freeglut only/) A multi-touch variant of 'passiveMotionCallback'.
+
+multiPassiveMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)
+multiPassiveMotionCallback = makeSettableStateVar $
+   setCallback MultiPassiveCB glutMultiPassiveFunc (makeMultiPassiveFunc . unmarshal)
+   where unmarshal cb d x y =
+            cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))

Graphics/UI/GLUT/Raw/Callbacks.hs

@@ -15,7 +15,6 @@
 -----------------------------------------------------------------------------
 
 module Graphics.UI.GLUT.Raw.Callbacks (
-   MenuFunc, makeMenuFunc,
    ButtonBoxFunc, makeButtonBoxFunc,
    CloseFunc, makeCloseFunc,
    DialsFunc, makeDialsFunc,
@@ -26,11 +25,16 @@ module Graphics.UI.GLUT.Raw.Callbacks (
    KeyboardFunc, makeKeyboardFunc,
    KeyboardUpFunc, makeKeyboardUpFunc,
    MenuDestroyFunc, makeMenuDestroyFunc,
+   MenuFunc, makeMenuFunc,
    MenuStateFunc, makeMenuStateFunc,
    MenuStatusFunc, makeMenuStatusFunc,
    MotionFunc, makeMotionFunc,
    MouseFunc, makeMouseFunc,
    MouseWheelFunc, makeMouseWheelFunc,
+   MultiButtonFunc, makeMultiButtonFunc,
+   MultiEntryFunc, makeMultiEntryFunc,
+   MultiMotionFunc, makeMultiMotionFunc,
+   MultiPassiveFunc, makeMultiPassiveFunc,
    OverlayDisplayFunc, makeOverlayDisplayFunc,
    PassiveMotionFunc, makePassiveMotionFunc,
    PositionFunc, makePositionFunc,
@@ -51,11 +55,6 @@ module Graphics.UI.GLUT.Raw.Callbacks (
 import Foreign.C.Types
 import Foreign.Ptr
 
-type MenuFunc = CInt -> IO ()
-
-foreign import ccall "wrapper"
-   makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc)
-
 type ButtonBoxFunc = CInt -> CInt -> IO ()
 
 foreign import ccall "wrapper"
@@ -106,6 +105,11 @@ type MenuDestroyFunc = IO ()
 foreign import ccall "wrapper"
    makeMenuDestroyFunc :: MenuDestroyFunc -> IO (FunPtr MenuDestroyFunc)
 
+type MenuFunc = CInt -> IO ()
+
+foreign import ccall "wrapper"
+   makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc)
+
 type MenuStateFunc = CInt -> IO ()
 
 foreign import ccall "wrapper"
@@ -131,6 +135,26 @@ type MouseWheelFunc = CInt -> CInt -> CInt -> CInt -> IO ()
 foreign import ccall "wrapper"
    makeMouseWheelFunc :: MouseWheelFunc -> IO (FunPtr MouseWheelFunc)
 
+type MultiButtonFunc = CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
+
+foreign import ccall "wrapper"
+   makeMultiButtonFunc :: MultiButtonFunc -> IO (FunPtr MultiButtonFunc)
+
+type MultiEntryFunc = CInt -> CInt -> IO ()
+
+foreign import ccall "wrapper"
+   makeMultiEntryFunc :: MultiEntryFunc -> IO (FunPtr MultiEntryFunc)
+
+type MultiMotionFunc = CInt -> CInt -> CInt -> IO ()
+
+foreign import ccall "wrapper"
+   makeMultiMotionFunc :: MultiMotionFunc -> IO (FunPtr MultiMotionFunc)
+
+type MultiPassiveFunc = CInt -> CInt -> CInt -> IO ()
+
+foreign import ccall "wrapper"
+   makeMultiPassiveFunc :: MultiPassiveFunc -> IO (FunPtr MultiPassiveFunc)
+
 type OverlayDisplayFunc = IO ()
 
 foreign import ccall "wrapper"

Graphics/UI/GLUT/Raw/Functions.hs

@@ -84,6 +84,10 @@ module Graphics.UI.GLUT.Raw.Functions (
    glutMotionFunc,
    glutMouseFunc,
    glutMouseWheelFunc,
+   glutMultiButtonFunc,
+   glutMultiEntryFunc,
+   glutMultiMotionFunc,
+   glutMultiPassiveFunc,
    glutOverlayDisplayFunc,
    glutPassiveMotionFunc,
    glutPopWindow,
@@ -246,6 +250,10 @@ API_ENTRY(glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ())
 API_ENTRY(glutMotionFunc,FunPtr MotionFunc -> IO ())
 API_ENTRY(glutMouseFunc,FunPtr MouseFunc -> IO ())
 API_ENTRY(glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ())
+API_ENTRY(glutMultiButtonFunc,FunPtr MultiButtonFunc -> IO ())
+API_ENTRY(glutMultiEntryFunc,FunPtr MultiEntryFunc -> IO ())
+API_ENTRY(glutMultiMotionFunc,FunPtr MultiMotionFunc -> IO ())
+API_ENTRY(glutMultiPassiveFunc,FunPtr MultiPassiveFunc -> IO ())
 API_ENTRY(glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ())
 API_ENTRY(glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ())
 API_ENTRY(glutPopWindow,IO ())