opengl-spacenavigator 0.1.4.2 → 0.1.5.2

raw patch · 3 files changed

+153/−61 lines, 3 filesdep +binarydep ~GLUTdep ~OpenGLdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: binary

Dependency ranges changed: GLUT, OpenGL, base

API changes (from Hackage documentation)

Files

• opengl-spacenavigator.cabal +8/−4
• src/Graphics/UI/SpaceNavigator.hs +138/−50
• src/Main.hs +7/−7

@@ -1,5 +1,5 @@ name:                opengl-spacenavigator-version:             0.1.4.2+version:             0.1.5.2 synopsis:            Library and example for using a SpaceNavigator-compatible 3-D mouse with OpenGL description:         This package contains functions for managing input from a SpaceNavigator \<<http://www.3dconnexion.com/products/spacemouse/spacenavigator.html>\>, or a 3D mouse compatible with its protocols.  OpenGL callbacks are provided, along with utilities for quantizing the input from the mouse or tracking its six degrees of freedom. license:             MIT@@ -23,18 +23,22 @@   library   exposed-modules:  Graphics.UI.SpaceNavigator-  build-depends:    base         >= 4.6 && < 5+  build-depends:    base         >= 4.8.1 && < 5+               ,    binary       >= 0.7.5                ,    data-default >= 0.5.3-               ,    GLUT         >= 2.4-               ,    OpenGL       >= 2.8+               ,    GLUT         >= 2.7.0.1+               ,    OpenGL       >= 2.12.0.1   hs-source-dirs:   src+  ghc-options:      -Wall   default-language: Haskell2010  executable opengl-spacenavigator   main-is:          Main.hs   build-depends:    base+               ,    binary                ,    data-default                ,    GLUT                ,    OpenGL   hs-source-dirs:   src+  ghc-options:      -Wall   default-language: Haskell2010

@@ -56,7 +56,10 @@ -}  -{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE ExplicitForAll      #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}   module Graphics.UI.SpaceNavigator (@@ -84,57 +87,89 @@ ) where  -import Control.Applicative ((<*>), (<$>)) import Control.Monad (when)+import Data.Binary (Binary) import Data.Default (Default(..)) import Data.IORef (IORef)-import Graphics.Rendering.OpenGL (GLfloat, SettableStateVar, Vector3(..), ($=!), ($~!), get, makeSettableStateVar, rotate, translate)+import Graphics.Rendering.OpenGL (MatrixComponent, SettableStateVar, Vector3(..), ($=!), ($~!), get, makeSettableStateVar, rotate, translate) import Graphics.UI.GLUT (KeyState(..), SpaceballInput(..), spaceballCallback) +import qualified Data.Binary as B (Binary(..)) + -- | Input received from a SpaceNavigator 3D mouse.-data SpaceNavigatorInput =+data SpaceNavigatorInput a =       -- | The mouse has been pushed.       Push       {-        pushRightward :: GLfloat       -- ^ The amount of rightward push, from -1 to +1.-      , pushUpward    :: GLfloat       -- ^ The amount of upward push, from -1 to +1.-      , pushBackward  :: GLfloat       -- ^ The amount of backward push, from -1 to +1.+        pushRightward :: a -- ^ The amount of rightward push, from -1 to +1.+      , pushUpward    :: a -- ^ The amount of upward push, from -1 to +1.+      , pushBackward  :: a -- ^ The amount of backward push, from -1 to +1.       }       -- | The mouse has been tilted.     | Tilt       {-        tiltForward   :: GLfloat       -- ^ The amount of forward tilt, from -1 to +1.-      , tiltClockwise :: GLfloat       -- ^ The amount of clockwise twist, from -1 to +1.-      , tiltRightward :: GLfloat       -- ^ The amount of rightward tilt, from -1 to +1.+        tiltForward   :: a -- ^ The amount of forward tilt, from -1 to +1.+      , tiltClockwise :: a -- ^ The amount of clockwise twist, from -1 to +1.+      , tiltRightward :: a -- ^ The amount of rightward tilt, from -1 to +1.       }       -- | A mouse button has been pressed.     | Button       {-        buttonPress  :: Button         -- ^ Which button has been pressed.-      , buttonAction :: ButtonAction   -- ^ Whether the button has been pressed or released.+        buttonPress  :: Button       -- ^ Which button has been pressed.+      , buttonAction :: ButtonAction -- ^ Whether the button has been pressed or released.       }       deriving (Eq, Read, Show) +instance Functor SpaceNavigatorInput where+  fmap f Push{..} =+    Push+    {+      pushRightward = f pushRightward+    , pushUpward    = f pushUpward+    , pushBackward  = f pushBackward+    }+  fmap f Tilt{..} =+    Tilt+    {+      tiltForward   = f tiltForward+    , tiltClockwise = f tiltClockwise+    , tiltRightward = f tiltRightward+    }+  fmap _ Button{..} =+    Button+    {+      buttonPress  = buttonPress+    , buttonAction = buttonAction+    }  -- | Buttons on a SpaceNavigator 3D mouse. data Button =-    ButtonLeft       -- ^ The left button.-  | ButtonRight      -- ^ The right button.-  | ButtonOther Int  -- ^ Neither the left nor the right button.+    ButtonLeft      -- ^ The left button.+  | ButtonRight     -- ^ The right button.+  | ButtonOther Int -- ^ Neither the left nor the right button.     deriving (Eq, Read, Show) +instance Enum Button where+  fromEnum  ButtonLeft     = 0+  fromEnum  ButtonRight    = 1+  fromEnum (ButtonOther i) = i+  toEnum 0 = ButtonLeft+  toEnum 1 = ButtonRight+  toEnum i = ButtonOther i + -- | Pressing and releasing actions on a SpaceNavigator 3D mouse. data ButtonAction =     ButtonPress   -- ^ The button has been pressed.   | ButtonRelease -- ^ The button has been released.-    deriving (Eq, Read, Show)+    deriving (Enum, Eq, Read, Show)   -- | Interpret SpaceBall input as SpaceNavigator input.-interpretSpaceball :: SpaceballInput      -- ^ The SpaceBall input.-                   -> SpaceNavigatorInput -- ^ The corresponding SpaceNavigator input.+interpretSpaceball :: Fractional a+                   => SpaceballInput        -- ^ The SpaceBall input.+                   -> SpaceNavigatorInput a -- ^ The corresponding SpaceNavigator input. interpretSpaceball (SpaceballMotion rightward upward forward) =   Push   {@@ -163,23 +198,25 @@   -- | A callback for input from the SpaceNavigator 3D mouse.-type SpaceNavigatorCallback = SpaceNavigatorInput -> IO ()+type SpaceNavigatorCallback a = SpaceNavigatorInput a -> IO ()   -- | Register the callback for input from the SpaceNavigator 3D mouse.-spaceNavigatorCallback :: SettableStateVar (Maybe SpaceNavigatorCallback)+spaceNavigatorCallback :: forall a . Fractional a+                       => SettableStateVar (Maybe (SpaceNavigatorCallback a)) spaceNavigatorCallback =   makeSettableStateVar setSpaceNavigatorCallback     where-      setSpaceNavigatorCallback :: Maybe SpaceNavigatorCallback -> IO ()+      setSpaceNavigatorCallback :: Maybe (SpaceNavigatorCallback a) -> IO ()       setSpaceNavigatorCallback Nothing         = spaceballCallback $=! Nothing       setSpaceNavigatorCallback (Just callback) = spaceballCallback $=! Just (callback . interpretSpaceball)   -- | Quantize the input from a SpaceNavigator 3D mouse according to whether the input exceeds a threshold.  The quantized input is -1, +1, or 0, depending on whether a threshold is exceeded.-quantize:: (GLfloat, GLfloat)     -- ^ The thresholds for pushing and titling, respectively, between 0 and +1.-        -> SpaceNavigatorCallback -- ^ The callback for the mouse.-        -> SpaceNavigatorCallback -- ^ A callback that receives quantized input {-1, 0, +1}.+quantize:: RealFloat a+        => (a, a)                   -- ^ The thresholds for pushing and titling, respectively, between 0 and +1.+        -> SpaceNavigatorCallback a -- ^ The callback for the mouse.+        -> SpaceNavigatorCallback a -- ^ A callback that receives quantized input {-1, 0, +1}. quantize (pushThreshold, tiltThreshold) callback input =   do     let@@ -203,27 +240,71 @@   -- | A default quantization for the SpaceNavigator 3D mouse.-defaultQuantization :: (GLfloat, GLfloat)+defaultQuantization :: RealFloat a => (a, a) defaultQuantization = (0.2, 0.1)   -- | Tracking information for a SpaceNavigator 3D mouse.-data Track =+data Track a =   Track   {-    trackMode        :: TrackMode       -- ^ The tracking mode.-  , trackPosition    :: Vector3 GLfloat -- ^ The coordinates for the position.-  , trackOrientation :: Vector3 GLfloat -- ^ The Euler angles for the orientation: yaw\/heading, pitch\/elevation, and roll\/bank, relative an initial orientation where the /-z/ axis is forward: see \<<https://en.wikipedia.org/wiki/Euler_angles#Alternative_names>\>.-  , trackLeftPress   :: Bool            -- ^ Whether the left button is pressed.-  , trackRightPress  :: Bool            -- ^ Whether the right button is pressed.-  , trackLastPressed :: Maybe Button    -- ^ The last button pressed, if any.+    trackMode        :: TrackMode    -- ^ The tracking mode.+  , trackPosition    :: Vector3 a    -- ^ The coordinates for the position.+  , trackOrientation :: Vector3 a    -- ^ The Euler angles for the orientation: yaw\/heading, pitch\/elevation, and roll\/bank, relative an initial orientation where the /-z/ axis is forward: see \<<https://en.wikipedia.org/wiki/Euler_angles#Alternative_names>\>.+  , trackLeftPress   :: Bool         -- ^ Whether the left button is pressed.+  , trackRightPress  :: Bool         -- ^ Whether the right button is pressed.+  , trackLastPressed :: Maybe Button -- ^ The last button pressed, if any.   }     deriving (Eq, Read, Show) -instance Default Track where+instance Functor Track where+  fmap f Track{..} =+    Track+    {+      trackMode        =        trackMode+    , trackPosition    = fmap f trackPosition+    , trackOrientation = fmap f trackOrientation+    , trackLeftPress   =        trackLeftPress+    , trackRightPress  =        trackRightPress+    , trackLastPressed =        trackLastPressed+    }++instance Num a => Default (Track a) where   def = Track def (Vector3 0 0 0) (Vector3 0 0 0) False False Nothing  +instance RealFloat a => Binary (Track a) where+  put Track{..} =+    do+      B.put $ fromEnum trackMode+      B.put $ decodeVector3 trackPosition+      B.put $ decodeVector3 trackOrientation+      B.put trackLeftPress+      B.put trackRightPress+      B.put $ fromEnum <$> trackLastPressed+  get =+    do+      trackMode <- toEnum <$> B.get+      trackPosition <- encodeVector3 <$> B.get+      trackOrientation <- encodeVector3 <$> B.get+      trackLeftPress <- B.get+      trackRightPress <- B.get+      trackLastPressed <- fmap toEnum <$> B.get+      return Track{..}+++decodeVector3 :: RealFloat a => Vector3 a -> ((Integer, Int), (Integer, Int), (Integer, Int))+decodeVector3 (Vector3 x y z) = (decodeFloat x, decodeFloat y, decodeFloat z)+++encodeVector3 :: RealFloat a => ((Integer, Int), (Integer, Int), (Integer, Int)) -> Vector3 a+encodeVector3 (x, y, z) = Vector3 (encodeFloat' x) (encodeFloat' y) (encodeFloat' z)+++encodeFloat' :: RealFloat a => (Integer, Int) -> a+encodeFloat' = uncurry encodeFloat++ -- | The mode for tracking a SpaceNavigator 3D mouse. -- -- /Currently only one mode is available, but other modes, such as flying and examining, will be implemented in the future./@@ -254,16 +335,17 @@   --   --   [tilt forward] decrement third Euler angle, roll\/bank   TrackPlatform-    deriving (Eq, Read, Show)+    deriving (Enum, Eq, Read, Show)  instance Default TrackMode where   def = TrackPlatform   -- | Track the movement of a SpaceNavigator 3D mouse.-track :: (Vector3 GLfloat, Vector3 GLfloat) -- ^ The rates at which to push or tilt, respectively, based on the mouse input.-      -> IORef Track                        -- ^ A reference to the tracking information.-      -> SpaceNavigatorCallback             -- ^ A callback for doing the tracking.+track :: Num a+      => (Vector3 a, Vector3 a)   -- ^ The rates at which to push or tilt, respectively, based on the mouse input.+      -> IORef (Track a)          -- ^ A reference to the tracking information.+      -> SpaceNavigatorCallback a -- ^ A callback for doing the tracking. track (pushRates, _) tracking Push{..} =   tracking $~!     \t@Track{..} ->@@ -315,15 +397,16 @@   -- | Default tracking rates for the SpaceNavigator 3D mouse.-defaultTracking :: (Vector3 GLfloat, Vector3 GLfloat)+defaultTracking :: RealFloat a => (Vector3 a, Vector3 a) defaultTracking = (Vector3 0.01 0.01 0.01, Vector3 1 1 1)   -- | Return an action to track a SpaceNavigator 3D mouse via OpenGL matrices. -- -- This simply calls @glTranslate@ on the position, followed by calls to @glRotate@ for the third Euler angle (roll\/bank) around the /x/-axis, the second (pitch\/elevation) around the /y/-axis, and then the first (yaw\/heading) around the /z/-axis, relative to an initial orientation where the /-z/ axis is forward.-doTracking :: Track -- ^ The tracking information.-           -> IO () -- ^ An action to track the mouse.+doTracking :: (MatrixComponent a, Num a)+           => Track a -- ^ The tracking information.+           -> IO ()   -- ^ An action to track the mouse. doTracking Track{..} =   do     let@@ -337,16 +420,18 @@ -- | Return an action to track a SpaceNavigator 3D mouse via OpenGL matrices. -- -- This simply calls @glTranslate@ on the position, followed by calls to @glRotate@ for the third Euler angle (roll\/bank) around the /x/-axis, the second (pitch\/elevation) around the /y/-axis, and then the first (yaw\/heading) around the /z/-axis, relative to an initial orientation where the /-z/ axis is forward.-doTracking' :: IORef Track -- ^ A reference to the tracking information.-            -> IO ()       -- ^ An action to track the mouse.+doTracking' :: (MatrixComponent a, Num a)+            => IORef (Track a) -- ^ A reference to the tracking information.+            -> IO ()           -- ^ An action to track the mouse. doTracking' = (doTracking =<<) . get   -- | Return an action to create a \"pilot-eye\" view from tracking a SpaceNavigator 3D mouse via OpenGL matrices. -- -- This simply calls @glRotate@ for the third Euler angle (roll\/bank) around the /x/-axis, then the second (pitch\/elevation) around the /y/-axis, and then the first (yaw\/heading) around the /z/-axis, relative to an initial orientation where the /-z/ axis is forward, finalling calling @glTranslate@ on the negated position.-doPilotView :: Track -- ^ The tracking information.-            -> IO () -- ^ An action to set the view.+doPilotView :: (MatrixComponent a, Num a)+            => Track a -- ^ The tracking information.+            -> IO ()   -- ^ An action to set the view. doPilotView Track{..} =   do     let@@ -361,16 +446,18 @@ -- | Return an action to create a \"pilot-eye\" view from tracking a SpaceNavigator 3D mouse via OpenGL matrices. -- -- This simply calls @glRotate@ for the third Euler angle (roll\/bank) around the /x/-axis, then the second (pitch\/elevation) around the /y/-axis, and then the first (yaw\/heading) around the /z/-axis, relative to an initial orientation where the /-z/ axis is forward, finalling calling @glTranslate@ on the negated position.-doPilotView' :: IORef Track -- ^ A reference to the tracking information.-             -> IO ()       -- ^ An action to set the view.+doPilotView' :: (MatrixComponent a, Num a)+             => IORef (Track a) -- ^ A reference to the tracking information.+             -> IO ()           -- ^ An action to set the view. doPilotView' = (doPilotView =<<) . get   -- | Return an action to create a \"polar\" view from tracking a SpaceNavigator 3D mouse via OpenGL matrices. -- -- This simply calls @glTranslate@ on along the /z/-axis negative norm of the position, followed by calls to @glRotate@ for the negated third Euler angle (roll\/bank) around the /x/-axis, the negate second (pitch\/elevation) around the /y/-axis, and then the first (yaw\/heading) around the /z/-axis, relative to an initial orientation where the /-z/ axis is forward.-doPolarView :: Track -- ^ The tracking information.-            -> IO () -- ^ An action to set the view.+doPolarView :: (MatrixComponent a, RealFloat a)+            => Track a -- ^ The tracking information.+            -> IO ()   -- ^ An action to set the view. doPolarView Track{..} =   do     let@@ -385,6 +472,7 @@ -- | Return an action to create a \"polar\" view from tracking a SpaceNavigator 3D mouse via OpenGL matrices. -- -- This simply calls @glTranslate@ on along the /z/-axis negative norm of the position, followed by calls to @glRotate@ for the negated third Euler angle (roll\/bank) around the /x/-axis, the negate second (pitch\/elevation) around the /y/-axis, and then the first (yaw\/heading) around the /z/-axis, relative to an initial orientation where the /-z/ axis is forward.-doPolarView' :: IORef Track -- ^ A reference to the tracking information.-             -> IO ()       -- ^ An action to set the view.+doPolarView' :: (MatrixComponent a, RealFloat a)+             => IORef (Track a) -- ^ A reference to the tracking information.+             -> IO ()           -- ^ An action to set the view. doPolarView' = (doPolarView =<<) . get

@@ -18,9 +18,9 @@  import Data.Default (def) import Data.IORef (IORef, newIORef)-import Graphics.Rendering.OpenGL (ClearBuffer(..), Color3(..), ComparisonFunction(Less), GLfloat, MatrixMode(Modelview, Projection), Position(..), PrimitiveMode(..), Size(..), Vector3(..), Vertex3(..), ($=), ($=!), clear, color, depthFunc, flush, frustum, get, loadIdentity, matrixMode, preservingMatrix, renderPrimitive, rotate, translate, vertex, viewport)+import Graphics.Rendering.OpenGL (ClearBuffer(..), Color3(..), ComparisonFunction(Less), GLfloat, MatrixMode(Modelview, Projection), Position(..), PrimitiveMode(..), SettableStateVar, Size(..), Vector3(..), Vertex3(..), ($=), ($=!), clear, color, depthFunc, flush, frustum, get, loadIdentity, matrixMode, preservingMatrix, renderPrimitive, rotate, translate, vertex, viewport) import Graphics.UI.GLUT (DisplayCallback, DisplayMode(..), ReshapeCallback, createWindow, displayCallback, getArgsAndInitialize, idleCallback, initialDisplayMode, mainLoop, postRedisplay, reshapeCallback, swapBuffers)-import Graphics.UI.SpaceNavigator (Track(..), defaultQuantization, defaultTracking, doTracking', quantize, spaceNavigatorCallback, track)+import Graphics.UI.SpaceNavigator (SpaceNavigatorCallback, Track(..), defaultQuantization, defaultTracking, doTracking', quantize, spaceNavigatorCallback, track)   -- | The main action.@@ -51,25 +51,25 @@  dispatch ["raw"] =   do -    spaceNavigatorCallback $=! Just print+    (spaceNavigatorCallback :: SettableStateVar (Maybe (SpaceNavigatorCallback GLfloat))) $=! Just print     displayCallback $=! display Nothing     mainLoop  dispatch ["quantized"] =   let-     (pushThreshold, tiltThreshold) = defaultQuantization+     (pushThreshold, tiltThreshold) = defaultQuantization :: (GLfloat, GLfloat)   in     dispatch ["quantized", show pushThreshold, show tiltThreshold]  dispatch ["quantized", pushThreshold, tiltThreshold] =   do-    spaceNavigatorCallback $=! Just (quantize (read pushThreshold, read tiltThreshold) print)+    spaceNavigatorCallback $=! Just (quantize (read pushThreshold, read tiltThreshold :: GLfloat) print)     displayCallback $=! display Nothing     mainLoop  dispatch ["track"] =   let-     (pushThreshold, tiltThreshold) = defaultQuantization+     (pushThreshold, tiltThreshold) = defaultQuantization :: (GLfloat, GLfloat)   in     dispatch ["track", show pushThreshold, show tiltThreshold] @@ -98,7 +98,7 @@   -- | The display callback.-display :: Maybe (IORef Track) -> DisplayCallback+display :: Maybe (IORef (Track GLfloat)) -> DisplayCallback display (Just tracking) =   do     let