diff --git a/handa-opengl.cabal b/handa-opengl.cabal --- a/handa-opengl.cabal +++ b/handa-opengl.cabal @@ -1,5 +1,5 @@ name: handa-opengl -version: 0.1.6.1 +version: 0.1.11.2 synopsis: Utility functions for OpenGL and GLUT description: This is a collection of miscellaneous utility functions for OpenGL and GLUT. @@ -14,7 +14,7 @@ stability: Stable homepage: https://bitbucket.org/bwbush/handa-opengl bug-reports: https://bwbush.atlassian.net/projects/HOGL/issues/ -package-url: https://bitbucket.org/bwbush/handa-opengl/downloads/handa-opengl-0.1.6.1.tar.gz +package-url: https://bitbucket.org/bwbush/handa-opengl/downloads/handa-opengl-0.1.11.2.tar.gz extra-source-files: ReadMe.md @@ -23,16 +23,22 @@ location: https://bwbush@bitbucket.org/bwbush/handa-opengl.git library - build-depends: base >= 4.6 && < 5 - , array >= 0.4.0.1 + build-depends: base >= 4.8.1 && < 5 + , aeson >= 0.10 + , array >= 0.5.1.0 + , binary >= 0.7.5 , data-default >= 0.5.3 - , GLUT >= 2.4 - , opengl-dlp-stereo >= 0.1.4.1 - , OpenGL >= 2.8 - exposed-modules: Graphics.Rendering.Handa.Face + , GLUT >= 2.7.0.1 + , opengl-dlp-stereo >= 0.1.5.1 + , OpenGL >= 2.12.0.1 + , vector-space >= 0.10.2 + exposed-modules: Foreign.C.Types.Instances + Graphics.Rendering.Handa.Face + Graphics.Rendering.Handa.Projection Graphics.Rendering.Handa.Shape Graphics.Rendering.Handa.Viewer Graphics.Rendering.Handa.Util + Graphics.Rendering.OpenGL.GL.Tensor.Instances Graphics.UI.Handa.Keyboard Graphics.UI.Handa.Setup hs-source-dirs: src diff --git a/src/Foreign/C/Types/Instances.hs b/src/Foreign/C/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/Types/Instances.hs @@ -0,0 +1,44 @@ +{-| +Module : Foreign.C.Types.Instances +Copyright : (c) 2015 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + +Instances for C types. +-} + + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + + +module Foreign.C.Types.Instances ( +) where + + +import Data.Aeson (FromJSON) +import Data.Binary (Binary(..)) +import Foreign.C.Types (CDouble(..), CFloat(..)) +import GHC.Generics (Generic) + + +deriving instance Generic CFloat + +instance Binary CFloat where + put (CFloat x) = put x + get = CFloat <$> get + +instance FromJSON CFloat + + +deriving instance Generic CDouble + +instance Binary CDouble where + put (CDouble x) = put x + get = CDouble <$> get + +instance FromJSON CDouble diff --git a/src/Graphics/Rendering/Handa/Projection.hs b/src/Graphics/Rendering/Handa/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Handa/Projection.hs @@ -0,0 +1,122 @@ +{-| +Module : Graphics.Rendering.Handa.Projection +Copyright : (c) 2015 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + +Functions for off-axis projection. +-} + + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Graphics.Rendering.Handa.Projection ( +-- * Screens. + Screen(..) +, aspectRatio +, throwRatio +-- * Projections. +, projection +) where + + +import Data.AdditiveGroup (AdditiveGroup) +import Data.Aeson (FromJSON) +import Data.AffineSpace ((.-.)) +import Data.Binary (Binary(..)) +import Data.Cross (cross3) +import Data.Data (Data) +import Data.VectorSpace ((<.>), magnitude, normalized) +import GHC.Generics (Generic) +import Graphics.Rendering.OpenGL (GLmatrix, MatrixComponent, MatrixOrder(RowMajor), Vector3(..), Vertex3(..), frustum, multMatrix, newMatrix, translate) +import Graphics.Rendering.OpenGL.GL.Tensor.Instances (origin) + + +-- | Description of a physical screen geometry. +data Screen a = + Screen + { + lowerLeft :: Vertex3 a -- ^ The lower left corner. + , lowerRight :: Vertex3 a -- ^ The lower right corner. + , upperLeft :: Vertex3 a -- ^ The upper left corner. + } + deriving (Binary, Data, Eq, FromJSON, Generic, Read, Show) + +instance Functor Screen where + fmap f Screen{..} = + Screen + { + lowerLeft = fmap f lowerLeft + , lowerRight = fmap f lowerRight + , upperLeft = fmap f upperLeft + } + + +-- | The aspect ratio. +aspectRatio :: (AdditiveGroup a, RealFloat a) + => Screen a -- ^ The screen geometry. + -> a -- ^ The aspect ratio, namely the screen width divided by its height. +aspectRatio Screen{..} = + let + width = magnitude $ lowerRight .-. lowerLeft + height = magnitude $ upperLeft .-. lowerLeft + in + width / height + + +-- | The throw ratio. +throwRatio :: (AdditiveGroup a, RealFloat a) + => Screen a -- ^ The screen geometry. + -> Vertex3 a -- ^ The eye position. + -> a -- ^ The throw ratio, name the distance to the screen divided by its width. +throwRatio Screen{..} eye = + let + width = magnitude $ lowerRight .-. lowerLeft + vn = normalized (lowerRight .-. lowerLeft) `cross3` normalized (upperLeft .-. lowerLeft) + throw = - (lowerLeft .-. eye) <.> vn + in + throw / width + + +-- | Make an off-axis projection for a screen. This projection is based on the equations in \<\> . +projection :: forall a . (AdditiveGroup a, MatrixComponent a, RealFloat a) + => Screen a -- ^ The screen geometry. + -> Vertex3 a -- ^ The eye position. + -> a -- ^ The distance to the near culling plane. + -> a -- ^ The distance to the far culling plane. + -> IO () -- ^ An action for performing the off-axis projection. +projection Screen{..} eye near far = + do + let + -- Orthonomal basis for screen. + vr = normalized $ lowerRight .-. lowerLeft + vu = normalized $ upperLeft .-. lowerLeft + vn = vr `cross3` vu + -- Screen corners relative to eye. + va = lowerLeft .-. eye + vb = lowerRight .-. eye + vc = upperLeft .-. eye + -- Distance from eye to screen. + throw = - va <.> vn + -- Extent on near clipping plane. + scaling = near / throw + left = realToFrac $ (vr <.> va) * scaling + right = realToFrac $ (vr <.> vb) * scaling + bottom = realToFrac $ (vu <.> va) * scaling + top = realToFrac $ (vu <.> vc) * scaling + -- Matrix transforming world to screen. + m = [[x, y, z, 0] | Vector3 x y z <- [vr, vu, vn]] ++ [[0, 0, 0, 1]] + -- Perpendicator projection + frustum left right bottom top (realToFrac near) (realToFrac far) + -- Rotate to non-perpendicular. + multMatrix =<< (newMatrix RowMajor $ concat m :: IO (GLmatrix a)) + -- Move apex of frustum. + translate $ origin .-. eye diff --git a/src/Graphics/Rendering/Handa/Shape.hs b/src/Graphics/Rendering/Handa/Shape.hs --- a/src/Graphics/Rendering/Handa/Shape.hs +++ b/src/Graphics/Rendering/Handa/Shape.hs @@ -23,7 +23,6 @@ ) where -import Control.Applicative ((<$>)) import Data.Array.Storable (newListArray, withStorableArray) import Foreign.Ptr (nullPtr) import Foreign.Storable (Storable, sizeOf) @@ -63,9 +62,9 @@ -- | Reconstruct a shape by replacing its vertices. remakeShape :: Storable a - => Shape -- ^ The shape. - -> [a] -- ^ The replacement vertices. - -> IO Shape -- ^ An action for the updated shape. + => Shape -- ^ The shape. + -> [a] -- ^ The replacement vertices. + -> IO Shape -- ^ An action for the updated shape. remakeShape shape@Shape{..} vertices = let n = length vertices diff --git a/src/Graphics/Rendering/Handa/Viewer.hs b/src/Graphics/Rendering/Handa/Viewer.hs --- a/src/Graphics/Rendering/Handa/Viewer.hs +++ b/src/Graphics/Rendering/Handa/Viewer.hs @@ -10,13 +10,18 @@ -} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} module Graphics.Rendering.Handa.Viewer ( -- * Viewer Geometry ViewerParameters(..) , viewerGeometry +, displayAspectRatio +, displayThrowRatio , fieldOfView -- * Typical Devices , phoneViewer @@ -30,125 +35,176 @@ ) where +import Data.AdditiveGroup (AdditiveGroup) +import Data.Aeson (FromJSON) +import Data.Binary (Binary(..)) +import Data.Data (Data) import Data.Default (Default, def) +import Foreign.Storable (Storable) +import GHC.Generics (Generic) import Graphics.Rendering.DLP (DlpEncoding, DlpEye(..)) import Graphics.Rendering.DLP.Callbacks (DlpDisplay(..)) +import Graphics.Rendering.Handa.Projection (Screen(..), aspectRatio, projection, throwRatio) import Graphics.Rendering.Handa.Util (degree) -import Graphics.Rendering.OpenGL (GLdouble, MatrixMode(..), Position(..), Size(..), Vector3(..), Vertex3(..), ($=!), loadIdentity, lookAt, matrixMode, perspective, viewport) +import Graphics.Rendering.OpenGL (GLdouble, MatrixComponent, MatrixMode(..), Position(..), Vector3(..), Vertex3(..), ($=!), loadIdentity, lookAt, matrixMode, scale, viewport) +import Graphics.Rendering.OpenGL.GL.Tensor.Instances () import Graphics.UI.GLUT (DisplayCallback, ReshapeCallback) -- | Paramaters specifying a viewer, including the frustum of the view. -data ViewerParameters = +data ViewerParameters a = ViewerParameters { - displayAspectRatio :: GLdouble -- ^ The aspect ratio of the screen or display (i.e., the width divided by the height). - , displayThrowRatio :: GLdouble -- ^ The throw ratio of the screen or display (i.e., the width divided by the distance). - , distanceNearPlane :: GLdouble -- ^ The distance to the near plane of the frustum. - , distanceFarPlane :: GLdouble -- ^ The distance to the far plane of the frustum. - , eyePosition :: Vertex3 GLdouble -- ^ The position of the eyes. - , eyeSeparation :: Vector3 GLdouble -- ^ The separation between the eyes. - , eyeUpward :: Vector3 GLdouble -- ^ The upward direction. - , sceneCenter :: Vertex3 GLdouble -- ^ The center of the scene. + screen :: Screen a -- ^ The screen location. + , nearPlane :: a -- ^ The distance to the near plane of the frustum. + , farPlane :: a -- ^ The distance to the far plane of the frustum. + , eyePosition :: Vertex3 a -- ^ The position of the eyes. + , eyeSeparation :: Vector3 a -- ^ The separation between the eyes. + , eyeUpward :: Vector3 a -- ^ The upward direction. + , sceneCenter :: Vertex3 a -- ^ The center of the scene. + , sceneScale :: Vector3 a -- ^ The factor by which to scale the scene. } - deriving (Eq, Read, Show) + deriving (Binary, Data, Eq, FromJSON, Generic, Read, Show) -instance Default ViewerParameters where +instance Functor ViewerParameters where + fmap f ViewerParameters{..} = + ViewerParameters + { + screen = fmap f screen + , nearPlane = f nearPlane + , farPlane = f farPlane + , eyePosition = fmap f eyePosition + , eyeSeparation = fmap f eyeSeparation + , eyeUpward = fmap f eyeUpward + , sceneCenter = fmap f sceneCenter + , sceneScale = fmap f sceneScale + } + +instance (Fractional a, Storable a) => Default (ViewerParameters a) where def = ViewerParameters { - displayAspectRatio = 1 - , displayThrowRatio = 1 - , distanceNearPlane = 0.5 - , distanceFarPlane = 4.5 - , eyePosition = Vertex3 0 0 2 - , eyeSeparation = Vector3 0.2 0 0 - , eyeUpward = Vector3 0 1 0 - , sceneCenter = Vertex3 0 0 0 + screen = + Screen + { + lowerLeft = Vertex3 (-0.5) (-0.5) 0 + , lowerRight = Vertex3 0.5 (-0.5) 0 + , upperLeft = Vertex3 (-0.5) 0.5 0 + } + , nearPlane = 0.1 + , farPlane = 100 + , eyePosition = Vertex3 0 0 1 + , eyeSeparation = Vector3 0.2 0 0 + , eyeUpward = Vector3 0 1 0 + , sceneCenter = Vertex3 0 0 0 + , sceneScale = Vector3 1 1 1 } -- | Construct viewer geometry from physical geometry. -viewerGeometry :: GLdouble -- ^ The width of the screen or display. - -> GLdouble -- ^ The height of the screen or display. - -> GLdouble -- ^ The distance from the eyes to the screen or display. - -> ViewerParameters -- ^ The corresponding viewer parameters. +viewerGeometry :: (Fractional a, Storable a) + => a -- ^ The width of the screen or display. + -> a -- ^ The height of the screen or display. + -> a -- ^ The distance from the eyes to the screen or display. + -> ViewerParameters a -- ^ The corresponding viewer parameters. viewerGeometry width height throw = def { - displayAspectRatio = width / height - , displayThrowRatio = throw / width + screen = + Screen + { + lowerLeft = Vertex3 (- 1 / 2) (- height / width / 2) 0 + , lowerRight = Vertex3 ( 1 / 2) (- height / width / 2) 0 + , upperLeft = Vertex3 (- 1 / 2) ( height / width / 2) 0 + } + , eyePosition = Vertex3 0 0 (throw / width) + , sceneScale = Vector3 1 (height / width) 1 } -- | Viewer parameters for a typical smartphone screen. -phoneViewer :: ViewerParameters +phoneViewer :: (Fractional a, Storable a) => ViewerParameters a phoneViewer = viewerGeometry 5.27 2.80 12 -- | Viewer parameters for a typical laptop screen. -laptopViewer :: ViewerParameters +laptopViewer :: (Fractional a, Storable a) => ViewerParameters a laptopViewer = viewerGeometry 13.625 7.875 24 -- | Viewer parameters for a typical desktop monitor. -desktopViewer :: ViewerParameters +desktopViewer :: (Fractional a, Storable a) => ViewerParameters a desktopViewer = viewerGeometry 20.75 11.625 32 -- | Viewer parameters for a typical projector. -projectorViewer :: ViewerParameters -projectorViewer = - def - { - displayAspectRatio = 1.6 / 1.0 - , displayThrowRatio = 1.5 / 1.0 - } +projectorViewer :: (Fractional a, Storable a) => ViewerParameters a +projectorViewer = viewerGeometry 1.6 1.0 (1.5 * 1.6) +-- | The aspect ratio of the viewer. +displayAspectRatio :: (AdditiveGroup a, RealFloat a, Storable a) + => ViewerParameters a -- ^ The viewer parameters. + -> a -- ^ The aspect ratio, namely the screen width divided by its height. +displayAspectRatio ViewerParameters{..} = aspectRatio screen + + +-- | The throw ratio of the viewer. +displayThrowRatio :: (AdditiveGroup a, RealFloat a, Storable a) + => ViewerParameters a -- ^ The viewer parameters. + -> a -- ^ The throw ratio, namely the distance to the screen divided by its height. +displayThrowRatio ViewerParameters{..} = throwRatio screen eyePosition + + -- | Compute the field of view for viewer parameters. -fieldOfView :: ViewerParameters -- ^ The viewer parameters - -> GLdouble -- ^ The field of view, in degrees. -fieldOfView ViewerParameters{..} = 2 * atan2 0.5 displayThrowRatio * degree +fieldOfView :: (AdditiveGroup a, RealFloat a, Storable a) + => ViewerParameters a -- ^ The viewer parameters + -> a -- ^ The field of view, in degrees. +fieldOfView ViewerParameters{..} = 2 * atan2 0.5 (throwRatio screen eyePosition) * degree -- | Construct a reshape callback from viewer parameters. This simply sets the frustum based on the viewer parameters and the size of the viewport. -reshape :: ViewerParameters -- ^ The viewer parameters. - -> ReshapeCallback -- ^ The reshape callback. -reshape vp@ViewerParameters{..} wh@(Size w h) = +reshape :: (AdditiveGroup a, MatrixComponent a, RealFloat a, Storable a) + => ViewerParameters a -- ^ The viewer parameters. + -> ReshapeCallback -- ^ The reshape callback. +reshape ViewerParameters{..} wh = do viewport $=! (Position 0 0, wh) matrixMode $=! Projection loadIdentity - perspective (fieldOfView vp) (fromIntegral w / fromIntegral h) distanceNearPlane distanceFarPlane + projection screen eyePosition nearPlane farPlane matrixMode $=! Modelview 0 -- | Create an action look at the scene according to the viewer parameters. -loadViewer :: ViewerParameters -- ^ The viewer parameters. - -> DlpEye -- ^ The eye from which to view. - -> IO () -- ^ An action for looking at the scene using the specified eye and viewer parameters. +loadViewer :: (RealFloat a, Storable a) + => ViewerParameters a -- ^ The viewer parameters. + -> DlpEye -- ^ The eye from which to view. + -> IO () -- ^ An action for looking at the scene using the specified eye and viewer parameters. loadViewer ViewerParameters{..} eye = do - loadIdentity let offset = case eye of - LeftDlp -> -1/2 - RightDlp -> 1/2 + LeftDlp -> -0.5 + RightDlp -> 0.5 Vertex3 xEye yEye zEye = eyePosition Vector3 dxEye dyEye dzEye = eyeSeparation + Vector3 sx sy sz = realToFrac <$> sceneScale :: Vector3 GLdouble + loadIdentity + scale sx sy sz lookAt - (Vertex3 (xEye + offset * dxEye) (yEye + offset * dyEye) (zEye + offset * dzEye)) - sceneCenter - eyeUpward + (realToFrac <$> Vertex3 (xEye + offset * dxEye) (yEye + offset * dyEye) (zEye + offset * dzEye)) + (realToFrac <$> sceneCenter) + (realToFrac <$> eyeUpward) -- | Construct a DLP display from a display callback. -dlpViewerDisplay :: DlpEncoding -- ^ The DLP encoding. - -> ViewerParameters -- ^ The viewer parameters. - -> DisplayCallback -- ^ The display callback. - -> DlpDisplay -- ^ The DLP display data for using the specified encoding, viewer parameters, and display callback. +dlpViewerDisplay :: (RealFloat a, Storable a) + => DlpEncoding -- ^ The DLP encoding. + -> ViewerParameters a -- ^ The viewer parameters. + -> DisplayCallback -- ^ The display callback. + -> DlpDisplay -- ^ The DLP display data for using the specified encoding, viewer parameters, and display callback. dlpViewerDisplay encoding viewerParameters display = def { diff --git a/src/Graphics/Rendering/OpenGL/GL/Tensor/Instances.hs b/src/Graphics/Rendering/OpenGL/GL/Tensor/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/OpenGL/GL/Tensor/Instances.hs @@ -0,0 +1,83 @@ +{-| +Module : Graphics.Rendering.OpenGL.GL.Tensor.Instances +Copyright : (c) 2015 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + +Instances for vector algebra. +-} + + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + + +module Graphics.Rendering.OpenGL.GL.Tensor.Instances ( + origin +) where + + +import Data.Aeson (FromJSON) +import Data.AdditiveGroup (AdditiveGroup(..)) +import Data.AffineSpace (AffineSpace(..)) +import Data.Binary (Binary(..)) +import Data.Cross (HasCross3(..)) +import Data.Data (Data) +import Data.VectorSpace (InnerSpace(..), VectorSpace(..)) +import GHC.Generics (Generic) +import Graphics.Rendering.OpenGL (Vector3(..), Vertex3(..)) + + +-- | The origin of the coordinate system. +origin :: Num a => Vertex3 a +origin = Vertex3 0 0 0 + + +deriving instance Data a => Data (Vector3 a) + +deriving instance Generic a => Generic (Vector3 a) + +deriving instance (Binary a, Generic a) => Binary (Vector3 a) + +deriving instance (FromJSON a, Generic a) => FromJSON (Vector3 a) + + +deriving instance Data a => Data (Vertex3 a) + +deriving instance Generic a => Generic (Vertex3 a) + +deriving instance (Binary a, Generic a) => Binary (Vertex3 a) + +deriving instance (FromJSON a, Generic a) => FromJSON (Vertex3 a) + + +instance Num a => AdditiveGroup (Vector3 a) where + zeroV = Vector3 0 0 0 + Vector3 x y z ^+^ Vector3 x' y' z' = Vector3 (x + x') (y + y') (z + z') + negateV (Vector3 x y z) = Vector3 (-x) (-y) (-z) + + +instance Num a => VectorSpace (Vector3 a) where + type Scalar (Vector3 a) = a + s *^ Vector3 x y z = Vector3 (s * x) (s * y) (s * z) + + +instance (AdditiveGroup a, Num a) => InnerSpace (Vector3 a) where + Vector3 x y z <.> Vector3 x' y' z' = x * x' + y * y' + z * z' + + +instance Num a => HasCross3 (Vector3 a) where + Vector3 x y z `cross3` Vector3 x' y' z' = Vector3 (y * z' - z * y') (z * x' - x * z') (x * y' - y * x') + + +instance Num a => AffineSpace (Vertex3 a) where + type Diff (Vertex3 a) = Vector3 a + Vertex3 x y z .-. Vertex3 x' y' z' = Vector3 (x - x') (y - y') (z - z') + Vertex3 x y z .+^ Vector3 x' y' z' = Vertex3 (x + x') (y + y') (z + z') diff --git a/src/Graphics/UI/Handa/Setup.hs b/src/Graphics/UI/Handa/Setup.hs --- a/src/Graphics/UI/Handa/Setup.hs +++ b/src/Graphics/UI/Handa/Setup.hs @@ -10,78 +10,169 @@ -} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + module Graphics.UI.Handa.Setup ( -- * Functions - setup + Setup(..) +, Stereo(..) +, Viewer(..) +, setup , handleArguments , idle ) where import Control.Monad (when) -import Data.Default (def) +import Data.AdditiveGroup (AdditiveGroup) +import Data.Aeson (FromJSON) +import Data.Binary (Binary(..)) +import Data.Data (Data) +import Data.Default (Default(def)) import Data.List ((\\)) -import Graphics.Rendering.DLP (DlpEncoding(..)) +import Data.Typeable (Typeable) +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import Graphics.Rendering.DLP (DlpEncoding) import Graphics.Rendering.Handa.Viewer (ViewerParameters(eyeSeparation), desktopViewer, laptopViewer, phoneViewer, projectorViewer, reshape) -import Graphics.Rendering.OpenGL (BlendingFactor(..), Capability(Enabled), ComparisonFunction(Less), Vector3(..), ($=), blend, blendFunc) -import Graphics.UI.GLUT (DisplayMode(..), IdleCallback, createWindow, depthFunc, getArgsAndInitialize, fullScreen, idleCallback, initialDisplayMode, postRedisplay, reshapeCallback) +import Graphics.Rendering.OpenGL (BlendingFactor(..), Capability(Enabled), ComparisonFunction(Less), MatrixComponent, ($=), blend, blendFunc) +import Graphics.UI.GLUT (DisplayMode(..), IdleCallback, createWindow, depthFunc, fullScreen, idleCallback, initialDisplayMode, initialize, postRedisplay, reshapeCallback) +import qualified Graphics.Rendering.DLP as D (DlpEncoding(..)) + +-- | The configuration for setting up the display. +data Setup a = + Setup + { + stereo :: Stereo -- ^ The type of stereo. + , switchEyes :: Bool -- ^ Whether to switch the left and right eyes. + , viewer :: Either (ViewerParameters a) Viewer -- ^ The viewer information. + , fullscreen :: Bool -- ^ Whether to display full screen. + } + deriving (Binary, Data, Eq, FromJSON, Generic, Read, Show, Typeable) + +instance Functor Setup where + fmap f Setup{..} = + Setup + { + stereo = stereo + , switchEyes = switchEyes + , viewer = case viewer of + Left x -> Left $ fmap f x + Right x -> Right x + , fullscreen = fullscreen + } + +instance Default (Setup a) where + def = Setup def False (Right def) False + + +-- | The type of stereo. +data Stereo = + DLP -- ^ Frame-sequential DLP 3D ReadySync stereo. + | QuadBuffer -- ^ Quad buffer stereo. + | Cardboard -- ^ Google Cardboard stereo. + | Mono -- ^ No stereo. + deriving (Binary, Bounded, Data, Enum, Eq, FromJSON, Generic, Ord, Read, Show, Typeable) + +instance Default Stereo where + def = Mono + + +-- | The viewer information. +data Viewer = + Phone -- ^ A typical phone. + | Laptop -- ^ A typical laptop. + | Desktop -- ^ A typical desktop display. + | Projector -- ^ A typical projector. + deriving (Binary, Bounded, Data, Enum, Eq, FromJSON, Generic, Ord, Read, Show, Typeable) + +instance Default Viewer where + def = Laptop + + -- | Set up a window with basic callbacks. This creates a double-buffered window with a depth buffer, a transparency blending function, a generic reshaping callback, and a redisplaying idle function. See 'handleArguments' for information on how command-line arguments are interpretted. -setup :: String -- ^ The window title. - -> IO (DlpEncoding, ViewerParameters, [String]) -- ^ An action returing the DLP encoding requested, the viewer parameters, and the uninterpretted arguments. -setup title = +setup :: (AdditiveGroup a, MatrixComponent a, RealFloat a, Storable a) + => String -- ^ The window title. + -> String -- ^ The program name. + -> [String] -- ^ The X11 arguments. + -> Setup a -- ^ The setup configuration. + -> IO (DlpEncoding, ViewerParameters a, [String]) -- ^ An action returing the DLP encoding requested, the viewer parameters, and the uninterpretted arguments. +setup title program arguments Setup{..} = do - (_, arguments) <- getArgsAndInitialize - initialDisplayMode $= [WithDepthBuffer, DoubleBuffered] + arguments' <- initialize program arguments + initialDisplayMode $= + (if stereo == QuadBuffer then (Stereoscopic :) else id) + [WithDepthBuffer, DoubleBuffered] _window <- createWindow title depthFunc $= Just Less blend $= Enabled blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - r@(_, viewerParameters, _) <- handleArguments arguments - reshapeCallback $= Just (reshape viewerParameters) + when fullscreen fullScreen + let + dlp = case stereo of + DLP -> D.FrameSequential + QuadBuffer -> D.QuadBuffer + Cardboard -> D.SideBySide + Mono -> D.LeftOnly + viewerParameters = case viewer of + Right Phone -> phoneViewer + Right Laptop -> laptopViewer + Right Desktop -> desktopViewer + Right Projector -> projectorViewer + Left parameters -> parameters + viewerParameters' = + if switchEyes + then viewerParameters {eyeSeparation = negate <$> eyeSeparation viewerParameters} + else viewerParameters + reshapeCallback $= Just (reshape viewerParameters') idleCallback $= Just idle - return r + return (dlp, viewerParameters', arguments') -- | Act on command-line arguments. -- --- * \"--fullscreen\" puts the application in full screen mode. +-- * \"--dlp\" puts the application in frame-sequential DLP (3D ReadySync) stereo mode. -- --- * \"--stereo\" puts the application in frame-sequential DLP stereo mode. +-- * \"--quadbuffer\" puts the application in quad-buffer stereo mode. -- -- * \"--cardboard\" puts the application in side-by-side (Google Cardboard) stereo mode. -- +-- * \"--switchEyes\" swaps the views of the left and right eyes. +-- -- * \"--phone\" sets the frustum for a typical smartphone. -- -- * \"--laptop\" sets the frustum for a typical laptop. -- -- * \"--desktop\" sets the frustum for a typical desktop monitor. -- --- * \"--projection1 sets the frustum for a typical projector. +-- * \"--projection\" sets the frustum for a typical projector. -- --- * \"--switchEyes\" swaps the views of the left and right eyes. -handleArguments :: [String] -> IO (DlpEncoding, ViewerParameters, [String]) +-- * \"--fullscreen\" puts the application in full screen mode. +handleArguments :: [String] -- ^ The arguments. + -> (Setup a, [String]) -- ^ The setup configuration and the remaining, uninterpretted, arguments. handleArguments arguments = - do - when ("--fullscreen" `elem` arguments) fullScreen - let - dlp - | "--stereo" `elem` arguments = FrameSequential - | "--cardboard" `elem` arguments = SideBySide - | otherwise = LeftOnly - viewerParameters - | "--phone" `elem` arguments = phoneViewer - | "--laptop" `elem` arguments = laptopViewer - | "--desktop" `elem` arguments = desktopViewer - | "--projector" `elem` arguments = projectorViewer - | otherwise = def - viewerParameters' = - if "--switchEyes" `elem` arguments - then viewerParameters {eyeSeparation = (\(Vector3 x y z) -> Vector3 (-x) (-y) (-z)) $ eyeSeparation viewerParameters} - else viewerParameters - keywords = ["--fullscreen", "--stereo", "--cardboard", "--phone", "--laptop", "--desktop", "--projector", "--switchEyes"] - return (dlp, viewerParameters', arguments \\ keywords) + let + stereo + | "--dlp" `elem` arguments = DLP + | "--cardboard" `elem` arguments = Cardboard + | "--quadbuffer" `elem` arguments = QuadBuffer + | otherwise = Mono + switchEyes = "--switchEyes" `elem` arguments + viewer + | "--phone" `elem` arguments = Right Phone + | "--laptop" `elem` arguments = Right Laptop + | "--desktop" `elem` arguments = Right Desktop + | "--projector" `elem` arguments = Right Projector + | otherwise = Right Laptop + fullscreen = "--fullscreen" `elem` arguments + keywords = ["--dlp", "--cardboard", "--switchEyes", "--phone", "--laptop", "--desktop", "--projector", "--fullscreen"] + in + (Setup{..}, arguments \\ keywords) -- | An idle callback that simply posts a request for redisplay.