-------------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.OGL.GL.Colors -- Copyright : (c) Sven Panne 2002-2006 -- License : BSD-style (see the file libraries/OpenGL/LICENSE) -- -- Maintainer : sven.panne@aedion.de -- Stability : stable -- Portability : portable -- -- This module corresponds to section 2.14 (Colors and Coloring) of the -- OpenGL 2.1 specs. -- -------------------------------------------------------------------------------- module Graphics.Rendering.OGL.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 ) where import Control.Monad ( liftM2, liftM3 ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( allocaArray, withArray ) import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( Ptr ) import Foreign.Storable ( Storable(peek) ) import Graphics.Rendering.OGL.Monad import Graphics.Rendering.OGL.GL.Capability ( marshalCapability, unmarshalCapability, EnableCap(CapVertexProgramTwoSide,CapLighting,CapColorMaterial,CapLight), makeCapability, makeStateVarMaybe ) import Graphics.Rendering.OGL.GL.BasicTypes ( GLenum, GLint, GLsizei, GLfloat,Capability ) import Graphics.Rendering.OGL.GL.Face ( Face(..), marshalFace, unmarshalFace ) import Graphics.Rendering.OGL.GL.PeekPoke ( peek3 ) import Graphics.Rendering.OGL.GL.QueryUtils ( GetPName(GetMaxLights, GetFrontFace,GetShadeModel, GetLightModelAmbient, GetLightModelLocalViewer, GetLightModelTwoSide, GetLightModelColorControl, GetColorMaterialFace,GetColorMaterialParameter, GetMaxShininess,GetMaxSpotExponent), getBoolean1, getEnum1, getSizei1, getFloat1, getFloat4, lightIndexToEnum ) import Graphics.Rendering.OGL.GL.StateVar ( getIO, ($$=), GettableStateVar, makeGettableStateVar, StateVar, makeStateVar ) import Graphics.Rendering.OGL.GL.VertexSpec ( Color4(..), Normal3(..), Vertex4(..), Index1(..) ) import Graphics.Rendering.OGL.GLU.ErrorsInternal ( recordInvalidEnum ) -------------------------------------------------------------------------------- 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 -> 0x900 CCW -> 0x901 unmarshalFrontFaceDirection :: GLenum -> FrontFaceDirection unmarshalFrontFaceDirection x | x == 0x900 = CW | x == 0x901 = CCW | otherwise = error ("unmarshalFrontFaceDirection: illegal value " ++ show x) -------------------------------------------------------------------------------- frontFace :: StateVar FrontFaceDirection frontFace = makeStateVar (getEnum1 unmarshalFrontFaceDirection GetFrontFace) (glFrontFace . marshalFrontFaceDirection) foreign import CALLCONV unsafe "glFrontFace" glFrontFace :: GLenum -> IO () -------------------------------------------------------------------------------- data MaterialParameter = MaterialEmission | MaterialShininess | MaterialAmbientAndDiffuse | MaterialColorIndexes | MaterialAmbient | MaterialDiffuse | MaterialSpecular marshalMaterialParameter :: MaterialParameter -> GLenum marshalMaterialParameter x = case x of MaterialEmission -> 0x1600 MaterialShininess -> 0x1601 MaterialAmbientAndDiffuse -> 0x1602 MaterialColorIndexes -> 0x1603 MaterialAmbient -> 0x1200 MaterialDiffuse -> 0x1201 MaterialSpecular -> 0x1202 -------------------------------------------------------------------------------- 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 foreign import CALLCONV unsafe "glGetMaterialfv" glGetMaterialfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () foreign import CALLCONV unsafe "glMaterialfv" glMaterialfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () -------------------------------------------------------------------------------- materialShininess :: Face -> StateVar GLfloat materialShininess = makeMaterialVar glGetMaterialfvf glMaterialff MaterialShininess foreign import CALLCONV unsafe "glGetMaterialfv" glGetMaterialfvf :: GLenum -> GLenum -> Ptr GLfloat -> IO () foreign import CALLCONV unsafe "glMaterialfv" glMaterialff :: GLenum -> GLenum -> Ptr GLfloat -> IO () 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 foreign import CALLCONV unsafe "glGetMaterialiv" glGetMaterialiv :: GLenum -> GLenum -> Ptr GLint -> IO () 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) foreign import CALLCONV unsafe "glMaterialiv" glMaterialiv :: GLenum -> GLenum -> Ptr GLint -> IO () -------------------------------------------------------------------------------- data LightParameter = Ambient' | Diffuse' | Specular' | Position | SpotDirection | SpotExponent | SpotCutoff | ConstantAttenuation | LinearAttenuation | QuadraticAttenuation marshalLightParameter :: LightParameter -> GLenum marshalLightParameter x = case x of Ambient' -> 0x1200 Diffuse' -> 0x1201 Specular' -> 0x1202 Position -> 0x1203 SpotDirection -> 0x1204 SpotExponent -> 0x1205 SpotCutoff -> 0x1206 ConstantAttenuation -> 0x1207 LinearAttenuation -> 0x1208 QuadraticAttenuation -> 0x1209 -------------------------------------------------------------------------------- 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 foreign import CALLCONV unsafe "glGetLightfv" glGetLightfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () foreign import CALLCONV unsafe "glLightfv" glLightfvc :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () -------------------------------------------------------------------------------- position :: Light -> StateVar (Vertex4 GLfloat) position = makeLightVar glGetLightfvv glLightfvv Position (Vertex4 0 0 0 0) foreign import CALLCONV unsafe "glLightfv" glLightfvv :: GLenum -> GLenum -> Ptr (Vertex4 GLfloat) -> IO () foreign import CALLCONV unsafe "glGetLightfv" glGetLightfvv :: GLenum -> GLenum -> Ptr (Vertex4 GLfloat) -> IO () -------------------------------------------------------------------------------- spotDirection :: Light -> StateVar (Normal3 GLfloat) spotDirection = makeLightVar glGetLightfvn glLightfvn SpotDirection (Normal3 0 0 0) foreign import CALLCONV unsafe "glLightfv" glLightfvn :: GLenum -> GLenum -> Ptr (Normal3 GLfloat) -> IO () foreign import CALLCONV unsafe "glGetLightfv" glGetLightfvn :: GLenum -> GLenum -> Ptr (Normal3 GLfloat) -> IO () -------------------------------------------------------------------------------- spotExponent :: Light -> StateVar GLfloat spotExponent = makeLightVar glGetLightfv glLightfv SpotExponent 0 foreign import CALLCONV unsafe "glLightfv" glLightfv :: GLenum -> GLenum -> Ptr GLfloat -> IO () foreign import CALLCONV unsafe "glGetLightfv" glGetLightfv :: GLenum -> GLenum -> Ptr GLfloat -> IO () 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 (,,) (getIO (constantAttenuation theLight)) (getIO (linearAttenuation theLight)) (getIO (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 -> 0xb53 LightModelLocalViewer -> 0xb51 LightModelTwoSide -> 0xb52 LightModelColorControl -> 0x81f8 -------------------------------------------------------------------------------- lightModelAmbient :: StateVar (Color4 GLfloat) lightModelAmbient = makeStateVar (getFloat4 Color4 GetLightModelAmbient) (\c -> with c $ glLightModelfv (marshalLightModelParameter LightModelAmbient)) foreign import CALLCONV unsafe "glLightModelfv" glLightModelfv :: GLenum -> Ptr (Color4 GLfloat) -> IO () -------------------------------------------------------------------------------- lightModelLocalViewer :: StateVar Capability lightModelLocalViewer = makeLightModelCapVar GetLightModelLocalViewer LightModelLocalViewer makeLightModelCapVar :: GetPName -> LightModelParameter -> StateVar Capability makeLightModelCapVar pname lightModelParameter = makeStateVar (getBoolean1 unmarshalCapability pname) (glLightModeli (marshalLightModelParameter lightModelParameter) . fromIntegral . marshalCapability) foreign import CALLCONV unsafe "glLightModeli" glLightModeli :: GLenum -> GLint -> IO () -------------------------------------------------------------------------------- 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 -> 0x81f9 SeparateSpecularColor -> 0x81fa unmarshalLightModelColorControl :: GLenum -> LightModelColorControl unmarshalLightModelColorControl x | x == 0x81f9 = SingleColor | x == 0x81fa = 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 -> 0x1200 Diffuse -> 0x1201 Specular -> 0x1202 Emission -> 0x1600 AmbientAndDiffuse -> 0x1602 unmarshalColorMaterialParameter :: GLenum -> ColorMaterialParameter unmarshalColorMaterialParameter x | x == 0x1200 = Ambient | x == 0x1201 = Diffuse | x == 0x1202 = Specular | x == 0x1600 = Emission | x == 0x1602 = 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)) foreign import CALLCONV unsafe "glColorMaterial" glColorMaterial :: GLenum -> GLenum -> IO () -------------------------------------------------------------------------------- data ShadingModel = Flat | Smooth deriving ( Eq, Ord, Show ) marshalShadingModel :: ShadingModel -> GLenum marshalShadingModel x = case x of Flat -> 0x1d00 Smooth -> 0x1d01 unmarshalShadingModel :: GLenum -> ShadingModel unmarshalShadingModel x | x == 0x1d00 = Flat | x == 0x1d01 = Smooth | otherwise = error ("unmarshalShadingModel: illegal value " ++ show x) -------------------------------------------------------------------------------- shadeModel :: StateVar ShadingModel shadeModel = makeStateVar (getEnum1 unmarshalShadingModel GetShadeModel) (glShadeModel . marshalShadingModel) foreign import CALLCONV unsafe "glShadeModel" glShadeModel :: GLenum -> IO ()