diff --git a/opengl-spacenavigator.cabal b/opengl-spacenavigator.cabal --- a/opengl-spacenavigator.cabal +++ b/opengl-spacenavigator.cabal @@ -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 \<\>, 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 diff --git a/src/Graphics/UI/SpaceNavigator.hs b/src/Graphics/UI/SpaceNavigator.hs --- a/src/Graphics/UI/SpaceNavigator.hs +++ b/src/Graphics/UI/SpaceNavigator.hs @@ -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 \<\>. - , 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 \<\>. + , 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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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