--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.Colors
-- Copyright   :  (c) Sven Panne 2002-2009
-- License     :  BSD-style (see the file libraries/OpenGL/LICENSE)
--
-- Maintainer  :  [email protected]
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 2.14 (Colors and Coloring) of the
-- OpenGL 2.1 specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.Colors (
   -- * Lighting
   lighting, Light(..), light, maxLights,
   FrontFaceDirection(..), frontFace,

   -- * Lighting Parameter Specification
   Face(..),
   materialAmbient, materialDiffuse, materialAmbientAndDiffuse,
   materialSpecular, materialEmission, materialShininess, maxShininess,
   materialColorIndexes,

   ambient, diffuse, specular,
   position, spotDirection, spotExponent, maxSpotExponent, spotCutoff,
   attenuation,

   lightModelAmbient, lightModelLocalViewer, lightModelTwoSide,
   vertexProgramTwoSide,
   LightModelColorControl(..), lightModelColorControl,

   -- * ColorMaterial
   ColorMaterialParameter(..), colorMaterial,

   -- * Flatshading
   ShadingModel(..), shadeModel,

   -- * Color clamping
   ClampTarget(..), ClampMode(..),
   clampColor,
) where

import Control.Monad
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL.GL.StateVar
import Graphics.Rendering.OpenGL.GL.Tensor
import Graphics.Rendering.OpenGL.GL.Capability
import Graphics.Rendering.OpenGL.GL.Face
import Graphics.Rendering.OpenGL.GL.PeekPoke
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.GLU.ErrorsInternal
import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility (
   glColorMaterial, glGetLightfv, glGetMaterialfv, glGetMaterialiv,
   glLightModelfv, glLightModeli, glLightfv, glMaterialfv, glMaterialiv,
   glShadeModel, gl_AMBIENT, gl_AMBIENT_AND_DIFFUSE, gl_COLOR_INDEXES,
   gl_CONSTANT_ATTENUATION, gl_DIFFUSE, gl_EMISSION, gl_FLAT,
   gl_LIGHT_MODEL_AMBIENT, gl_LIGHT_MODEL_COLOR_CONTROL,
   gl_LIGHT_MODEL_LOCAL_VIEWER, gl_LIGHT_MODEL_TWO_SIDE, gl_LINEAR_ATTENUATION,
   gl_POSITION, gl_QUADRATIC_ATTENUATION, gl_SEPARATE_SPECULAR_COLOR,
   gl_SHININESS, gl_SINGLE_COLOR, gl_SMOOTH, gl_SPECULAR, gl_SPOT_CUTOFF,
   gl_SPOT_DIRECTION, gl_SPOT_EXPONENT,
   gl_CLAMP_FRAGMENT_COLOR, gl_CLAMP_VERTEX_COLOR )
import Graphics.Rendering.OpenGL.Raw.Core31

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

lighting :: StateVar Capability
lighting = makeCapability CapLighting

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

newtype Light = Light GLsizei
   deriving ( Eq, Ord, Show )

marshalLight :: Light -> Maybe GLenum
marshalLight (Light l) = lightIndexToEnum l

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

light :: Light -> StateVar Capability
light (Light l) = makeCapability (CapLight l)

maxLights :: GettableStateVar GLsizei
maxLights = makeGettableStateVar (getSizei1 id GetMaxLights)

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

data FrontFaceDirection =
     CW
   | CCW
   deriving ( Eq, Ord, Show )

marshalFrontFaceDirection :: FrontFaceDirection -> GLenum
marshalFrontFaceDirection x = case x of
   CW -> gl_CW
   CCW -> gl_CCW

unmarshalFrontFaceDirection :: GLenum -> FrontFaceDirection
unmarshalFrontFaceDirection x
   | x == gl_CW = CW
   | x == gl_CCW = CCW
   | otherwise = error ("unmarshalFrontFaceDirection: illegal value " ++ show x)

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

frontFace :: StateVar FrontFaceDirection
frontFace =
   makeStateVar
      (getEnum1 unmarshalFrontFaceDirection GetFrontFace)
      (glFrontFace . marshalFrontFaceDirection)

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

data MaterialParameter =
     MaterialEmission
   | MaterialShininess
   | MaterialAmbientAndDiffuse
   | MaterialColorIndexes
   | MaterialAmbient
   | MaterialDiffuse
   | MaterialSpecular

marshalMaterialParameter :: MaterialParameter -> GLenum
marshalMaterialParameter x = case x of
   MaterialEmission -> gl_EMISSION
   MaterialShininess -> gl_SHININESS
   MaterialAmbientAndDiffuse -> gl_AMBIENT_AND_DIFFUSE
   MaterialColorIndexes -> gl_COLOR_INDEXES
   MaterialAmbient -> gl_AMBIENT
   MaterialDiffuse -> gl_DIFFUSE
   MaterialSpecular -> gl_SPECULAR

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

materialAmbient :: Face -> StateVar (Color4 GLfloat)
materialAmbient =
   makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialAmbient

materialDiffuse :: Face -> StateVar (Color4 GLfloat)
materialDiffuse =
   makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialDiffuse

materialAmbientAndDiffuse :: Face -> StateVar (Color4 GLfloat)
materialAmbientAndDiffuse =
   makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialAmbientAndDiffuse

materialSpecular :: Face -> StateVar (Color4 GLfloat)
materialSpecular =
   makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialSpecular

materialEmission :: Face -> StateVar (Color4 GLfloat)
materialEmission =
   makeMaterialVar glGetMaterialfvc glMaterialfvc MaterialEmission

makeMaterialVar :: Storable a
                => (GLenum -> GLenum -> Ptr a -> IO ())
                -> (GLenum -> GLenum -> Ptr a -> IO ())
                -> MaterialParameter -> Face -> StateVar a
makeMaterialVar getter setter materialParameter face =
   makeStateVar (alloca $ \buf -> do getter f mp buf ; peek buf)
                (\val -> with val $ setter f mp)
   where mp = marshalMaterialParameter materialParameter
         f  = marshalFace face

glGetMaterialfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO ()
glGetMaterialfvc face pname ptr = glGetMaterialfv face pname (castPtr ptr)

glMaterialfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO ()
glMaterialfvc face pname ptr = glMaterialfv face pname (castPtr ptr)

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

materialShininess :: Face -> StateVar GLfloat
materialShininess =
   makeMaterialVar glGetMaterialfvf glMaterialff MaterialShininess

glGetMaterialfvf :: GLenum -> GLenum -> Ptr GLfloat -> IO ()
glGetMaterialfvf face pname ptr = glGetMaterialfv face pname (castPtr ptr)

glMaterialff :: GLenum -> GLenum -> Ptr GLfloat -> IO ()
glMaterialff face pname ptr = glMaterialfv face pname (castPtr ptr)

maxShininess :: GettableStateVar GLfloat
maxShininess = makeGettableStateVar $ getFloat1 id GetMaxShininess

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

-- Alas, (Index1 GLint, Index1 GLint, Index1 GLint) is not an instance of
-- Storable...

materialColorIndexes ::
   Face -> StateVar (Index1 GLint, Index1 GLint, Index1 GLint)
materialColorIndexes face =
   makeStateVar (getMaterialColorIndexes face) (setMaterialColorIndexes face)

getMaterialColorIndexes :: Face -> IO (Index1 GLint, Index1 GLint, Index1 GLint)
getMaterialColorIndexes face =
   allocaArray 3 $ \buf -> do
      glGetMaterialiv (marshalFace face)
                      (marshalMaterialParameter MaterialColorIndexes)
                      buf
      peek3 (\a d s -> (Index1 a, Index1 d, Index1 s)) buf

setMaterialColorIndexes ::
   Face -> (Index1 GLint, Index1 GLint, Index1 GLint) -> IO ()
setMaterialColorIndexes face (Index1 a, Index1 d, Index1 s) =
   withArray [a, d, s] $
      glMaterialiv (marshalFace face)
                   (marshalMaterialParameter MaterialColorIndexes)

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

data LightParameter =
     Ambient'
   | Diffuse'
   | Specular'
   | Position
   | SpotDirection
   | SpotExponent
   | SpotCutoff
   | ConstantAttenuation
   | LinearAttenuation
   | QuadraticAttenuation

marshalLightParameter :: LightParameter -> GLenum
marshalLightParameter x = case x of
   Ambient' -> gl_AMBIENT
   Diffuse' -> gl_DIFFUSE
   Specular' -> gl_SPECULAR
   Position -> gl_POSITION
   SpotDirection -> gl_SPOT_DIRECTION
   SpotExponent -> gl_SPOT_EXPONENT
   SpotCutoff -> gl_SPOT_CUTOFF
   ConstantAttenuation -> gl_CONSTANT_ATTENUATION
   LinearAttenuation -> gl_LINEAR_ATTENUATION
   QuadraticAttenuation -> gl_QUADRATIC_ATTENUATION

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

ambient :: Light -> StateVar (Color4 GLfloat)
ambient = makeLightVar glGetLightfvc glLightfvc Ambient' black

black :: Color4 GLfloat
black = Color4 0 0 0 0

diffuse :: Light -> StateVar (Color4 GLfloat)
diffuse = makeLightVar glGetLightfvc glLightfvc Diffuse' black

specular :: Light -> StateVar (Color4 GLfloat)
specular = makeLightVar glGetLightfvc glLightfvc Specular' black

makeLightVar :: Storable a
             => (GLenum -> GLenum -> Ptr a -> IO ())
             -> (GLenum -> GLenum -> Ptr a -> IO ())
             -> LightParameter -> a -> Light -> StateVar a
makeLightVar getter setter lightParameter defaultValue theLight =
   makeStateVar (maybe (return defaultValue) getLightVar ml)
                (\val -> maybe recordInvalidEnum (setLightVar val) ml)
   where lp          = marshalLightParameter lightParameter
         ml          = marshalLight theLight
         getLightVar = \l -> alloca $ \buf -> do getter l lp buf ; peek buf
         setLightVar = \val l -> with val $ setter l lp

glGetLightfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO ()
glGetLightfvc l pname ptr = glGetLightfv l pname (castPtr ptr)

glLightfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO ()
glLightfvc l pname ptr = glLightfv l pname (castPtr ptr)

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

position :: Light -> StateVar (Vertex4 GLfloat)
position = makeLightVar glGetLightfvv glLightfvv Position (Vertex4 0 0 0 0)

glLightfvv :: GLenum -> GLenum -> Ptr (Vertex4 GLfloat) -> IO ()
glLightfvv l pname ptr = glLightfv l pname (castPtr ptr)

glGetLightfvv :: GLenum -> GLenum -> Ptr (Vertex4 GLfloat) -> IO ()
glGetLightfvv l pname ptr = glGetLightfv l pname (castPtr ptr)

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

spotDirection :: Light -> StateVar (Normal3 GLfloat)
spotDirection =
   makeLightVar glGetLightfvn glLightfvn SpotDirection (Normal3 0 0 0)

glLightfvn :: GLenum -> GLenum -> Ptr (Normal3 GLfloat) -> IO ()
glLightfvn l pname ptr = glLightfv l pname (castPtr ptr)

glGetLightfvn :: GLenum -> GLenum -> Ptr (Normal3 GLfloat) -> IO ()
glGetLightfvn l pname ptr = glGetLightfv l pname (castPtr ptr)

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

spotExponent :: Light -> StateVar GLfloat
spotExponent = makeLightVar glGetLightfv glLightfv SpotExponent 0

maxSpotExponent :: GettableStateVar GLfloat
maxSpotExponent = makeGettableStateVar $ getFloat1 id GetMaxSpotExponent

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

spotCutoff :: Light -> StateVar GLfloat
spotCutoff = makeLightVar glGetLightfv glLightfv SpotCutoff 0

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

attenuation :: Light -> StateVar (GLfloat, GLfloat, GLfloat)
attenuation theLight =
   makeStateVar
      (liftM3 (,,) (get (constantAttenuation  theLight))
                   (get (linearAttenuation    theLight))
                   (get (quadraticAttenuation theLight)))
      (\(constant, linear, quadratic) -> do
         constantAttenuation  theLight $= constant
         linearAttenuation    theLight $= linear
         quadraticAttenuation theLight $= quadratic)

constantAttenuation :: Light -> StateVar GLfloat
constantAttenuation = makeLightVar glGetLightfv glLightfv ConstantAttenuation 0

linearAttenuation :: Light -> StateVar GLfloat
linearAttenuation = makeLightVar glGetLightfv glLightfv LinearAttenuation 0

quadraticAttenuation :: Light -> StateVar GLfloat
quadraticAttenuation =
   makeLightVar glGetLightfv glLightfv QuadraticAttenuation 0

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

data LightModelParameter =
     LightModelAmbient
   | LightModelLocalViewer
   | LightModelTwoSide
   | LightModelColorControl

marshalLightModelParameter :: LightModelParameter -> GLenum
marshalLightModelParameter x = case x of
   LightModelAmbient -> gl_LIGHT_MODEL_AMBIENT
   LightModelLocalViewer -> gl_LIGHT_MODEL_LOCAL_VIEWER
   LightModelTwoSide -> gl_LIGHT_MODEL_TWO_SIDE
   LightModelColorControl -> gl_LIGHT_MODEL_COLOR_CONTROL

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

lightModelAmbient :: StateVar (Color4 GLfloat)
lightModelAmbient =
   makeStateVar
      (getFloat4 Color4 GetLightModelAmbient)
      (\c -> with c $
                glLightModelfv (marshalLightModelParameter LightModelAmbient) . castPtr)

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

lightModelLocalViewer :: StateVar Capability
lightModelLocalViewer =
   makeLightModelCapVar GetLightModelLocalViewer LightModelLocalViewer

makeLightModelCapVar :: PName1I -> LightModelParameter -> StateVar Capability
makeLightModelCapVar pname lightModelParameter =
   makeStateVar
      (getBoolean1 unmarshalCapability pname)
      (glLightModeli (marshalLightModelParameter lightModelParameter) .
                     fromIntegral . marshalCapability)

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

lightModelTwoSide :: StateVar Capability
lightModelTwoSide = makeLightModelCapVar GetLightModelTwoSide LightModelTwoSide

vertexProgramTwoSide :: StateVar Capability
vertexProgramTwoSide = makeCapability CapVertexProgramTwoSide

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

data LightModelColorControl =
     SingleColor
   | SeparateSpecularColor
   deriving ( Eq, Ord, Show )

marshalLightModelColorControl :: LightModelColorControl -> GLenum
marshalLightModelColorControl x = case x of
   SingleColor -> gl_SINGLE_COLOR
   SeparateSpecularColor -> gl_SEPARATE_SPECULAR_COLOR

unmarshalLightModelColorControl :: GLenum -> LightModelColorControl
unmarshalLightModelColorControl x
   | x == gl_SINGLE_COLOR = SingleColor
   | x == gl_SEPARATE_SPECULAR_COLOR = SeparateSpecularColor
   | otherwise = error ("unmarshalLightModelColorControl: illegal value " ++ show x)

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

lightModelColorControl :: StateVar LightModelColorControl
lightModelColorControl =
   makeStateVar
      (getEnum1 unmarshalLightModelColorControl GetLightModelColorControl)
      (glLightModeli (marshalLightModelParameter LightModelColorControl) .
                     fromIntegral . marshalLightModelColorControl)

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

data ColorMaterialParameter =
     Ambient
   | Diffuse
   | Specular
   | Emission
   | AmbientAndDiffuse
   deriving ( Eq, Ord, Show )

marshalColorMaterialParameter :: ColorMaterialParameter -> GLenum
marshalColorMaterialParameter x = case x of
   Ambient -> gl_AMBIENT
   Diffuse -> gl_DIFFUSE
   Specular -> gl_SPECULAR
   Emission -> gl_EMISSION
   AmbientAndDiffuse -> gl_AMBIENT_AND_DIFFUSE

unmarshalColorMaterialParameter :: GLenum -> ColorMaterialParameter
unmarshalColorMaterialParameter x
   | x == gl_AMBIENT = Ambient
   | x == gl_DIFFUSE = Diffuse
   | x == gl_SPECULAR = Specular
   | x == gl_EMISSION = Emission
   | x == gl_AMBIENT_AND_DIFFUSE = AmbientAndDiffuse
   | otherwise = error ("unmarshalColorMaterialParameter: illegal value " ++ show x)

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

colorMaterial :: StateVar (Maybe (Face, ColorMaterialParameter))
colorMaterial =
   makeStateVarMaybe
      (return CapColorMaterial)
      (liftM2
         (,)
         (getEnum1 unmarshalFace GetColorMaterialFace)
         (getEnum1 unmarshalColorMaterialParameter GetColorMaterialParameter))
      (\(face, param) -> glColorMaterial (marshalFace face)
                                         (marshalColorMaterialParameter param))

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

data ShadingModel =
     Flat
   | Smooth
   deriving ( Eq, Ord, Show )

marshalShadingModel :: ShadingModel -> GLenum
marshalShadingModel x = case x of
   Flat -> gl_FLAT
   Smooth -> gl_SMOOTH

unmarshalShadingModel :: GLenum -> ShadingModel
unmarshalShadingModel x
   | x == gl_FLAT = Flat
   | x == gl_SMOOTH = Smooth
   | otherwise = error ("unmarshalShadingModel: illegal value " ++ show x)

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

shadeModel :: StateVar ShadingModel
shadeModel =
   makeStateVar
      (getEnum1 unmarshalShadingModel GetShadeModel)
      (glShadeModel . marshalShadingModel)

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

data ClampTarget =
     ClampVertexColor
   | ClampFragmentColor
   | ClampReadColor

marshalClampTarget :: ClampTarget -> GLenum
marshalClampTarget x = case x of
   ClampVertexColor -> gl_CLAMP_VERTEX_COLOR
   ClampFragmentColor -> gl_CLAMP_FRAGMENT_COLOR
   ClampReadColor -> gl_CLAMP_READ_COLOR

marshalClampTargetToPName :: ClampTarget -> PName1I
marshalClampTargetToPName x = case x of
   ClampFragmentColor -> GetFragmentColorClamp
   ClampVertexColor -> GetVertexColorClamp
   ClampReadColor -> GetReadColorClamp


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

data ClampMode =
     ClampOn
   | FixedOnly
   | ClampOff

marshalClampMode :: ClampMode -> GLenum
marshalClampMode x = case x of
   ClampOn -> gl_TRUE
   FixedOnly -> gl_FIXED_ONLY
   ClampOff -> gl_FALSE

unmarshalClampMode :: GLenum -> ClampMode
unmarshalClampMode x
   | x == gl_TRUE = ClampOn
   | x == gl_FIXED_ONLY = FixedOnly
   | x == gl_FALSE = ClampOff
   | otherwise = error $ "unmarshalClampMode: unknown enum value " ++ show x

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

clampColor :: ClampTarget -> StateVar ClampMode
clampColor ct = makeStateVar (getClampColor ct) (setClampColor ct)
   where setClampColor t = glClampColor (marshalClampTarget t) . marshalClampMode
         getClampColor = getEnum1 unmarshalClampMode . marshalClampTargetToPName