diff --git a/opengl-dlp-stereo.cabal b/opengl-dlp-stereo.cabal --- a/opengl-dlp-stereo.cabal +++ b/opengl-dlp-stereo.cabal @@ -1,5 +1,5 @@ name: opengl-dlp-stereo -version: 0.1.4.1 +version: 0.1.5.2 synopsis: Library and example for using DLP stereo in OpenGL description: This package contains functions for rendering 3D stereo using DLP 3-D Ready Sync projectors and active-shutter stereo glasses. It also includes a sample application (see \<\>) and notes regarding hardware setup for DLP. In particular, note that this technique does not require a graphics card that supports @GL_STEREO@. This package also works with VR systems such as Google Cardboard \<\>. @@ -14,7 +14,7 @@ stability: Stable homepage: https://bitbucket.org/bwbush/opengl-dlp-stereo bug-reports: https://bwbush.atlassian.net/projects/HOGLDLP/issues/ -package-url: https://bitbucket.org/bwbush/opengl-dlp-stereo/downloads/opengl-dlp-stereo-0.1.4.1.tar.gz +package-url: https://bitbucket.org/bwbush/opengl-dlp-stereo/downloads/opengl-dlp-stereo-0.1.5.2.tar.gz extra-source-files: ReadMe.md @@ -25,12 +25,13 @@ library exposed-modules: Graphics.Rendering.DLP Graphics.Rendering.DLP.Callbacks - build-depends: base >= 4.6 && < 5 + build-depends: base >= 4.8.1 && < 5 , data-default >= 0.5.3 - , GLUT >= 2.4 - , OpenGL >= 2.8 - , vector >= 0.10 + , GLUT >= 2.7.0.1 + , OpenGL >= 2.12.0.1 + , vector >= 0.11 hs-source-dirs: src + ghc-options: -Wall default-language: Haskell2010 executable opengl-dlp-test @@ -41,4 +42,5 @@ , OpenGL , vector hs-source-dirs: src + ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Graphics/Rendering/DLP.hs b/src/Graphics/Rendering/DLP.hs --- a/src/Graphics/Rendering/DLP.hs +++ b/src/Graphics/Rendering/DLP.hs @@ -65,7 +65,6 @@ ) where -import Control.Applicative ((<$>)) import Control.Monad (unless, when) import Data.Bits ((.|.)) import Data.IORef (IORef, newIORef) @@ -77,11 +76,12 @@ -- | The type of DLP encoding. See the specification \<\> for further details. data DlpEncoding = - SideBySide -- ^ Side-by-side encoding, where the left image is stored to the left of the right image in the framebuffer. - | FrameSequential -- ^ Frame-sequential encoding, where left and right images alternate, each filling the whole framebuffer. - | TopAndBottom -- ^ Top-and-bottom encoding, where the top image is stored above the bottom image in the framebuffer. - | LeftOnly -- ^ Monoscopic with only the left eye's view. - | RightOnly -- ^ Monoscopic with only the right eye's view. + SideBySide -- ^ Side-by-side encoding, where the left image is stored to the left of the right image in the framebuffer. + | FrameSequential -- ^ Frame-sequential encoding, where left and right images alternate, each filling the whole framebuffer. + | TopAndBottom -- ^ Top-and-bottom encoding, where the top image is stored above the bottom image in the framebuffer. + | LeftOnly -- ^ Monoscopic with only the left eye's view. + | RightOnly -- ^ Monoscopic with only the right eye's view. + | QuadBuffer -- ^ Instead of DLP, use a quad buffer stereo. deriving (Eq, Read, Show) @@ -102,13 +102,15 @@ -- | Query whether to show the view from the specified eye for the current frame. Client code should call this function to determine which views to draw into the framebuffer. -showEye :: DlpEye -- ^ The eye in question. - -> DlpState -- ^ The current DLP state. - -> Bool -- ^ Whether the view of the specified eye should be shown for the current frame. +showEye :: DlpEye -- ^ The eye in question. + -> DlpState -- ^ The current DLP state. + -> Bool -- ^ Whether the view of the specified eye should be shown for the current frame. showEye LeftDlp (DlpState FrameSequential frame) = frame `mod` 2 == 0 showEye RightDlp (DlpState FrameSequential frame) = frame `mod` 2 /= 0 showEye RightDlp (DlpState LeftOnly _ ) = False showEye LeftDlp (DlpState RightOnly _ ) = False +showEye LeftDlp (DlpState QuadBuffer frame) = frame `mod` 2 == 0 +showEye RightDlp (DlpState QuadBuffer frame) = frame `mod` 2 /= 0 showEye _ _ = True @@ -149,22 +151,24 @@ -- | Color constants. -red, green, blue, cyan, magenta, yellow :: Word32 +red, green, blue, cyan, magenta, yellow, clear :: Word32 red = 0x00FF0000 green = 0x0000FF00 blue = 0x000000FF cyan = green .|. blue magenta = red .|. blue yellow = red .|. green +clear = 0xFF000000 -- | Determine the correct color of the reference line for a given DLP encoding and DLP state. dlpColor :: DlpState -> Word32 -dlpColor (DlpState SideBySide frame) = if frame `mod` 2 == 0 then red else cyan -dlpColor (DlpState FrameSequential frame) = if frame `mod` 4 < 2 then green else magenta -dlpColor (DlpState TopAndBottom frame) = if frame `mod` 2 == 0 then blue else yellow -dlpColor (DlpState LeftOnly _ ) = undefined -- Safe because drawDlp never calls the function for this DLP mode. -dlpColor (DlpState RightOnly _ ) = undefined -- Safe because drawDlp never acalls te function for this DLP mode. +dlpColor (DlpState SideBySide frame) = if frame `mod` 2 == 0 then red else cyan +dlpColor (DlpState FrameSequential frame) = if frame `mod` 4 < 2 then green else magenta +dlpColor (DlpState TopAndBottom frame) = if frame `mod` 2 == 0 then blue else yellow +dlpColor (DlpState LeftOnly _ ) = undefined -- Safe because drawDlp never calls the function for this DLP mode. +dlpColor (DlpState RightOnly _ ) = undefined -- Safe because drawDlp never acalls te function for this DLP mode. +dlpColor (DlpState QuadBuffer _ ) = clear -- | Determine the correct color of the reference line for a given DLP encoding and DLP state. diff --git a/src/Graphics/Rendering/DLP/Callbacks.hs b/src/Graphics/Rendering/DLP/Callbacks.hs --- a/src/Graphics/Rendering/DLP/Callbacks.hs +++ b/src/Graphics/Rendering/DLP/Callbacks.hs @@ -44,8 +44,9 @@ import Data.Default (Default(..)) -import Graphics.Rendering.DLP (DlpEncoding(FrameSequential), DlpEye(..), drawDlp, initDlp, showEye, whichView) -import Graphics.Rendering.OpenGL (ClearBuffer(..), SettableStateVar, ($=!), clear, get, makeSettableStateVar, viewport) +import Data.IORef (IORef) +import Graphics.Rendering.DLP (DlpEncoding(FrameSequential, QuadBuffer), DlpEye(..), DlpState, drawDlp, initDlp, showEye, whichView) +import Graphics.Rendering.OpenGL (BufferMode(BackLeftBuffer, BackRightBuffer), ClearBuffer(..), SettableStateVar, ($=!), clear, drawBuffer, get, makeSettableStateVar, viewport) import Graphics.UI.GLUT (DisplayCallback, displayCallback, swapBuffers) @@ -81,25 +82,55 @@ makeSettableStateVar setDlpDisplayCallback where setDlpDisplayCallback :: DlpDisplay -> IO () - setDlpDisplayCallback DlpDisplay{..} = + setDlpDisplayCallback dlpDisplay@DlpDisplay{..} = do dlpRef <- initDlp dlpEncoding displayCallback $=! - do - vpSaved <- get viewport - preDisplay - dlp <- get dlpRef - sequence_ - [ - do - vp <- whichView eye dlp - viewport $=! vp - doDisplay eye - viewport $=! vpSaved - | - eye <- [LeftDlp, RightDlp] - , showEye eye dlp - ] - postDisplay - drawDlp dlpRef - swapBuffers + case dlpEncoding of + QuadBuffer -> doQuad dlpRef dlpDisplay + _ -> doDlp dlpRef dlpDisplay + + +-- | Make a display callback for DLP. +doDlp :: IORef DlpState -- ^ A reference to the DLP state. + -> DlpDisplay -- ^ The display information. + -> DisplayCallback -- ^ The display callback. +doDlp dlpRef DlpDisplay{..} = + do + vpSaved <- get viewport + preDisplay + dlp <- get dlpRef + sequence_ + [ + do + vp <- whichView eye dlp + viewport $=! vp + doDisplay eye + viewport $=! vpSaved + | + eye <- [LeftDlp, RightDlp] + , showEye eye dlp + ] + postDisplay + drawDlp dlpRef + swapBuffers + + +-- | Make a display callback for quad buffer stereo. +doQuad :: IORef DlpState -- ^ A reference to the DLP state. + -> DlpDisplay -- ^ The display information. + -> DisplayCallback -- ^ The display callback. +doQuad dlpRef DlpDisplay{..} = + do + sequence_ + [ + do + drawBuffer $=! buffer + preDisplay + doDisplay eye + postDisplay + drawDlp dlpRef + | + (eye, buffer) <- zip [LeftDlp, RightDlp] [BackLeftBuffer, BackRightBuffer] + ] + swapBuffers diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -33,16 +33,18 @@ putStrLn " Use the --fullscreen flag to run in full screen mode." putStrLn " Use the --mono flag to run in monoscopic mode." putStrLn " Use the --cardboard flag to run in side-by-side (Google Cardboard) mode." + putStrLn " Use the --quadbuffer flag to run in quad buffer stereo mode." (_, arguments) <- getArgsAndInitialize - initialDisplayMode $=! [WithDepthBuffer, DoubleBuffered] + initialDisplayMode $=! (if "--quadbuffer" `elem` arguments then (Stereoscopic :) else id) [WithDepthBuffer, DoubleBuffered] _ <- createWindow "DLP Stereo OpenGL Example" depthFunc $=! Just Less when ("--fullscreen" `elem` arguments) fullScreen angle <- newIORef 0 let encoding - | "--mono" `elem` arguments = LeftOnly - | "--cardboard" `elem` arguments = SideBySide - | otherwise = FrameSequential + | "--quadbuffer" `elem` arguments = QuadBuffer + | "--mono" `elem` arguments = LeftOnly + | "--cardboard" `elem` arguments = SideBySide + | otherwise = FrameSequential dlpDisplayCallback $=! def {dlpEncoding = encoding, doDisplay = display angle} idleCallback $=! Just (idle angle) mainLoop