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

module Vis.VisObject ( VisObject(..)
                     , drawObjects
                     , LoadedObjModel(..)
                     , loadObjModel
                     , setPerspectiveMode
                     , Euler(..)
                     ) 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 Linear (V3(..),Quaternion,M33,fromQuaternion)

import qualified Vis.GlossColor as GlossColor

-- | 3-2-1 Euler angle rotation sequence
data Euler a = Euler { forall a. Euler a -> a
eYaw :: a
                     , forall a. Euler a -> a
ePitch :: a
                     , forall a. Euler a -> a
eRoll :: a
                     } deriving (Euler a -> Euler a -> Bool
(Euler a -> Euler a -> Bool)
-> (Euler a -> Euler a -> Bool) -> Eq (Euler a)
forall a. Eq a => Euler a -> Euler a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Euler a -> Euler a -> Bool
== :: Euler a -> Euler a -> Bool
$c/= :: forall a. Eq a => Euler a -> Euler a -> Bool
/= :: Euler a -> Euler a -> Bool
Eq, Int -> Euler a -> ShowS
[Euler a] -> ShowS
Euler a -> String
(Int -> Euler a -> ShowS)
-> (Euler a -> String) -> ([Euler a] -> ShowS) -> Show (Euler a)
forall a. Show a => Int -> Euler a -> ShowS
forall a. Show a => [Euler a] -> ShowS
forall a. Show a => Euler a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Euler a -> ShowS
showsPrec :: Int -> Euler a -> ShowS
$cshow :: forall a. Show a => Euler a -> String
show :: Euler a -> String
$cshowList :: forall a. Show a => [Euler a] -> ShowS
showList :: [Euler a] -> ShowS
Show, (forall a b. (a -> b) -> Euler a -> Euler b)
-> (forall a b. a -> Euler b -> Euler a) -> Functor Euler
forall a b. a -> Euler b -> Euler a
forall a b. (a -> b) -> Euler a -> Euler b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Euler a -> Euler b
fmap :: forall a b. (a -> b) -> Euler a -> Euler b
$c<$ :: forall a b. a -> Euler b -> Euler a
<$ :: forall a b. a -> Euler b -> Euler a
Functor, Eq (Euler a)
Eq (Euler a) =>
(Euler a -> Euler a -> Ordering)
-> (Euler a -> Euler a -> Bool)
-> (Euler a -> Euler a -> Bool)
-> (Euler a -> Euler a -> Bool)
-> (Euler a -> Euler a -> Bool)
-> (Euler a -> Euler a -> Euler a)
-> (Euler a -> Euler a -> Euler a)
-> Ord (Euler a)
Euler a -> Euler a -> Bool
Euler a -> Euler a -> Ordering
Euler a -> Euler a -> Euler a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Euler a)
forall a. Ord a => Euler a -> Euler a -> Bool
forall a. Ord a => Euler a -> Euler a -> Ordering
forall a. Ord a => Euler a -> Euler a -> Euler a
$ccompare :: forall a. Ord a => Euler a -> Euler a -> Ordering
compare :: Euler a -> Euler a -> Ordering
$c< :: forall a. Ord a => Euler a -> Euler a -> Bool
< :: Euler a -> Euler a -> Bool
$c<= :: forall a. Ord a => Euler a -> Euler a -> Bool
<= :: Euler a -> Euler a -> Bool
$c> :: forall a. Ord a => Euler a -> Euler a -> Bool
> :: Euler a -> Euler a -> Bool
$c>= :: forall a. Ord a => Euler a -> Euler a -> Bool
>= :: Euler a -> Euler a -> Bool
$cmax :: forall a. Ord a => Euler a -> Euler a -> Euler a
max :: Euler a -> Euler a -> Euler a
$cmin :: forall a. Ord a => Euler a -> Euler a -> Euler a
min :: Euler a -> Euler a -> Euler a
Ord, (forall x. Euler a -> Rep (Euler a) x)
-> (forall x. Rep (Euler a) x -> Euler a) -> Generic (Euler a)
forall x. Rep (Euler a) x -> Euler a
forall x. Euler a -> Rep (Euler a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Euler a) x -> Euler a
forall a x. Euler a -> Rep (Euler a) x
$cfrom :: forall a x. Euler a -> Rep (Euler a) x
from :: forall x. Euler a -> Rep (Euler a) x
$cto :: forall a x. Rep (Euler a) x -> Euler a
to :: forall x. Rep (Euler a) x -> Euler a
Generic)
--                     } deriving (Eq, Show, Functor, Foldable, Traversable, Ord)

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

dcmOfQuat :: Num a => Quaternion a -> M33 a
dcmOfQuat :: forall a. Num a => Quaternion a -> M33 a
dcmOfQuat Quaternion a
q = V3 a -> V3 a -> V3 a -> V3 (V3 a)
forall a. a -> a -> a -> V3 a
V3
              (a -> a -> a -> V3 a
forall a. a -> a -> a -> V3 a
V3 a
m11 a
m21 a
m31)
              (a -> a -> a -> V3 a
forall a. a -> a -> a -> V3 a
V3 a
m12 a
m22 a
m32)
              (a -> a -> a -> V3 a
forall a. a -> a -> a -> V3 a
V3 a
m13 a
m23 a
m33)
  where
    V3
      (V3 a
m11 a
m12 a
m13)
      (V3 a
m21 a
m22 a
m23)
      (V3 a
m31 a
m32 a
m33) = Quaternion a -> V3 (V3 a)
forall a. Num a => Quaternion a -> M33 a
fromQuaternion Quaternion a
q

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

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

setMaterialDiffuse :: GlossColor.Color -> IO ()
setMaterialDiffuse :: Color -> IO ()
setMaterialDiffuse Color
col = Face -> StateVar (Color4 Float)
GLUT.materialDiffuse Face
Front StateVar (Color4 Float) -> Color4 Float -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 Float) -> Color4 Float -> m ()
$= (Color -> Color4 Float
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 x. VisObject a -> Rep (VisObject a) x)
-> (forall x. Rep (VisObject a) x -> VisObject a)
-> Generic (VisObject a)
forall x. Rep (VisObject a) x -> VisObject a
forall x. VisObject a -> Rep (VisObject a) x
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
$cfrom :: forall a x. VisObject a -> Rep (VisObject a) x
from :: forall x. VisObject a -> Rep (VisObject a) x
$cto :: forall a x. Rep (VisObject a) x -> VisObject a
to :: forall x. Rep (VisObject a) x -> VisObject a
Generic, (forall a b. (a -> b) -> VisObject a -> VisObject b)
-> (forall a b. a -> VisObject b -> VisObject a)
-> Functor VisObject
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
$cfmap :: forall a b. (a -> b) -> VisObject a -> VisObject b
fmap :: forall a b. (a -> b) -> VisObject a -> VisObject b
$c<$ :: forall a b. a -> VisObject b -> VisObject a
<$ :: forall a b. a -> VisObject b -> VisObject a
Functor)

data LoadedObjModel = LoadedObjModel (VS.Vector Double) (VS.Vector Double) Int deriving ((forall x. LoadedObjModel -> Rep LoadedObjModel x)
-> (forall x. Rep LoadedObjModel x -> LoadedObjModel)
-> Generic LoadedObjModel
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
$cfrom :: forall x. LoadedObjModel -> Rep LoadedObjModel x
from :: forall x. LoadedObjModel -> Rep LoadedObjModel x
$cto :: forall x. Rep LoadedObjModel x -> LoadedObjModel
to :: forall x. Rep LoadedObjModel x -> LoadedObjModel
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 = Bool -> Put
forall t. Binary t => t -> Put
B.put (Bool -> Put) -> (Flavour -> Bool) -> Flavour -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flavour -> Bool
fromFlavour
  get :: Get Flavour
get = (Bool -> Flavour) -> Get Bool -> Get Flavour
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Flavour
toFlavour Get Bool
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 = String -> BitmapFont
forall a. HasCallStack => String -> a
error (String -> BitmapFont) -> String -> BitmapFont
forall a b. (a -> b) -> a -> b
$ String
"deserializing BitmapFont got bad value (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

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


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

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

instance B.Binary (GlossColor.Color) where
  put :: Color -> Put
put = (Float, Float, Float, Float) -> Put
forall t. Binary t => t -> Put
B.put ((Float, Float, Float, Float) -> Put)
-> (Color -> (Float, Float, Float, Float)) -> Color -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> (Float, Float, Float, Float)
fromColor
  get :: Get Color
get = ((Float, Float, Float, Float) -> Color)
-> Get (Float, Float, Float, Float) -> Get Color
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Float, Float, Float, Float) -> Color
toColor Get (Float, Float, Float, Float)
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) <- StateVar (Position, Size) -> IO (Position, Size)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
StateVar (Position, Size) -> m (Position, Size)
GLUT.get StateVar (Position, Size)
GLUT.viewport
  StateVar MatrixMode
GLUT.matrixMode StateVar MatrixMode -> MatrixMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar MatrixMode -> MatrixMode -> m ()
$= MatrixMode
Projection
  IO ()
GLUT.loadIdentity
  GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO ()
GLUT.perspective GLdouble
40 (GLsizei -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
w GLdouble -> GLdouble -> GLdouble
forall a. Fractional a => a -> a -> a
/ GLsizei -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
h) GLdouble
0.1 GLdouble
1000
  StateVar MatrixMode
GLUT.matrixMode StateVar MatrixMode -> MatrixMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar MatrixMode -> MatrixMode -> m ()
$= GLsizei -> MatrixMode
Modelview GLsizei
0

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

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

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

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

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

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

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

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

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

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

-- cylinder
drawObject (Cylinder (GLdouble
height,GLdouble
radius) Color
col) =
  IO () -> IO ()
forall a. IO a -> IO a
GLUT.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
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 :: [(GLdouble, GLdouble)]
sinCosTable = (GLdouble -> (GLdouble, GLdouble))
-> [GLdouble] -> [(GLdouble, GLdouble)]
forall a b. (a -> b) -> [a] -> [b]
map (\GLdouble
q -> (GLdouble -> GLdouble
forall a. Floating a => a -> a
sin GLdouble
q, GLdouble -> GLdouble
forall a. Floating a => a -> a
cos GLdouble
q)) [GLdouble]
angles
          where
            angle :: GLdouble
angle = GLdouble
2GLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
*GLdouble
forall a. Floating a => a
piGLdouble -> GLdouble -> GLdouble
forall a. Fractional a => a -> a -> a
/(Int -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nslices)
            angles :: [GLdouble]
angles = [GLdouble] -> [GLdouble]
forall a. [a] -> [a]
reverse ([GLdouble] -> [GLdouble]) -> [GLdouble] -> [GLdouble]
forall a b. (a -> b) -> a -> b
$ (Int -> GLdouble) -> [Int] -> [GLdouble]
forall a b. (a -> b) -> [a] -> [b]
map ((GLdouble
angleGLdouble -> GLdouble -> GLdouble
forall a. Num a => a -> a -> a
*) (GLdouble -> GLdouble) -> (Int -> GLdouble) -> Int -> GLdouble
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GLdouble
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Int
0..(Int
nslicesInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)]

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

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

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

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

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

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

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

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

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

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

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

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

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

    GLenum -> IO ()
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 Float
x Float
y Float
z = (a -> Float) -> V3 a -> V3 Float
forall a b. (a -> b) -> V3 a -> V3 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac V3 a
xyz
          Color -> IO ()
setMaterialDiffuse Color
col
          Color -> IO ()
setColor Color
col
          Float -> Float -> Float -> IO ()
forall (m :: * -> *). MonadIO m => Float -> Float -> Float -> m ()
glVertex3f Float
x Float
y Float
z
    ((V3 GLdouble, Color) -> IO ()) -> [(V3 GLdouble, Color)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (V3 GLdouble, Color) -> IO ()
forall {a}. Real a => (V3 a, Color) -> IO ()
f [(V3 GLdouble, Color)]
pathcols
    IO ()
forall (m :: * -> *). MonadIO m => m ()
glEnd
    StateVar Float
GLUT.lineWidth StateVar Float -> Float -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *). MonadIO m => StateVar Float -> Float -> m ()
$= Float
lineWidth0
    StateVar Capability
GLUT.lighting StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
Enabled

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

drawObject (Vis.VisObject.ObjModel (LoadedObjModel Vector GLdouble
vvec Vector GLdouble
nvec Int
numVerts) Color
col) =
  IO () -> IO ()
forall a. IO a -> IO a
GLUT.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
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 StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled
    ClientArrayType -> StateVar Capability
GL.clientState ClientArrayType
GL.NormalArray StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled

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

    -- disable vertex/normal arrays
    ClientArrayType -> StateVar Capability
GL.clientState ClientArrayType
GL.VertexArray StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Disabled
    ClientArrayType -> StateVar Capability
GL.clientState ClientArrayType
GL.NormalArray StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> 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 GLdouble, V3 GLdouble) -> LoadedObjModel
loadObjModel f (V3 GLdouble, V3 GLdouble)
vns = Vector GLdouble -> Vector GLdouble -> Int -> LoadedObjModel
LoadedObjModel ([GLdouble] -> Vector GLdouble
forall a. Storable a => [a] -> Vector a
VS.fromList [GLdouble]
vs) ([GLdouble] -> Vector GLdouble
forall a. Storable a => [a] -> Vector a
VS.fromList [GLdouble]
ns) Int
n
  where
    vs :: [GLdouble]
vs = (V3 GLdouble -> [GLdouble]) -> [V3 GLdouble] -> [GLdouble]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
F.concatMap (\(V3 GLdouble
x GLdouble
y GLdouble
z) -> [GLdouble
x,GLdouble
y,GLdouble
z]) [V3 GLdouble]
vs'
    ns :: [GLdouble]
ns = (V3 GLdouble -> [GLdouble]) -> [V3 GLdouble] -> [GLdouble]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
F.concatMap (\(V3 GLdouble
x GLdouble
y GLdouble
z) -> [GLdouble
x,GLdouble
y,GLdouble
z]) [V3 GLdouble]
ns'
    ([V3 GLdouble]
vs',[V3 GLdouble]
ns') = [(V3 GLdouble, V3 GLdouble)] -> ([V3 GLdouble], [V3 GLdouble])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(V3 GLdouble, V3 GLdouble)] -> ([V3 GLdouble], [V3 GLdouble]))
-> [(V3 GLdouble, V3 GLdouble)] -> ([V3 GLdouble], [V3 GLdouble])
forall a b. (a -> b) -> a -> b
$ f (V3 GLdouble, V3 GLdouble) -> [(V3 GLdouble, V3 GLdouble)]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f (V3 GLdouble, V3 GLdouble)
vns
    n :: Int
n = [V3 GLdouble] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [V3 GLdouble]
vs'