{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
{-# Language StandaloneDeriving #-}
{-# Language DeriveFunctor #-}
{-# Language DeriveGeneric #-}
{-# Language TypeSynonymInstances #-}

module Vis.VisObject ( VisObject(..)
                     , drawObjects
                     , LoadedObjModel(..)
                     , loadObjModel
                     , setPerspectiveMode
                     ) where

import GHC.Generics ( Generic )

import Control.Monad ( when )
import qualified Data.Binary as B
import qualified Data.Foldable as F
import Data.Maybe ( fromJust, isJust )
import Data.Vector.Binary ()
import qualified Data.Vector.Storable as VS
import Data.Word ( Word8 )
import Graphics.GL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT
import Graphics.UI.GLUT ( BitmapFont(..), Capability(..), Color4(..), Face(..)
                        , Flavour(..), MatrixMode(..), PrimitiveMode(..), Size(..)
                        , Vertex3(..), Vector3(..)
                        , ($=)
                        )

import SpatialMath

import qualified Vis.GlossColor as GlossColor

glColorOfColor :: GlossColor.Color -> Color4 GLfloat
glColorOfColor :: Color -> Color4 GLfloat
glColorOfColor = (\(GLfloat
r,GLfloat
g,GLfloat
b,GLfloat
a) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a. a -> a -> a -> a -> Color4 a
Color4 GLfloat
r GLfloat
g GLfloat
b GLfloat
a)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> (GLfloat, GLfloat, GLfloat, GLfloat)
GlossColor.rgbaOfColor

setColor :: GlossColor.Color -> IO ()
setColor :: Color -> IO ()
setColor = forall a. Color a => a -> IO ()
GLUT.color forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Color4 GLfloat
glColorOfColor

setMaterialDiffuse :: GlossColor.Color -> IO ()
setMaterialDiffuse :: Color -> IO ()
setMaterialDiffuse Color
col = Face -> StateVar (Color4 GLfloat)
GLUT.materialDiffuse Face
Front forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Color -> Color4 GLfloat
glColorOfColor Color
col)

data VisObject a = VisObjects [VisObject a]
                 | Trans (V3 a) (VisObject a)
                 | RotQuat (Quaternion a) (VisObject a)
                 | RotDcm (M33 a) (VisObject a)
                 | RotEulerRad (Euler a) (VisObject a)
                 | RotEulerDeg (Euler a) (VisObject a) -- degrees more efficient
                 | Scale (a,a,a) (VisObject a)
                 | Cylinder (a,a) GlossColor.Color
                 | Box (a,a,a) Flavour GlossColor.Color
                 | Cube a Flavour GlossColor.Color
                 | Sphere a Flavour GlossColor.Color
                 | Ellipsoid (a,a,a) Flavour GlossColor.Color
                 | Line (Maybe a) [V3 a] GlossColor.Color
                 | Line' (Maybe a) [(V3 a,GlossColor.Color)]
                 | Arrow (a,a) (V3 a) GlossColor.Color
                 | Axes (a,a)
                 | Plane (V3 a) GlossColor.Color GlossColor.Color
                 | Triangle (V3 a) (V3 a) (V3 a) GlossColor.Color
                 | Quad (V3 a) (V3 a) (V3 a) (V3 a) GlossColor.Color
                 | Text3d String (V3 a) BitmapFont GlossColor.Color
                 | Text2d String (a,a) BitmapFont GlossColor.Color
                 | Points [V3 a] (Maybe GLfloat) GlossColor.Color
                 | ObjModel LoadedObjModel GlossColor.Color
                 deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (VisObject a) x -> VisObject a
forall a x. VisObject a -> Rep (VisObject a) x
$cto :: forall a x. Rep (VisObject a) x -> VisObject a
$cfrom :: forall a x. VisObject a -> Rep (VisObject a) x
Generic, forall a b. a -> VisObject b -> VisObject a
forall a b. (a -> b) -> VisObject a -> VisObject b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> VisObject b -> VisObject a
$c<$ :: forall a b. a -> VisObject b -> VisObject a
fmap :: forall a b. (a -> b) -> VisObject a -> VisObject b
$cfmap :: forall a b. (a -> b) -> VisObject a -> VisObject b
Functor)

data LoadedObjModel = LoadedObjModel (VS.Vector Double) (VS.Vector Double) Int deriving (forall x. Rep LoadedObjModel x -> LoadedObjModel
forall x. LoadedObjModel -> Rep LoadedObjModel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LoadedObjModel x -> LoadedObjModel
$cfrom :: forall x. LoadedObjModel -> Rep LoadedObjModel x
Generic)

instance B.Binary LoadedObjModel

toFlavour :: Bool -> Flavour
toFlavour :: Bool -> Flavour
toFlavour Bool
False = Flavour
Solid
toFlavour Bool
True = Flavour
Wireframe

fromFlavour :: Flavour -> Bool
fromFlavour :: Flavour -> Bool
fromFlavour Flavour
Solid = Bool
False
fromFlavour Flavour
Wireframe = Bool
True

instance B.Binary Flavour where
  put :: Flavour -> Put
put = forall t. Binary t => t -> Put
B.put forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flavour -> Bool
fromFlavour
  get :: Get Flavour
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Flavour
toFlavour forall t. Binary t => Get t
B.get


fromBitmapFont :: BitmapFont -> Word8
fromBitmapFont :: BitmapFont -> Word8
fromBitmapFont BitmapFont
Fixed8By13   = Word8
0 :: Word8
fromBitmapFont BitmapFont
Fixed9By15   = Word8
1 :: Word8
fromBitmapFont BitmapFont
TimesRoman10 = Word8
2 :: Word8
fromBitmapFont BitmapFont
TimesRoman24 = Word8
3 :: Word8
fromBitmapFont BitmapFont
Helvetica10  = Word8
4 :: Word8
fromBitmapFont BitmapFont
Helvetica12  = Word8
5 :: Word8
fromBitmapFont BitmapFont
Helvetica18  = Word8
6 :: Word8

toBitmapFont :: Word8 -> BitmapFont
toBitmapFont :: Word8 -> BitmapFont
toBitmapFont Word8
0 = BitmapFont
Fixed8By13
toBitmapFont Word8
1 = BitmapFont
Fixed9By15
toBitmapFont Word8
2 = BitmapFont
TimesRoman10
toBitmapFont Word8
3 = BitmapFont
TimesRoman24
toBitmapFont Word8
4 = BitmapFont
Helvetica10
toBitmapFont Word8
5 = BitmapFont
Helvetica12
toBitmapFont Word8
6 = BitmapFont
Helvetica18
toBitmapFont Word8
k = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"deserializing BitmapFont got bad value (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
k forall a. [a] -> [a] -> [a]
++ String
")"

instance B.Binary BitmapFont where
  put :: BitmapFont -> Put
put = forall t. Binary t => t -> Put
B.put forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitmapFont -> Word8
fromBitmapFont
  get :: Get BitmapFont
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> BitmapFont
toBitmapFont forall t. Binary t => Get t
B.get


fromColor :: GlossColor.Color -> (Float,Float,Float,Float)
fromColor :: Color -> (GLfloat, GLfloat, GLfloat, GLfloat)
fromColor = Color -> (GLfloat, GLfloat, GLfloat, GLfloat)
GlossColor.rgbaOfColor

toColor :: (Float,Float,Float,Float) -> GlossColor.Color
toColor :: (GLfloat, GLfloat, GLfloat, GLfloat) -> Color
toColor (GLfloat
r,GLfloat
g,GLfloat
b,GLfloat
a) = GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color
GlossColor.makeColor GLfloat
r GLfloat
g GLfloat
b GLfloat
a

instance B.Binary (GlossColor.Color) where
  put :: Color -> Put
put = forall t. Binary t => t -> Put
B.put forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> (GLfloat, GLfloat, GLfloat, GLfloat)
fromColor
  get :: Get Color
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GLfloat, GLfloat, GLfloat, GLfloat) -> Color
toColor forall t. Binary t => Get t
B.get


instance B.Binary a => B.Binary (VisObject a)

setPerspectiveMode :: IO ()
setPerspectiveMode :: IO ()
setPerspectiveMode = do
  (Position
_, Size GLsizei
w GLsizei
h) <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get StateVar (Position, Size)
GLUT.viewport
  StateVar MatrixMode
GLUT.matrixMode forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= MatrixMode
Projection
  IO ()
GLUT.loadIdentity
  Double -> Double -> Double -> Double -> IO ()
GLUT.perspective Double
40 (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
w forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
h) Double
0.1 Double
1000
  StateVar MatrixMode
GLUT.matrixMode forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> MatrixMode
Modelview GLsizei
0

drawObjects :: VisObject GLdouble -> IO ()
drawObjects :: VisObject Double -> IO ()
drawObjects VisObject Double
objects = do
  IO ()
setPerspectiveMode
  VisObject Double -> IO ()
drawObject VisObject Double
objects

drawObject :: VisObject GLdouble -> IO ()
-- list of objects
drawObject :: VisObject Double -> IO ()
drawObject (VisObjects [VisObject Double]
xs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VisObject Double -> IO ()
drawObject [VisObject Double]
xs

-- list of objects
drawObject (Trans (V3 Double
x Double
y Double
z) VisObject Double
visobj) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    forall c. MatrixComponent c => Vector3 c -> IO ()
GLUT.translate (forall a. a -> a -> a -> Vector3 a
Vector3 Double
x Double
y Double
z :: Vector3 GLdouble)
    VisObject Double -> IO ()
drawObject VisObject Double
visobj

drawObject (RotQuat Quaternion Double
quat VisObject Double
visobj) = VisObject Double -> IO ()
drawObject (forall a. M33 a -> VisObject a -> VisObject a
RotDcm (forall a. Num a => Quaternion a -> M33 a
dcmOfQuat Quaternion Double
quat) VisObject Double
visobj)

drawObject (RotDcm (V3 (V3 Double
m00 Double
m01 Double
m02) (V3 Double
m10 Double
m11 Double
m12) (V3 Double
m20 Double
m21 Double
m22)) VisObject Double
visobject) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    GLmatrix Double
mat <- forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
MatrixOrder -> [c] -> IO (m c)
GLUT.newMatrix MatrixOrder
GLUT.ColumnMajor
      [ Double
m00, Double
m01, Double
m02, Double
0
      , Double
m10, Double
m11, Double
m12, Double
0
      , Double
m20, Double
m21, Double
m22, Double
0
      ,   Double
0,   Double
0,   Double
0, Double
1
      ]
      :: IO (GLUT.GLmatrix GLdouble)
    forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
m c -> IO ()
GLUT.multMatrix GLmatrix Double
mat
    VisObject Double -> IO ()
drawObject VisObject Double
visobject

drawObject (RotEulerRad Euler Double
euler VisObject Double
visobj) =
  VisObject Double -> IO ()
drawObject forall a b. (a -> b) -> a -> b
$ forall a. Euler a -> VisObject a -> VisObject a
RotEulerDeg (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Double
180forall a. Fractional a => a -> a -> a
/forall a. Floating a => a
pi)forall a. Num a => a -> a -> a
*) Euler Double
euler) VisObject Double
visobj

drawObject (RotEulerDeg (Euler Double
yaw Double
pitch Double
roll) VisObject Double
visobj) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GLUT.rotate Double
yaw   (forall a. a -> a -> a -> Vector3 a
Vector3 Double
0 Double
0 Double
1)
    forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GLUT.rotate Double
pitch (forall a. a -> a -> a -> Vector3 a
Vector3 Double
0 Double
1 Double
0)
    forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GLUT.rotate Double
roll  (forall a. a -> a -> a -> Vector3 a
Vector3 Double
1 Double
0 Double
0)
    VisObject Double -> IO ()
drawObject VisObject Double
visobj

drawObject (Scale (Double
sx,Double
sy,Double
sz) VisObject Double
visobj) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    StateVar Capability
GLUT.normalize forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
    forall c. MatrixComponent c => c -> c -> c -> IO ()
GLUT.scale Double
sx Double
sy Double
sz
    VisObject Double -> IO ()
drawObject VisObject Double
visobj
    StateVar Capability
GLUT.normalize forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled

-- triangle
drawObject (Triangle (V3 Double
x0 Double
y0 Double
z0) (V3 Double
x1 Double
y1 Double
z1) (V3 Double
x2 Double
y2 Double
z2) Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    Color -> IO ()
setMaterialDiffuse Color
col
    Color -> IO ()
setColor Color
col
    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBegin GLenum
GL_TRIANGLES
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
x0 Double
y0 Double
z0
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
x1 Double
y1 Double
z1
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
x2 Double
y2 Double
z2
    forall (m :: * -> *). MonadIO m => m ()
glEnd

-- quad
drawObject (Quad (V3 Double
x0 Double
y0 Double
z0) (V3 Double
x1 Double
y1 Double
z1) (V3 Double
x2 Double
y2 Double
z2) (V3 Double
x3 Double
y3 Double
z3) Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
    Color -> IO ()
setColor Color
col
    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBegin GLenum
GL_QUADS
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
x0 Double
y0 Double
z0
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
x1 Double
y1 Double
z1
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
x2 Double
y2 Double
z2
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
x3 Double
y3 Double
z3
    forall (m :: * -> *). MonadIO m => m ()
glEnd
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

-- cylinder
drawObject (Cylinder (Double
height,Double
radius) Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    Color -> IO ()
setMaterialDiffuse Color
col
    Color -> IO ()
setColor Color
col

    -- GLUT.translate (Vector3 0 0 (-height/2) :: Vector3 GLdouble)

    let nslices :: Int
nslices = Int
10 :: Int
        nstacks :: Int
nstacks = Int
10 :: Int

        -- Pre-computed circle
        sinCosTable :: [(Double, Double)]
sinCosTable = forall a b. (a -> b) -> [a] -> [b]
map (\Double
q -> (forall a. Floating a => a -> a
sin Double
q, forall a. Floating a => a -> a
cos Double
q)) [Double]
angles
          where
            angle :: Double
angle = Double
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nslices)
            angles :: [Double]
angles = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Double
angleforall a. Num a => a -> a -> a
*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Int
0..(Int
nslicesforall a. Num a => a -> a -> a
+Int
1)]

    -- Cover the base and top
    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBegin GLenum
GL_TRIANGLE_FAN
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glNormal3d Double
0 Double
0 (-Double
1)
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
0 Double
0 Double
0
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Double
s,Double
c) -> forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d (Double
cforall a. Num a => a -> a -> a
*Double
radius) (Double
sforall a. Num a => a -> a -> a
*Double
radius) Double
0) [(Double, Double)]
sinCosTable
    forall (m :: * -> *). MonadIO m => m ()
glEnd

    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBegin GLenum
GL_TRIANGLE_FAN
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glNormal3d Double
0 Double
0 Double
1
    forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d Double
0 Double
0 Double
height
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Double
s,Double
c) -> forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d (Double
cforall a. Num a => a -> a -> a
*Double
radius) (Double
sforall a. Num a => a -> a -> a
*Double
radius) Double
height) (forall a. [a] -> [a]
reverse [(Double, Double)]
sinCosTable)
    forall (m :: * -> *). MonadIO m => m ()
glEnd

    let -- Do the stacks
        -- Step in z and radius as stacks are drawn.
        zSteps :: [Double]
zSteps = forall a b. (a -> b) -> [a] -> [b]
map (\Int
k -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k)forall a. Num a => a -> a -> a
*Double
heightforall a. Fractional a => a -> a -> a
/(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nstacks)) [Int
0..Int
nstacks]
        drawSlice :: Double -> Double -> (Double, Double) -> m ()
drawSlice Double
z0 Double
z1 (Double
s,Double
c) = do
          forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glNormal3d  Double
c          Double
s         Double
0
          forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d (Double
cforall a. Num a => a -> a -> a
*Double
radius) (Double
sforall a. Num a => a -> a -> a
*Double
radius) Double
z0
          forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glVertex3d (Double
cforall a. Num a => a -> a -> a
*Double
radius) (Double
sforall a. Num a => a -> a -> a
*Double
radius) Double
z1

        drawSlices :: (Double, Double) -> m ()
drawSlices (Double
z0,Double
z1) = do
          forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBegin GLenum
GL_QUAD_STRIP
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {m :: * -> *}.
MonadIO m =>
Double -> Double -> (Double, Double) -> m ()
drawSlice Double
z0 Double
z1) [(Double, Double)]
sinCosTable
          forall (m :: * -> *). MonadIO m => m ()
glEnd

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}. MonadIO m => (Double, Double) -> m ()
drawSlices forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
init [Double]
zSteps) (forall a. [a] -> [a]
tail [Double]
zSteps)

-- sphere
drawObject (Sphere Double
r Flavour
flav Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    Color -> IO ()
setMaterialDiffuse Color
col
    Color -> IO ()
setColor Color
col
    forall (m :: * -> *). MonadIO m => Flavour -> Object -> m ()
GLUT.renderObject Flavour
flav (Double -> GLsizei -> GLsizei -> Object
GLUT.Sphere' (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
r) GLsizei
20 GLsizei
20)

-- ellipsoid
drawObject (Ellipsoid (Double
sx,Double
sy,Double
sz) Flavour
flav Color
col) = VisObject Double -> IO ()
drawObject forall a b. (a -> b) -> a -> b
$ forall a. (a, a, a) -> VisObject a -> VisObject a
Scale (Double
sx,Double
sy,Double
sz) forall a b. (a -> b) -> a -> b
$ forall a. a -> Flavour -> Color -> VisObject a
Sphere Double
1 Flavour
flav Color
col

-- box
drawObject (Box (Double
dx,Double
dy,Double
dz) Flavour
flav Color
col) = VisObject Double -> IO ()
drawObject forall a b. (a -> b) -> a -> b
$ forall a. (a, a, a) -> VisObject a -> VisObject a
Scale (Double
dx,Double
dy,Double
dz) forall a b. (a -> b) -> a -> b
$ forall a. a -> Flavour -> Color -> VisObject a
Cube Double
1 Flavour
flav Color
col

drawObject (Cube Double
r Flavour
flav Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    Color -> IO ()
setMaterialDiffuse Color
col
    Color -> IO ()
setColor Color
col
    forall (m :: * -> *). MonadIO m => Flavour -> Object -> m ()
GLUT.renderObject Flavour
flav (Double -> Object
GLUT.Cube (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
r))

-- line
drawObject (Line Maybe Double
width [V3 Double]
path Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
    Color -> IO ()
setColor Color
col
    GLfloat
lineWidth0 <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get StateVar GLfloat
GLUT.lineWidth
    case Maybe Double
width of
     Just Double
w -> StateVar GLfloat
GLUT.lineWidth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
w
     Maybe Double
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    forall a. PrimitiveMode -> IO a -> IO a
GLUT.renderPrimitive PrimitiveMode
LineStrip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(V3 Double
x' Double
y' Double
z') -> forall a. Vertex a => a -> IO ()
GLUT.vertex forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> Vertex3 a
Vertex3 Double
x' Double
y' Double
z') [V3 Double]
path
    StateVar GLfloat
GLUT.lineWidth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLfloat
lineWidth0
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

-- line where you set the color at each vertex
drawObject (Line' Maybe Double
width [(V3 Double, Color)]
pathcols) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled

    GLfloat
lineWidth0 <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get StateVar GLfloat
GLUT.lineWidth
    case Maybe Double
width of
     Just Double
w -> StateVar GLfloat
GLUT.lineWidth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
w
     Maybe Double
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBegin GLenum
GL_LINE_STRIP
    let f :: (V3 a, Color) -> IO ()
f (V3 a
xyz, Color
col) = do
          let V3 GLfloat
x GLfloat
y GLfloat
z = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac V3 a
xyz
          Color -> IO ()
setMaterialDiffuse Color
col
          Color -> IO ()
setColor Color
col
          forall (m :: * -> *).
MonadIO m =>
GLfloat -> GLfloat -> GLfloat -> m ()
glVertex3f GLfloat
x GLfloat
y GLfloat
z
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. Real a => (V3 a, Color) -> IO ()
f [(V3 Double, Color)]
pathcols
    forall (m :: * -> *). MonadIO m => m ()
glEnd
    StateVar GLfloat
GLUT.lineWidth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLfloat
lineWidth0
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

-- plane
drawObject (Plane (V3 Double
x Double
y Double
z) Color
col1 Color
col2) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    let normInv :: Double
normInv = Double
1forall a. Fractional a => a -> a -> a
/(forall a. Floating a => a -> a
sqrt forall a b. (a -> b) -> a -> b
$ Double
xforall a. Num a => a -> a -> a
*Double
x forall a. Num a => a -> a -> a
+ Double
yforall a. Num a => a -> a -> a
*Double
y forall a. Num a => a -> a -> a
+ Double
zforall a. Num a => a -> a -> a
*Double
z)
        x' :: Double
x' = Double
xforall a. Num a => a -> a -> a
*Double
normInv
        y' :: Double
y' = Double
yforall a. Num a => a -> a -> a
*Double
normInv
        z' :: Double
z' = Double
zforall a. Num a => a -> a -> a
*Double
normInv
        r :: Double
r  = Double
10
        n :: Double
n  = Double
5
        eps :: Double
eps = Double
0.01
    forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GLUT.rotate ((forall a. Floating a => a -> a
acos Double
z')forall a. Num a => a -> a -> a
*Double
180forall a. Fractional a => a -> a -> a
/forall a. Floating a => a
pi :: GLdouble) (forall a. a -> a -> a -> Vector3 a
Vector3 (-Double
y') Double
x' Double
0)

    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBegin GLenum
GL_QUADS
    Color -> IO ()
setColor Color
col2

    let r' :: GLfloat
r' = forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
r
    forall (m :: * -> *).
MonadIO m =>
GLfloat -> GLfloat -> GLfloat -> m ()
glVertex3f   GLfloat
r'    GLfloat
r'  GLfloat
0
    forall (m :: * -> *).
MonadIO m =>
GLfloat -> GLfloat -> GLfloat -> m ()
glVertex3f (-GLfloat
r')   GLfloat
r'  GLfloat
0
    forall (m :: * -> *).
MonadIO m =>
GLfloat -> GLfloat -> GLfloat -> m ()
glVertex3f (-GLfloat
r')  (-GLfloat
r')  GLfloat
0
    forall (m :: * -> *).
MonadIO m =>
GLfloat -> GLfloat -> GLfloat -> m ()
glVertex3f   GLfloat
r'   (-GLfloat
r')  GLfloat
0
    forall (m :: * -> *). MonadIO m => m ()
glEnd

    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glDisable GLenum
GL_BLEND
    let drawWithEps :: Double -> IO ()
drawWithEps Double
eps' = do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VisObject Double -> IO ()
drawObject forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ forall a. Maybe a -> [V3 a] -> Color -> VisObject a
Line forall a. Maybe a
Nothing
                                            [ forall a. a -> a -> a -> V3 a
V3 (-Double
r) Double
y0 Double
eps'
                                            , forall a. a -> a -> a -> V3 a
V3 Double
r    Double
y0 Double
eps'
                                            ] Color
col1
                                     , forall a. Maybe a -> [V3 a] -> Color -> VisObject a
Line forall a. Maybe a
Nothing
                                            [ forall a. a -> a -> a -> V3 a
V3 Double
x0 (-Double
r) Double
eps',
                                              forall a. a -> a -> a -> V3 a
V3 Double
x0 Double
r    Double
eps'
                                            ] Color
col1
                                     ] | Double
x0 <- [-Double
r,-Double
rforall a. Num a => a -> a -> a
+Double
rforall a. Fractional a => a -> a -> a
/Double
n..Double
r], Double
y0 <- [-Double
r,-Double
rforall a. Num a => a -> a -> a
+Double
rforall a. Fractional a => a -> a -> a
/Double
n..Double
r]]
    Double -> IO ()
drawWithEps Double
eps
    Double -> IO ()
drawWithEps (-Double
eps)

    forall (m :: * -> *). MonadIO m => GLenum -> m ()
glEnable GLenum
GL_BLEND


-- arrow
drawObject (Arrow (Double
size, Double
aspectRatio) (V3 Double
x Double
y Double
z) Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    let numSlices :: GLsizei
numSlices = GLsizei
8
        numStacks :: GLsizei
numStacks = GLsizei
15
        cylinderRadius :: Double
cylinderRadius = Double
0.5forall a. Num a => a -> a -> a
*Double
sizeforall a. Fractional a => a -> a -> a
/Double
aspectRatio
        cylinderHeight :: Double
cylinderHeight = Double
size
        coneRadius :: Double
coneRadius = Double
2forall a. Num a => a -> a -> a
*Double
cylinderRadius
        coneHeight :: Double
coneHeight = Double
2forall a. Num a => a -> a -> a
*Double
coneRadius

        rotAngle :: Double
rotAngle = forall a. Floating a => a -> a
acos(Double
zforall a. Fractional a => a -> a -> a
/(forall a. Floating a => a -> a
sqrt(Double
xforall a. Num a => a -> a -> a
*Double
x forall a. Num a => a -> a -> a
+ Double
yforall a. Num a => a -> a -> a
*Double
y forall a. Num a => a -> a -> a
+ Double
zforall a. Num a => a -> a -> a
*Double
z) forall a. Num a => a -> a -> a
+ Double
1e-15))forall a. Num a => a -> a -> a
*Double
180forall a. Fractional a => a -> a -> a
/forall a. Floating a => a
pi :: GLdouble
        rotAxis :: Vector3 Double
rotAxis = forall a. a -> a -> a -> Vector3 a
Vector3 (-Double
y) Double
x Double
0

    forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GLUT.rotate Double
rotAngle Vector3 Double
rotAxis

    -- cylinder
    VisObject Double -> IO ()
drawObject forall a b. (a -> b) -> a -> b
$ forall a. (a, a) -> Color -> VisObject a
Cylinder (Double
cylinderHeight, Double
cylinderRadius) Color
col
    -- cone
    Color -> IO ()
setMaterialDiffuse Color
col
    Color -> IO ()
setColor Color
col
    forall c. MatrixComponent c => Vector3 c -> IO ()
GLUT.translate (forall a. a -> a -> a -> Vector3 a
Vector3 Double
0 Double
0 Double
cylinderHeight :: Vector3 GLdouble)
    forall (m :: * -> *). MonadIO m => Flavour -> Object -> m ()
GLUT.renderObject Flavour
Solid (Double -> Double -> GLsizei -> GLsizei -> Object
GLUT.Cone Double
coneRadius Double
coneHeight GLsizei
numSlices GLsizei
numStacks)

drawObject (Axes (Double
size, Double
aspectRatio)) = forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
  let xAxis :: VisObject Double
xAxis = forall a. (a, a) -> V3 a -> Color -> VisObject a
Arrow (Double
size, Double
aspectRatio) (forall a. a -> a -> a -> V3 a
V3 Double
1 Double
0 Double
0) (GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color
GlossColor.makeColor GLfloat
1 GLfloat
0 GLfloat
0 GLfloat
1)
      yAxis :: VisObject Double
yAxis = forall a. (a, a) -> V3 a -> Color -> VisObject a
Arrow (Double
size, Double
aspectRatio) (forall a. a -> a -> a -> V3 a
V3 Double
0 Double
1 Double
0) (GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color
GlossColor.makeColor GLfloat
0 GLfloat
1 GLfloat
0 GLfloat
1)
      zAxis :: VisObject Double
zAxis = forall a. (a, a) -> V3 a -> Color -> VisObject a
Arrow (Double
size, Double
aspectRatio) (forall a. a -> a -> a -> V3 a
V3 Double
0 Double
0 Double
1) (GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color
GlossColor.makeColor GLfloat
0 GLfloat
0 GLfloat
1 GLfloat
1)
  VisObject Double -> IO ()
drawObject forall a b. (a -> b) -> a -> b
$ forall a. [VisObject a] -> VisObject a
VisObjects [VisObject Double
xAxis, VisObject Double
yAxis, VisObject Double
zAxis]

drawObject (Text3d String
string (V3 Double
x Double
y Double
z) BitmapFont
font Color
col) = forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
  StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
  Color -> IO ()
setColor Color
col
  forall (m :: * -> *).
MonadIO m =>
Double -> Double -> Double -> m ()
glRasterPos3d Double
x Double
y Double
z
  forall a (m :: * -> *). (Font a, MonadIO m) => a -> String -> m ()
GLUT.renderString BitmapFont
font String
string
  StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

drawObject (Text2d String
string (Double
x,Double
y) BitmapFont
font Color
col) = forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
  StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
  Color -> IO ()
setColor Color
col

  StateVar MatrixMode
GLUT.matrixMode forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= MatrixMode
Projection
  IO ()
GLUT.loadIdentity

  (Position
_, Size GLsizei
w GLsizei
h) <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get StateVar (Position, Size)
GLUT.viewport
  Double -> Double -> Double -> Double -> IO ()
GLUT.ortho2D Double
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
w) Double
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
h)
  StateVar MatrixMode
GLUT.matrixMode forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> MatrixMode
Modelview GLsizei
0
  IO ()
GLUT.loadIdentity

  forall (m :: * -> *). MonadIO m => Double -> Double -> m ()
glRasterPos2d Double
x Double
y
  forall a (m :: * -> *). (Font a, MonadIO m) => a -> String -> m ()
GLUT.renderString BitmapFont
font String
string

  IO ()
setPerspectiveMode
  StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

drawObject (Vis.VisObject.Points [V3 Double]
xyzs Maybe GLfloat
ps Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
    Color -> IO ()
setColor Color
col
    GLfloat
s' <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get StateVar GLfloat
GLUT.pointSize
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe GLfloat
ps) forall a b. (a -> b) -> a -> b
$ StateVar GLfloat
GLUT.pointSize forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (forall a. HasCallStack => Maybe a -> a
fromJust Maybe GLfloat
ps)
    forall a. PrimitiveMode -> IO a -> IO a
GLUT.renderPrimitive PrimitiveMode
GLUT.Points forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(V3 Double
x' Double
y' Double
z') -> forall a. Vertex a => a -> IO ()
GLUT.vertex forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> Vertex3 a
Vertex3 Double
x' Double
y' Double
z') [V3 Double]
xyzs
    StateVar GLfloat
GLUT.pointSize forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLfloat
s'
    StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

drawObject (Vis.VisObject.ObjModel (LoadedObjModel Vector Double
vvec Vector Double
nvec Int
numVerts) Color
col) =
  forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
    Color -> IO ()
setMaterialDiffuse Color
col
    Color -> IO ()
setColor Color
col

    -- enable vertex/normal arrays
    -- todo: Should this be done every time?
    --       Either enable at the start, or push/pop to preserve user attributes
    ClientArrayType -> StateVar Capability
GL.clientState ClientArrayType
GL.VertexArray forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
GL.Enabled
    ClientArrayType -> StateVar Capability
GL.clientState ClientArrayType
GL.NormalArray forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
GL.Enabled

    -- set the vertex and normal arrays
    let va :: Ptr a -> VertexArrayDescriptor a
va = forall a.
GLsizei -> DataType -> GLsizei -> Ptr a -> VertexArrayDescriptor a
GL.VertexArrayDescriptor GLsizei
3 DataType
GL.Double GLsizei
0
        na :: Ptr a -> VertexArrayDescriptor a
na = forall a.
GLsizei -> DataType -> GLsizei -> Ptr a -> VertexArrayDescriptor a
GL.VertexArrayDescriptor GLsizei
3 DataType
GL.Double GLsizei
0
    forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VS.unsafeWith Vector Double
vvec forall a b. (a -> b) -> a -> b
$ \Ptr Double
vptr -> forall a. ClientArrayType -> StateVar (VertexArrayDescriptor a)
GL.arrayPointer ClientArrayType
GL.VertexArray forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall {a}. Ptr a -> VertexArrayDescriptor a
va Ptr Double
vptr
    forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VS.unsafeWith Vector Double
nvec forall a b. (a -> b) -> a -> b
$ \Ptr Double
nptr -> forall a. ClientArrayType -> StateVar (VertexArrayDescriptor a)
GL.arrayPointer ClientArrayType
GL.NormalArray forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall {a}. Ptr a -> VertexArrayDescriptor a
na Ptr Double
nptr
    -- draw the triangles
    PrimitiveMode -> GLsizei -> GLsizei -> IO ()
GL.drawArrays PrimitiveMode
GL.Triangles GLsizei
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numVerts)

    -- disable vertex/normal arrays
    ClientArrayType -> StateVar Capability
GL.clientState ClientArrayType
GL.VertexArray forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
GL.Disabled
    ClientArrayType -> StateVar Capability
GL.clientState ClientArrayType
GL.NormalArray forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
GL.Disabled

-- | turn a list of vertex/normal tuples into vertex/normal arrays
loadObjModel :: F.Foldable f => f (V3 Double, V3 Double) -> LoadedObjModel
loadObjModel :: forall (f :: * -> *).
Foldable f =>
f (V3 Double, V3 Double) -> LoadedObjModel
loadObjModel f (V3 Double, V3 Double)
vns = Vector Double -> Vector Double -> Int -> LoadedObjModel
LoadedObjModel (forall a. Storable a => [a] -> Vector a
VS.fromList [Double]
vs) (forall a. Storable a => [a] -> Vector a
VS.fromList [Double]
ns) Int
n
  where
    vs :: [Double]
vs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
F.concatMap (\(V3 Double
x Double
y Double
z) -> [Double
x,Double
y,Double
z]) [V3 Double]
vs'
    ns :: [Double]
ns = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
F.concatMap (\(V3 Double
x Double
y Double
z) -> [Double
x,Double
y,Double
z]) [V3 Double]
ns'
    ([V3 Double]
vs',[V3 Double]
ns') = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f (V3 Double, V3 Double)
vns
    n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [V3 Double]
vs'