module Graphics.Rendering.Handa.Viewer (
ViewerParameters(..)
, viewerGeometry
, displayAspectRatio
, displayThrowRatio
, fieldOfView
, phoneViewer
, laptopViewer
, desktopViewer
, projectorViewer
, glassesViewer
, reshape
, loadViewer
, dlpViewerDisplay
, dlpViewerDisplay'
) where
import Data.AdditiveGroup (AdditiveGroup)
import Data.AffineSpace ((.+^))
import Data.Aeson (FromJSON)
import Data.Binary (Binary)
import Data.Data (Data)
import Data.VectorSpace ((*^))
import Data.Default (Default, def)
import Data.IORef (IORef)
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 (OffAxisProjection(VTKOffAxis), Screen(..), aspectRatio, projection, throwRatio)
import Graphics.Rendering.Handa.Util (degree)
import Graphics.Rendering.OpenGL (GLdouble, MatrixComponent, MatrixMode(..), Position(..), Vector3(..), Vertex3(..), ($=!), get, loadIdentity, lookAt, matrixMode, scale, viewport)
import Graphics.Rendering.OpenGL.GL.Tensor.Instances ()
import Graphics.UI.GLUT (DisplayCallback, ReshapeCallback)
data ViewerParameters a =
ViewerParameters
{
screen :: Screen a
, nearPlane :: a
, farPlane :: a
, eyePosition :: Vertex3 a
, eyeSeparation :: Vector3 a
, eyeUpward :: Vector3 a
, sceneCenter :: Vertex3 a
, sceneScale :: Vector3 a
}
deriving (Binary, Data, Eq, FromJSON, Generic, Read, Show)
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 = laptopViewer
viewerGeometry :: (Fractional a, Storable a)
=> a
-> a
-> a
-> ViewerParameters a
viewerGeometry aspect throw distance =
ViewerParameters
{
screen =
Screen
{
lowerLeft = Vertex3 ( width / 2) ( height / 2) 0
, lowerRight = Vertex3 ( width / 2) ( height / 2) 0
, upperLeft = Vertex3 ( width / 2) ( height / 2) 0
}
, nearPlane = 1
, farPlane = 5 * distance
, eyePosition = Vertex3 0 0 distance
, eyeSeparation = Vector3 (typical * (1 comfort)) 0 0
, eyeUpward = Vector3 0 1 0
, sceneCenter = Vertex3 0 0 1
, sceneScale = size *^ Vector3 aspect 1 1
}
where
width = distance / throw
height = width / aspect
margin = 0.10
size = (1 margin) / (1 / height + 1 / distance)
typical = 2.5
comfort = 0.50
phoneViewer :: (Fractional a, Storable a) => ViewerParameters a
phoneViewer = viewerGeometry (1280 / 768) 0.5 18
laptopViewer :: (Fractional a, Storable a) => ViewerParameters a
laptopViewer = viewerGeometry (1920 / 1080) 1.8 24
desktopViewer :: (Fractional a, Storable a) => ViewerParameters a
desktopViewer = viewerGeometry (1920 / 1080) 1.6 32
projectorViewer :: (Fractional a, Storable a) => ViewerParameters a
projectorViewer = viewerGeometry 1.6 1.5 36
glassesViewer :: (Fractional a, Storable a) => ViewerParameters a
glassesViewer =
viewerGeometry (realToFrac $ pixelWidth / pixelHeight) (distance / width) $ 0.2 * distance
where
distance = 4 * 39.37
pixelWidth = 852
pixelHeight = 480
pixelDiagonal = sqrt (pixelWidth * pixelWidth + pixelHeight * pixelHeight)
width = 100 * realToFrac (pixelWidth / pixelDiagonal :: Double)
displayAspectRatio :: (AdditiveGroup a, RealFloat a, Storable a)
=> ViewerParameters a
-> a
displayAspectRatio ViewerParameters{..} = aspectRatio screen
displayThrowRatio :: (AdditiveGroup a, RealFloat a, Storable a)
=> ViewerParameters a
-> a
displayThrowRatio ViewerParameters{..} = throwRatio screen eyePosition
fieldOfView :: (AdditiveGroup a, RealFloat a, Storable a)
=> ViewerParameters a
-> a
fieldOfView ViewerParameters{..} = 2 * atan2 0.5 (throwRatio screen eyePosition) * degree
reshape :: (AdditiveGroup a, MatrixComponent a, RealFloat a, Storable a)
=> ViewerParameters a
-> ReshapeCallback
reshape ViewerParameters{..} wh =
do
viewport $=! (Position 0 0, wh)
matrixMode $=! Projection
loadIdentity
projection VTKOffAxis screen eyePosition nearPlane farPlane
matrixMode $=! Modelview 0
loadViewer :: (AdditiveGroup a, MatrixComponent a, RealFloat a, Storable a)
=> Bool
-> ViewerParameters a
-> DlpEye
-> IO ()
loadViewer onAxis ViewerParameters{..} eye =
let
offset =
case eye of
LeftDlp -> 0.5
RightDlp -> 0.5
eyePosition' = eyePosition .+^ offset *^ eyeSeparation
Vector3 sx sy sz = realToFrac <$> sceneScale :: Vector3 GLdouble
in
if onAxis
then do
loadIdentity
lookAt
(realToFrac <$> eyePosition')
(realToFrac <$> sceneCenter)
(realToFrac <$> eyeUpward)
scale sx sy sz
else do
matrixMode $=! Projection
loadIdentity
projection VTKOffAxis screen eyePosition' nearPlane farPlane
matrixMode $=! Modelview 0
loadIdentity
scale sx sy sz
dlpViewerDisplay :: (AdditiveGroup a, MatrixComponent a, RealFloat a, Storable a)
=> Bool
-> DlpEncoding
-> ViewerParameters a
-> DisplayCallback
-> DlpDisplay
dlpViewerDisplay onAxis encoding viewerParameters display =
def
{
dlpEncoding = encoding
, doDisplay = \eye -> loadViewer onAxis viewerParameters eye >> display
}
dlpViewerDisplay' :: (AdditiveGroup a, MatrixComponent a, RealFloat a, Storable a)
=> Bool
-> DlpEncoding
-> IORef (ViewerParameters a)
-> DisplayCallback
-> DlpDisplay
dlpViewerDisplay' onAxis encoding viewerParameters display =
def
{
dlpEncoding = encoding
, doDisplay = \eye -> do
viewerParameters' <- get viewerParameters
loadViewer onAxis viewerParameters' eye
display
}