handa-opengl 0.1.6.1 → 0.1.11.2

raw patch · 7 files changed

+507/−106 lines, 7 filesdep +aesondep +binarydep +vector-spacedep ~GLUTdep ~OpenGLdep ~arrayPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, binary, vector-space

Dependency ranges changed: GLUT, OpenGL, array, base, opengl-dlp-stereo

API changes (from Hackage documentation)

Files

• handa-opengl.cabal +14/−8
• src/Foreign/C/Types/Instances.hs +44/−0
• src/Graphics/Rendering/Handa/Projection.hs +122/−0
• src/Graphics/Rendering/Handa/Shape.hs +3/−4
• src/Graphics/Rendering/Handa/Viewer.hs +113/−57
• src/Graphics/Rendering/OpenGL/GL/Tensor/Instances.hs +83/−0
• src/Graphics/UI/Handa/Setup.hs +128/−37

@@ -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

@@ -0,0 +1,44 @@+{-|+Module      :  Foreign.C.Types.Instances+Copyright   :  (c) 2015 Brian W Bush+License     :  MIT+Maintainer  :  Brian W Bush <consult@brianwbush.info>+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

@@ -0,0 +1,122 @@+{-|+Module      :  Graphics.Rendering.Handa.Projection+Copyright   :  (c) 2015 Brian W Bush+License     :  MIT+Maintainer  :  Brian W Bush <consult@brianwbush.info>+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 \<<http://csc.lsu.edu/~kooima/pdfs/gen-perspective.pdf>\> .+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

@@ -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

@@ -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      {

@@ -0,0 +1,83 @@+{-|+Module      :  Graphics.Rendering.OpenGL.GL.Tensor.Instances+Copyright   :  (c) 2015 Brian W Bush+License     :  MIT+Maintainer  :  Brian W Bush <consult@brianwbush.info>+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')

@@ -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.