OpenGL.hs

{-# OPTIONS_GHC -DFlt=Double -DVECT_Double #-}

-- TODO: the pointer versions of these functions should be really implemented 
-- via the pointer versions of the original opengl functions...

-- | OpenGL support, inclduing 'vertex', 'texCoord', etc instances for 'Vec2', 'Vec3' and 'Vec4'.
 
module Data.Vect.Flt.OpenGL where

import Control.Monad
import Data.Vect.Flt.Base
import qualified Graphics.Rendering.OpenGL as GL

import Foreign

import Graphics.Rendering.OpenGL hiding (Normal3,rotate,translate,scale)

-------------------------------------------------------

{-# SPECIALISE radianToDegrees :: Float -> Float #-}
{-# SPECIALISE radianToDegrees :: Double -> Double #-}
radianToDegrees :: RealFrac a => a -> a
radianToDegrees x = x * 57.295779513082322

{-# SPECIALIZE degreesToRadian :: Float  -> Float  #-}
{-# SPECIALIZE degreesToRadian :: Double -> Double #-}
degreesToRadian :: Floating a => a -> a
degreesToRadian x = x * 1.7453292519943295e-2

-- | The angle is in radians. (WARNING: OpenGL uses degrees!)
rotate :: Flt -> Vec3 -> IO ()
rotate angle (Vec3 x y z) = GL.rotate (radianToDegrees angle) (Vector3 x y z)

translate :: Vec3 -> IO ()
translate (Vec3 x y z) = GL.translate (Vector3 x y z)

scale3 :: Vec3 -> IO ()
scale3 (Vec3 x y z) = GL.scale x y z

scale :: Flt -> IO ()
scale x = GL.scale x x x

-------------------------------------------------------

-- Vertex instances

instance GL.Vertex Vec2 where
  vertex (Vec2 x y) = GL.vertex (GL.Vertex2 x y)
  vertexv p = peek p >>= vertex 
  
instance GL.Vertex Vec3 where
  vertex (Vec3 x y z) = GL.vertex (GL.Vertex3 x y z)
  vertexv p = peek p >>= vertex   
  
instance GL.Vertex Vec4 where
  vertex (Vec4 x y z w) = GL.vertex (GL.Vertex4 x y z w)
  vertexv p = peek p >>= vertex   

-------------------------------------------------------

-- the Normal instance
-- note that there is no Normal2\/Normal4 in the OpenGL binding

instance GL.Normal Normal3 where
  normal (Normal3 (Vec3 x y z)) = GL.normal (GL.Normal3 x y z)
  normalv p = peek p >>= normal 

-------------------------------------------------------

-- Color instances
  
instance GL.Color Vec3 where
  color (Vec3 r g b) = GL.color (GL.Color3 r g b)
  colorv p = peek p >>= color

instance GL.Color Vec4 where
  color (Vec4 r g b a) = GL.color (GL.Color4 r g b a)
  colorv p = peek p >>= color

instance GL.SecondaryColor Vec3 where
  secondaryColor (Vec3 r g b) = GL.secondaryColor (GL.Color3 r g b)
  secondaryColorv p = peek p >>= secondaryColor

{-
-- there is no such thing?
instance GL.SecondaryColor Vec4 where
  secondaryColor (Vec4 r g b a) = GL.secondaryColor (GL.Color4 r g b a)
  secondaryColorv p = peek p >>= secondaryColor
-}

-------------------------------------------------------

-- TexCoord instances

instance GL.TexCoord Vec2 where
  texCoord (Vec2 u v) = GL.texCoord (GL.TexCoord2 u v)
  texCoordv p = peek p >>= texCoord
  multiTexCoord unit (Vec2 u v) = GL.multiTexCoord unit (GL.TexCoord2 u v)
  multiTexCoordv unit p = peek p >>= multiTexCoord unit

instance GL.TexCoord Vec3 where
  texCoord (Vec3 u v w) = GL.texCoord (GL.TexCoord3 u v w)
  texCoordv p = peek p >>= texCoord
  multiTexCoord unit (Vec3 u v w) = GL.multiTexCoord unit (GL.TexCoord3 u v w)
  multiTexCoordv unit p = peek p >>= multiTexCoord unit

instance GL.TexCoord Vec4 where
  texCoord (Vec4 u v w z) = GL.texCoord (GL.TexCoord4 u v w z)
  texCoordv p = peek p >>= texCoord
  multiTexCoord unit (Vec4 u v w z) = GL.multiTexCoord unit (GL.TexCoord4 u v w z)
  multiTexCoordv unit p = peek p >>= multiTexCoord unit

-------------------------------------------------------
    
-- Vertex Attributes (experimental)

class VertexAttrib' a where
  vertexAttrib :: GL.AttribLocation -> a -> IO ()
  
instance VertexAttrib' {- ' CPP is sensitive to primes -} Flt where
  vertexAttrib loc x = GL.vertexAttrib1 loc x

instance VertexAttrib' Vec2 where
  vertexAttrib loc (Vec2 x y) = GL.vertexAttrib2 loc x y

instance VertexAttrib' Vec3 where
  vertexAttrib loc (Vec3 x y z) = GL.vertexAttrib3 loc x y z 

instance VertexAttrib' Vec4 where
  vertexAttrib loc (Vec4 x y z w) = GL.vertexAttrib4 loc x y z w 

instance VertexAttrib' Normal2 where
  vertexAttrib loc (Normal2 (Vec2 x y)) = GL.vertexAttrib2 loc x y

instance VertexAttrib' Normal3 where
  vertexAttrib loc (Normal3 (Vec3 x y z)) = GL.vertexAttrib3 loc x y z

instance VertexAttrib' Normal4 where
  vertexAttrib loc (Normal4 (Vec4 x y z w)) = GL.vertexAttrib4 loc x y z w

-------------------------------------------------------

-- Uniform (again, experimental)

-- (note that the uniform location code in the OpenGL 2.2.1.1 is broken; 
-- a work-around is to put a zero character at the end of uniform names)

{-
toFloat :: Flt -> Float
toFloat = realToFrac

fromFloat :: Float -> Flt
fromFloat = realToFrac
-}

-- Uniforms are always floats...
#ifdef VECT_Float

instance GL.Uniform Flt where
  uniform loc = GL.makeStateVar getter setter where
    getter = liftM (\(GL.Index1 x) -> x) $ get (uniform loc)
    setter x = ($=) (uniform loc) (Index1 x) 
  uniformv loc cnt ptr = uniformv loc cnt (castPtr ptr :: Ptr (Index1 Flt))

instance GL.Uniform Vec2 where
  uniform loc = GL.makeStateVar getter setter where
    getter = liftM (\(GL.Vertex2 x y) -> Vec2 x y) $ get (uniform loc)
    setter (Vec2 x y) = ($=) (uniform loc) (Vertex2 x y) 
  uniformv loc cnt ptr = uniformv loc (2*cnt) (castPtr ptr :: Ptr Flt)

instance GL.Uniform Vec3 where
  uniform loc = GL.makeStateVar getter setter where
    getter = liftM (\(GL.Vertex3 x y z) -> Vec3 x y z) $ get (uniform loc)
    setter (Vec3 x y z) = ($=) (uniform loc) (Vertex3 x y z) 
  uniformv loc cnt ptr = uniformv loc (3*cnt) (castPtr ptr :: Ptr Flt)

instance GL.Uniform Vec4 where
  uniform loc = GL.makeStateVar getter setter where
    getter = liftM (\(GL.Vertex4 x y z w) -> Vec4 x y z w) $ get (uniform loc)
    setter (Vec4 x y z w) = ($=) (uniform loc) (Vertex4 x y z w) 
  uniformv loc cnt ptr = uniformv loc (4*cnt) (castPtr ptr :: Ptr Flt)
    
#endif