module Graphics.Rendering.Handa.Projection (
Screen(..)
, upperRight
, aspectRatio
, throwRatio
, OffAxisProjection(..)
, projection
, fetchProjection
) 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.List.Split (chunksOf)
import Data.VectorSpace ((*^), (<.>), magnitude, normalized)
import GHC.Generics (Generic)
import Graphics.Rendering.OpenGL (GLmatrix, MatrixComponent, MatrixOrder(RowMajor), Vector3(..), Vertex3(..), frustum, get, getMatrixComponents, matrix, multMatrix, newMatrix, translate)
import Graphics.Rendering.OpenGL.GL.Tensor.Instances (origin)
data Screen a =
Screen
{
lowerLeft :: Vertex3 a
, lowerRight :: Vertex3 a
, upperLeft :: Vertex3 a
}
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
}
upperRight :: (Num a)
=> Screen a
-> Vertex3 a
upperRight Screen{..} = lowerRight .+^ (upperLeft .-. lowerLeft)
aspectRatio :: (AdditiveGroup a, RealFloat a)
=> Screen a
-> a
aspectRatio Screen{..} =
let
width = magnitude $ lowerRight .-. lowerLeft
height = magnitude $ upperLeft .-. lowerLeft
in
width / height
throwRatio :: (AdditiveGroup a, RealFloat a)
=> Screen a
-> Vertex3 a
-> a
throwRatio Screen{..} eye =
let
width = magnitude $ lowerRight .-. lowerLeft
vn = normalized (lowerRight .-. lowerLeft) `cross3` normalized (upperLeft .-. lowerLeft)
throw = (lowerLeft .-. eye) <.> vn
in
throw / width
data OffAxisProjection =
KooimaOffAxis
| VTKOffAxis
deriving (Eq, Read, Show)
projection :: forall a . (AdditiveGroup a, MatrixComponent a, RealFloat a)
=> OffAxisProjection
-> Screen a
-> Vertex3 a
-> a
-> a
-> IO ()
projection KooimaOffAxis Screen{..} eye near far =
do
let
vr = normalized $ lowerRight .-. lowerLeft
vu = normalized $ upperLeft .-. lowerLeft
vn = normalized $ vr `cross3` vu
va = lowerLeft .-. eye
vb = lowerRight .-. eye
vc = upperLeft .-. eye
throw = va <.> vn
scaling = near / throw
left = realToFrac $ (vr <.> va) * scaling
right = realToFrac $ (vr <.> vb) * scaling
bottom = realToFrac $ (vu <.> va) * scaling
top = realToFrac $ (vu <.> vc) * scaling
m = [[x, y, z, 0] | Vector3 x y z <- [vr, vu, vn]] ++ [[0, 0, 0, 1]]
frustum left right bottom top (realToFrac near) (realToFrac far)
multMatrix =<< (newMatrix RowMajor $ concat m :: IO (GLmatrix a))
translate $ origin .-. eye
projection VTKOffAxis s@Screen{..} eye near far =
do
let
vr = normalized $ lowerRight .-. lowerLeft
vu = normalized $ upperRight s .-. lowerRight
vn = normalized $ vr `cross3` vu
idet = 1 / (vr <.> vu `cross3` vn)
ur = idet *^ vu `cross3` vn
uu = idet *^ vn `cross3` vr
un = idet *^ vr `cross3` vu
va = lowerLeft .-. eye
vd = upperRight s .-. eye
throw = va <.> un
scaling = near / throw
left = realToFrac $ (ur <.> va) * scaling
right = realToFrac $ (ur <.> vd) * scaling
bottom = realToFrac $ (uu <.> va) * scaling
top = realToFrac $ (uu <.> vd) * scaling
m = [[x, y, z, 0] | Vector3 x y z <- [ur, uu, un]] ++ [[0, 0, 0, 1]]
frustum left right bottom top (realToFrac near) (realToFrac far)
multMatrix =<< (newMatrix RowMajor $ concat m :: IO (GLmatrix a))
translate $ origin .-. eye
fetchProjection :: forall a . (MatrixComponent a, RealFloat a)
=> IO [[a]]
fetchProjection =
do
m <- get $ matrix Nothing :: IO (GLmatrix a)
chunksOf 4 <$> getMatrixComponents RowMajor m