module Graphics.LambdaCube.RenderSystem.GL.RenderSystem where
import Control.Monad
import Data.IORef
import Data.IntMap ((!))
import Data.Maybe
import Data.Word
import Foreign
import Foreign.C.String
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Graphics.Rendering.OpenGL.Raw.Core31
import qualified Graphics.Rendering.OpenGL.Raw.ARB as ARB
import qualified Graphics.Rendering.OpenGL.Raw.EXT as EXT
import qualified Graphics.Rendering.OpenGL.Raw.ARB.Compatibility as Compat
import Graphics.LambdaCube.BlendMode
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.RenderOperation
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.RenderSystem.GL.Capabilities
import Graphics.LambdaCube.RenderSystem.GL.GpuProgram
import Graphics.LambdaCube.RenderSystem.GL.IndexBuffer
import Graphics.LambdaCube.RenderSystem.GL.OcclusionQuery
import Graphics.LambdaCube.RenderSystem.GL.Texture
import Graphics.LambdaCube.RenderSystem.GL.Utils
import Graphics.LambdaCube.RenderSystem.GL.VertexBuffer
import Graphics.LambdaCube.RenderSystemCapabilities
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.TextureUnitState
import Graphics.LambdaCube.Types
import Graphics.LambdaCube.VertexIndexData
data GLState
= GLState
{ stLight :: (Proj4,[(Proj4,Light)])
, stSurface :: (FloatType4,FloatType4,FloatType4,FloatType4,FloatType,TrackVertexColourType)
}
mkGLState :: IO (IORef GLState)
mkGLState = do
let st = GLState
{ stLight = (idmtx,[])
, stSurface = (c,c,c,c,0,TrackVertexColourType False False False False)
}
c = (0,0,0,0)
newIORef st
instance Eq Proj4 where
a == b = fromProjective a == fromProjective b
data GLRenderSystem
= GLRenderSystem
{ glrsWorldMatrix :: IORef Proj4
, glrsViewMatrix :: IORef Proj4
, glrsCapabilities :: RenderSystemCapabilities
, glrsState :: IORef GLState
}
mkGLRenderSystem :: IO GLRenderSystem
mkGLRenderSystem = do
worldMat <- newIORef $ idmtx
viewMat <- newIORef $ idmtx
cap <- mkGLCapabilities
glState <- mkGLState
(major,minor) <- getGLVersion
extSList <- getGLExtensions
let ext = Set.fromList extSList
glVer a b = major > a || (major >= a && minor >= b)
supports s = Set.member s ext
f = fromIntegral
when (glVer 1 2) $ do
Compat.glLightModeli Compat.gl_LIGHT_MODEL_COLOR_CONTROL $ f Compat.gl_SEPARATE_SPECULAR_COLOR
Compat.glLightModeli Compat.gl_LIGHT_MODEL_LOCAL_VIEWER 1
when (glVer 1 4) $ do
glEnable Compat.gl_COLOR_SUM
glDisable gl_DITHER
when (supports "GL_ARB_multisample") $ do
fsaa <- getInteger ARB.gl_SAMPLE_BUFFERS
when (fsaa > 0) $ do
glEnable ARB.gl_MULTISAMPLE
putStrLn $ "Render System " ++ "Using FSAA from GL_ARB_multisample extension."
return $ GLRenderSystem
{ glrsWorldMatrix = worldMat
, glrsViewMatrix = viewMat
, glrsCapabilities = cap
, glrsState = glState
}
glWithFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO ()) -> IO ()
glWithFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do
glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) gl_RGBA gl_UNSIGNED_BYTE $ castPtr p
fn p
glDirtyHackCopyTexImage :: GLTexture -> Int -> Int -> Int -> Int -> IO ()
glDirtyHackCopyTexImage tex x y w h = do
glActiveTexture $ fromIntegral gl_TEXTURE0
glBindTexture gl_TEXTURE_2D $ gltxTextureObject tex
glCopyTexImage2D gl_TEXTURE_2D 0 gl_RGBA (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) 0
instance RenderSystem GLRenderSystem GLVertexBuffer GLIndexBuffer GLOcclusionQuery GLTexture GLGpuProgram GLLinkedGpuProgram where
withFrameBuffer _ = glWithFrameBuffer
dirtyHackCopyTexImage _ = glDirtyHackCopyTexImage
getName _ = "OpenGL Rendering Subsystem"
getCapabilities = glrsCapabilities
createVertexBuffer _ = mkGLVertexBuffer
createIndexBuffer _ = mkGLIndexBuffer
createOcclusionQuery _ = mkGLOcclusionQuery
createTexture rs = mkGLTexture (glrsCapabilities rs)
createGpuProgram _ = mkGLGpuProgram
createLinkedGpuProgram _ = mkGLLinkedGpuProgram
bindLinkedGpuProgram _ = glBindLinkedGpuProgram
unbindLinkedGpuProgram _ = glUnBindLinkedGpuProgram
render _ = glRender
bindGeometry _ = glBindGeometry
unbindGeometry rs = glUnBindGeometry (glrsCapabilities rs)
setViewport _ x y w h = glSetViewport x y w h
setPolygonMode _ pm = glSetPolygonMode pm
setWorldMatrix = glSetWorldMatrix
setViewMatrix = glSetViewMatrix
setProjectionMatrix _ m = glSetProjectionMatrix m
clearFrameBuffer _ b c d s = glClearFrameBuffer b c d s
setShadingType _ = glSetShadingType
setCullingMode _ = glSetCullingMode
setAlphaRejectSettings rs = glSetAlphaRejectSettings (glrsCapabilities rs)
setDepthBias _ = glSetDepthBias
setDepthBufferCheckEnabled _ = glSetDepthBufferCheckEnabled
setDepthBufferWriteEnabled _ = glSetDepthBufferWriteEnabled
setDepthBufferFunction _ = glSetDepthBufferFunction --FIXME
setColourBufferWriteEnabled _ = glSetColourBufferWriteEnabled
setSurfaceParams = glSetSurfaceParams
setLightingEnabled _ = glSetLightingEnabled
useLights = glUseLights
setFog _ = glSetFog
setSceneBlending _ = glSetSceneBlending
setSeparateSceneBlending _ = glSetSeparateSceneBlending
setPointParameters = glSetPointParameters
setPointSpritesEnabled rs = glSetPointSpritesEnabled (glrsCapabilities rs)
setActiveTextureUnit _ = glSetActiveTextureUnit
setTexture _ = glSetTexture
setTextureAddressingMode _ = glSetTextureAddressingMode
setTextureUnitFiltering _ = glSetTextureUnitFiltering
setTextureLayerAnisotropy _ = glSetTextureLayerAnisotropy
setTextureMipmapBias _ = glSetTextureMipmapBias
setTextureMatrix _ = glSetTextureMatrix
setTextureBorderColour _ = glSetTextureBorderColour
setTextureCoordCalculation _ = glSetTextureCoordCalculation
setTextureBlendMode rs = glSetTextureBlendMode (glrsCapabilities rs)
getMinimumDepthInputValue _ = 1
getMaximumDepthInputValue _ = 1
prepareRender _ = glPrepareRender
finishRender _ = glFinishRender
glPrepareRender :: IO ()
glPrepareRender = do
Compat.glColor3f 1 1 1
glEnable gl_SCISSOR_TEST
glFinishRender :: IO ()
glFinishRender = do
Compat.glColor3f 1 1 1
glDisable gl_SCISSOR_TEST
glSetDepthBias :: FloatType -> FloatType -> IO ()
glSetDepthBias constantBias slopeScaleBias = case constantBias /= 0 || slopeScaleBias /= 0 of
True -> do
glEnable gl_POLYGON_OFFSET_FILL
glEnable gl_POLYGON_OFFSET_POINT
glEnable gl_POLYGON_OFFSET_LINE
glPolygonOffset (realToFrac (slopeScaleBias)) (realToFrac (constantBias))
False -> do
glDisable gl_POLYGON_OFFSET_FILL
glDisable gl_POLYGON_OFFSET_POINT
glDisable gl_POLYGON_OFFSET_LINE
glSetViewport :: Int -> Int -> Int -> Int -> IO ()
glSetViewport x y w h = do
let x' = fromIntegral x
y' = fromIntegral y
w' = fromIntegral w
h' = fromIntegral h
glViewport x' y' w' h'
glScissor x' y' w' h'
glSetPolygonMode :: PolygonMode -> IO ()
glSetPolygonMode pm = case pm of
PM_POINTS -> polygonMode gl_POINT
PM_WIREFRAME -> polygonMode gl_LINE
PM_SOLID -> polygonMode gl_FILL
where
polygonMode m = do
glPolygonMode gl_FRONT m
glPolygonMode gl_BACK m
glSetupMatrix :: Proj4 -> Proj4 -> IO ()
glSetupMatrix vm wm = do
Compat.glMatrixMode Compat.gl_MODELVIEW
with (wm .*. vm) $ \mp -> do
Compat.glLoadMatrixf $ castPtr mp
glSetWorldMatrix :: GLRenderSystem -> Proj4 -> IO ()
glSetWorldMatrix rs wm = do
writeIORef (glrsWorldMatrix rs) wm
viewMat <- readIORef $ glrsViewMatrix rs
glSetupMatrix viewMat wm
glSetViewMatrix :: GLRenderSystem -> Proj4 -> IO ()
glSetViewMatrix rs vm = do
writeIORef (glrsViewMatrix rs) vm
worldMat <- readIORef $ glrsWorldMatrix rs
glSetupMatrix vm worldMat
glSetProjectionMatrix :: Mat4 -> IO ()
glSetProjectionMatrix pm = do
Compat.glMatrixMode Compat.gl_PROJECTION
with pm $ \pp -> do
Compat.glLoadMatrixf $ castPtr pp
glClearFrameBuffer :: FrameBufferType -> FloatType4 -> FloatType -> Word16 -> IO ()
glClearFrameBuffer buffers colour depth stencil = do
tmpColorMask <- getBoolean4 gl_COLOR_WRITEMASK
tmpDepthMask <- getBoolean gl_DEPTH_WRITEMASK
tmpStencilMask <- getInteger gl_STENCIL_WRITEMASK
tmpScissor <- getInteger4 gl_SCISSOR_BOX
when (fbtColour buffers) $ do
let (r',g',b',a') = colour
(r,g,b,a) = (f r',f g',f b',f a')
f :: FloatType -> GLclampf
f = realToFrac
glColorMask 1 1 1 1
glClearColor r g b a
when (fbtDepth buffers) $ do
let f :: FloatType -> GLclampd
f = realToFrac
glDepthMask $ fromIntegral gl_TRUE
glClearDepth $ f depth
when (fbtStencil buffers) $ do
let f :: Word16 -> GLint
f = fromIntegral
glStencilMask 0xFFFFFFFF
glClearStencil $ f stencil
let f = fromIntegral
(x,y,w,h) <- getInteger4 gl_VIEWPORT
glScissor x y (f w) (f h)
when (fbtColour buffers) $ glClear $ fromIntegral gl_COLOR_BUFFER_BIT
when (fbtDepth buffers) $ glClear $ fromIntegral gl_DEPTH_BUFFER_BIT
when (fbtStencil buffers) $ glClear $ fromIntegral gl_STENCIL_BUFFER_BIT
let uncurry4 mf (a,b,c,d) = mf (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)
uncurry4b mf (a,b,c,d) = mf (a) (b) (c) (d)
uncurry4 glScissor tmpScissor
glDepthMask $ fromIntegral tmpDepthMask
uncurry4b glColorMask tmpColorMask
glStencilMask $ fromIntegral tmpStencilMask
glBindGeometry :: (Texture t) => RenderOperation GLVertexBuffer GLIndexBuffer -> [TextureUnitState t] -> IO ()
glBindGeometry ro tl = do
let multitexturing = True
vertexData = roVertexData ro
decl = vdVertexDeclaration vertexData
checkBinding e = case vdVertexBufferBinding vertexData of
VertexBufferBinding bm -> veSource e `IntMap.member` bm
mapM_ (bindElement ro tl) $ filter checkBinding $ vdElementList decl
when multitexturing $ Compat.glClientActiveTexture gl_TEXTURE0
case roIndexData ro of
Just indexData -> glBindBuffer gl_ELEMENT_ARRAY_BUFFER $ glibBufferObject $ idIndexBuffer indexData
Nothing -> return ()
return ()
glUnBindGeometry :: RenderSystemCapabilities -> RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
glUnBindGeometry rsc _ro = do
let multitexturing = True
f = fromIntegral
Compat.glDisableClientState Compat.gl_VERTEX_ARRAY
case multitexturing of
True -> do
forM_ [0..(rscNumTextureUnits rsc 1)] $ \stage -> do
Compat.glClientActiveTexture $ fromIntegral gl_TEXTURE0 + f stage
Compat.glDisableClientState Compat.gl_TEXTURE_COORD_ARRAY
Compat.glClientActiveTexture gl_TEXTURE0
False -> Compat.glDisableClientState Compat.gl_TEXTURE_COORD_ARRAY
Compat.glDisableClientState Compat.gl_NORMAL_ARRAY
Compat.glDisableClientState Compat.gl_COLOR_ARRAY
Compat.glDisableClientState Compat.gl_SECONDARY_COLOR_ARRAY
glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0
glBindBuffer gl_ARRAY_BUFFER 0
return ()
glRender :: RenderOperation GLVertexBuffer GLIndexBuffer -> IO ()
glRender ro = do
let vertexData = roVertexData ro
primType = case roOperationType ro of
OT_POINT_LIST -> gl_POINTS
OT_LINE_LIST -> gl_LINES
OT_LINE_STRIP -> gl_LINE_STRIP
OT_TRIANGLE_LIST -> gl_TRIANGLES
OT_TRIANGLE_STRIP -> gl_TRIANGLE_STRIP
OT_TRIANGLE_FAN -> gl_TRIANGLE_FAN
case roIndexData ro of
Just indexData -> do
let indexBuffer = idIndexBuffer indexData
dp = if 0 /= glibBufferObject indexBuffer then nullPtr else fromMaybe (error "fromJust 7") $ glibShadowBuffer indexBuffer
pBufferData = plusPtr dp $ idIndexStart indexData * getIndexSize indexBuffer
indexType = if getIndexType indexBuffer == IT_16BIT then gl_UNSIGNED_SHORT else gl_UNSIGNED_INT
glDrawElements primType (fromIntegral (idIndexCount indexData)) indexType pBufferData
Nothing -> do
glDrawArrays primType 0 (fromIntegral (vdVertexCount vertexData))
bindElement :: (Texture t, HardwareIndexBuffer ib) => RenderOperation GLVertexBuffer ib -> [TextureUnitState t] -> VertexElement -> IO ()
bindElement rop tl elem = do
let vertexData = roVertexData $ rop
case vdVertexBufferBinding vertexData of
VertexBufferBinding bm -> let vertexBuffer = bm ! (veSource elem) in do
dp <- case glvbBufferObject vertexBuffer of
0 -> do
return $ fromMaybe (error "fromJust 8") $ glvbShadowBuffer vertexBuffer
b -> do
glBindBuffer gl_ARRAY_BUFFER b
return nullPtr
let pBufferData = plusPtr dp $ vdVertexStart vertexData * getVertexSize vertexBuffer + veOffset elem
sem = veSemantic elem
isCustomAttrib = False
bindWith t = t (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
bindWith' t = t (getGLType . veType $ elem) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
case isCustomAttrib of
True -> do
let attrib = fromIntegral . getFixedAttributeIndex sem $ veIndex elem
normalised = case veType elem of
VET_COLOUR_ABGR -> gl_TRUE
VET_COLOUR_ARGB -> gl_TRUE
_ -> gl_FALSE
glVertexAttribPointer attrib (fromIntegral . getTypeCount . veType $ elem) (getGLType . veType $ elem) (fromIntegral normalised) (fromIntegral . getVertexSize $ vertexBuffer) pBufferData
glEnableVertexAttribArray attrib
--attribsBound.push_back(attrib);
False -> case sem of
VES_POSITION -> bindWith Compat.glVertexPointer >> Compat.glEnableClientState Compat.gl_VERTEX_ARRAY
VES_NORMAL -> bindWith' Compat.glNormalPointer >> Compat.glEnableClientState Compat.gl_NORMAL_ARRAY
VES_DIFFUSE -> bindWith Compat.glColorPointer >> Compat.glEnableClientState Compat.gl_COLOR_ARRAY
VES_SPECULAR -> bindWith Compat.glSecondaryColorPointer >> Compat.glEnableClientState Compat.gl_SECONDARY_COLOR_ARRAY
VES_TEXTURE_COORDINATES -> do
let idx = veIndex elem
tus = map fst $ filter (\(_,a)-> idx==a) $ zip [0 :: Int ..] $ map tusTextureCoordSetIndex tl
forM_ tus $ \tidx -> do
Compat.glClientActiveTexture $ fromIntegral gl_TEXTURE0 + fromIntegral tidx
bindWith Compat.glTexCoordPointer >> Compat.glEnableClientState Compat.gl_TEXTURE_COORD_ARRAY
_ -> error "bindElement"
glSetShadingType :: ShadeOptions -> IO ()
glSetShadingType so = case so of
SO_FLAT -> Compat.glShadeModel Compat.gl_FLAT
_ -> Compat.glShadeModel Compat.gl_SMOOTH
glSetAlphaRejectSettings :: RenderSystemCapabilities -> CompareFunction -> Int -> Bool -> IO ()
glSetAlphaRejectSettings rsc func value alphaToCoverage = do
let caps = rscCapabilities rsc
f = fromIntegral :: Int -> GLclampf
case func == CMPF_ALWAYS_PASS of
{ True -> do
glDisable Compat.gl_ALPHA_TEST
when (Set.member RSC_ALPHA_TO_COVERAGE caps) $ glDisable gl_SAMPLE_ALPHA_TO_COVERAGE
; False -> do
glEnable Compat.gl_ALPHA_TEST
Compat.glAlphaFunc (convertCompareFunction func) (f value / 255)
when (Set.member RSC_ALPHA_TO_COVERAGE caps) $ case alphaToCoverage of
True -> glEnable gl_SAMPLE_ALPHA_TO_COVERAGE
False -> glDisable gl_SAMPLE_ALPHA_TO_COVERAGE
}
glSetDepthBufferCheckEnabled :: Bool -> IO ()
glSetDepthBufferCheckEnabled enabled = case enabled of
{ True -> glClearDepth 1 >> glEnable gl_DEPTH_TEST
; False -> glDisable gl_DEPTH_TEST
}
glSetDepthBufferWriteEnabled :: Bool -> IO ()
glSetDepthBufferWriteEnabled enabled = case enabled of
{ True -> glDepthMask $ fromIntegral gl_TRUE
; False -> glDepthMask $ fromIntegral gl_FALSE
}
glSetDepthBufferFunction :: CompareFunction -> IO ()
glSetDepthBufferFunction func = glDepthFunc $ convertCompareFunction func
glSetPointSpritesEnabled :: RenderSystemCapabilities -> Bool -> IO ()
glSetPointSpritesEnabled rsc enabled = when (Set.member RSC_POINT_SPRITES $ rscCapabilities rsc) $ do
case enabled of
{ True -> glEnable Compat.gl_POINT_SPRITE
; False -> glDisable Compat.gl_POINT_SPRITE
}
let en = if enabled then gl_TRUE else gl_FALSE
forM_ [0..rscNumTextureUnits rsc] $ \i -> do
glActiveTexture $ fromIntegral gl_TEXTURE0 + fromIntegral i
Compat.glTexEnvi Compat.gl_POINT_SPRITE Compat.gl_COORD_REPLACE $ fromIntegral en
glActiveTexture $ fromIntegral gl_TEXTURE0
glSetSceneBlending :: SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> IO ()
glSetSceneBlending sourceFactor destFactor op = do
case sourceFactor == SBF_ONE && destFactor == SBF_ZERO of
{ True -> glDisable gl_BLEND
; False -> do
glEnable gl_BLEND
glBlendFunc (getBlendMode sourceFactor) (getBlendMode destFactor)
}
glBlendEquation $ getBlendEquation op
glSetSurfaceParams :: GLRenderSystem -> FloatType4 -> FloatType4 -> FloatType4 -> FloatType4 -> FloatType -> TrackVertexColourType -> IO ()
glSetSurfaceParams rs ambient diffuse specular emissive shininess tc@(TrackVertexColourType a d s e) = do
st@GLState { stSurface } <- readIORef $ glrsState rs
let newSt = (ambient, diffuse, specular, emissive, shininess, tc)
when (stSurface /= newSt) $ do
writeIORef (glrsState rs) $ st { stSurface = newSt }
case (a,d,s,e) of
(False,False,False,False) -> glDisable Compat.gl_COLOR_MATERIAL
(True,True,_,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_AMBIENT_AND_DIFFUSE
(True,False,_,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_AMBIENT
(_,True,_,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_DIFFUSE
(_,_,True,_) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_SPECULAR
(_,_,_,True) -> glEnable Compat.gl_COLOR_MATERIAL >> Compat.glColorMaterial gl_FRONT_AND_BACK Compat.gl_EMISSION
let f = realToFrac
c (r,g,b,a') = [f r, f g, f b, f a']
withArray (c diffuse) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_DIFFUSE p
withArray (c ambient) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_AMBIENT p
withArray (c specular) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_SPECULAR p
withArray (c emissive) $ \p -> Compat.glMaterialfv gl_FRONT_AND_BACK Compat.gl_EMISSION p
Compat.glMaterialf gl_FRONT_AND_BACK Compat.gl_SHININESS $ f shininess
glSetLightingEnabled :: Bool -> IO ()
glSetLightingEnabled enabled = case enabled of
True -> glEnable Compat.gl_LIGHTING
False -> glDisable Compat.gl_LIGHTING
glSetFog :: FogMode -> FloatType4 -> FloatType -> FloatType -> FloatType -> IO ()
glSetFog mode (r,g,b,a) density start end = case mode of
FOG_NONE -> glDisable Compat.gl_FOG
FOG_EXP -> setFog $ fromIntegral Compat.gl_EXP
FOG_EXP2 -> setFog $ fromIntegral Compat.gl_EXP2
FOG_LINEAR-> setFog $ fromIntegral gl_LINEAR
where
f = realToFrac
setFog fm = withArray [r,g,b,a] $ \p -> do
glEnable Compat.gl_FOG
Compat.glFogi Compat.gl_FOG_MODE fm
Compat.glFogfv Compat.gl_FOG_COLOR $ castPtr p
Compat.glFogf Compat.gl_FOG_DENSITY $ f density
Compat.glFogf Compat.gl_FOG_START $ f start
Compat.glFogf Compat.gl_FOG_END $ f end
glSetSeparateSceneBlending :: SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> SceneBlendOperation -> IO ()
glSetSeparateSceneBlending sourceFactor destFactor sourceFactorAlpha destFactorAlpha op alphaOp = do
case sourceFactor == SBF_ONE && destFactor == SBF_ZERO &&
sourceFactorAlpha == SBF_ONE && destFactorAlpha == SBF_ZERO of
True -> glDisable gl_BLEND
False -> do
let f = getBlendMode
glEnable gl_BLEND
glBlendFuncSeparate (f sourceFactor) (f sourceFactorAlpha) (f destFactor) (f destFactorAlpha)
glBlendEquationSeparate (getBlendEquation op) (getBlendEquation alphaOp)
glSetPointParameters :: (RenderSystem rs vb ib q t p lp) => rs -> FloatType -> Bool -> FloatType -> FloatType -> FloatType -> FloatType -> FloatType -> IO ()
glSetPointParameters rs size attenuationEnabled constant linear quadratic minSize maxSize = do
let rsc = getCapabilities rs
caps = rscCapabilities rsc
f = realToFrac
(size',_minSize',_maxSize',val') <- case attenuationEnabled of
True -> do
when (Set.member RSC_VERTEX_PROGRAM caps) $
glEnable gl_VERTEX_PROGRAM_POINT_SIZE
let correction = 0.005
return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,[f $ constant,f $ linear * correction,f $ quadratic * correction,1])
False -> do
when (Set.member RSC_VERTEX_PROGRAM caps) $
glDisable gl_VERTEX_PROGRAM_POINT_SIZE
return (size,minSize,if maxSize == 0 then rscMaxPointSize rsc else maxSize,[1,0,0,1])
glPointSize $ f size'
withArray val' $ \val -> case Set.member RSC_POINT_EXTENDED_PARAMETERS caps of
True -> do
glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
False -> case Set.member RSC_POINT_EXTENDED_PARAMETERS_ARB caps of
True -> do
ARB.glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
ARB.glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
ARB.glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
False -> case Set.member RSC_POINT_EXTENDED_PARAMETERS_EXT caps of
True -> do
EXT.glPointParameterfv Compat.gl_POINT_DISTANCE_ATTENUATION val
EXT.glPointParameterf Compat.gl_POINT_SIZE_MIN $ f minSize
EXT.glPointParameterf Compat.gl_POINT_SIZE_MAX $ f maxSize
False -> return ()
glSetActiveTextureUnit :: Int -> IO ()
glSetActiveTextureUnit stage = do
let f = fromIntegral
glActiveTexture $ fromIntegral $ gl_TEXTURE0 + f stage
glSetTexture :: Maybe GLTexture -> IO ()
glSetTexture tex = do
glDisable gl_TEXTURE_1D
glBindTexture gl_TEXTURE_1D 0
glDisable gl_TEXTURE_2D
glBindTexture gl_TEXTURE_2D 0
glDisable gl_TEXTURE_3D
glBindTexture gl_TEXTURE_3D 0
glDisable gl_TEXTURE_CUBE_MAP
glBindTexture gl_TEXTURE_CUBE_MAP 0
case tex of
Just t -> do
let target = getGLTextureTarget $ txTextureType t
glEnable target
glBindTexture target $ gltxTextureObject t
Nothing -> return ()
--TODO
glUseLights :: GLRenderSystem -> [(Proj4,Light)] -> IO ()
glUseLights rs lights = do
viewMat <- readIORef $ glrsViewMatrix rs
worldMat <- readIORef $ glrsWorldMatrix rs
st@GLState { stLight } <- readIORef $ glrsState rs
when (stLight /= (worldMat, lights)) $ do
writeIORef (glrsState rs) $ st { stLight = (worldMat,lights) }
glSetupMatrix viewMat idmtx
forM_ [length lights..7] $ \i -> glDisable $ Compat.gl_LIGHT0 + fromIntegral i
forM_ (zip [0..] $ take 8 lights) $ \(i,(mt,lt)) -> do
let gl_index = Compat.gl_LIGHT0 + i
rad2deg = 180 / pi
f = realToFrac
c (r,g,b,a) = [f r, f g, f b, f a]
pos1 = _4 $ fromProjective mt
case lgType lt of
LT_SPOTLIGHT -> do
Compat.glLightf gl_index Compat.gl_SPOT_CUTOFF $ realToFrac $ 0.5 * rad2deg * lgSpotOuter lt
Compat.glLightf gl_index Compat.gl_SPOT_EXPONENT $ realToFrac $ lgSpotFalloff lt
_ -> Compat.glLightf gl_index Compat.gl_SPOT_CUTOFF 180
withArray (c $ lgDiffuse lt) $ \p ->
Compat.glLightfv gl_index Compat.gl_DIFFUSE p
withArray (c $ lgSpecular lt) $ \p ->
Compat.glLightfv gl_index Compat.gl_SPECULAR p
withArray [0,0,0,1] $ \p ->
Compat.glLightfv gl_index Compat.gl_AMBIENT p
let pos = if lgType lt == LT_DIRECTIONAL then neg dir4 else pos1
dir4 = (extendZero $ lgDirection lt :: Vec4) .* (fromProjective mt)
with pos $ \p ->
Compat.glLightfv gl_index Compat.gl_POSITION $ castPtr p
when (lgType lt == LT_SPOTLIGHT) $ with dir4 $ \p ->
Compat.glLightfv gl_index Compat.gl_SPOT_DIRECTION $ castPtr p
Compat.glLightf gl_index Compat.gl_CONSTANT_ATTENUATION $ realToFrac $ lgAttenuationConst lt
Compat.glLightf gl_index Compat.gl_LINEAR_ATTENUATION $ realToFrac $ lgAttenuationLinear lt
Compat.glLightf gl_index Compat.gl_QUADRATIC_ATTENUATION $ realToFrac $ lgAttenuationQuad lt
glEnable gl_index
glSetupMatrix viewMat worldMat
glSetTextureAddressingMode :: TextureType -> UVWAddressingMode -> IO ()
glSetTextureAddressingMode texTarget (UVWAddressingMode u v w) = do
let target = getGLTextureTarget texTarget
glTexParameteri target gl_TEXTURE_WRAP_S $ fromIntegral $ getTextureAddressingMode u
glTexParameteri target gl_TEXTURE_WRAP_T $ fromIntegral $ getTextureAddressingMode v
glTexParameteri target gl_TEXTURE_WRAP_R $ fromIntegral $ getTextureAddressingMode w
glSetTextureBorderColour :: TextureType -> FloatType4 -> IO ()
glSetTextureBorderColour texTarget (r,g,b,a) = withArray [r,g,b,a] $ \p -> do
let target = getGLTextureTarget texTarget
glTexParameterfv target gl_TEXTURE_BORDER_COLOR $ castPtr p
glSetTextureUnitFiltering :: TextureType -> FilterOptions -> FilterOptions -> FilterOptions -> IO ()
glSetTextureUnitFiltering texTarget minFilter magFilter mipFilter = do
let target = getGLTextureTarget texTarget
mag = case magFilter of
FO_ANISOTROPIC -> gl_LINEAR
FO_LINEAR -> gl_LINEAR
FO_POINT -> gl_NEAREST
FO_NONE -> gl_NEAREST
min' = case minFilter of
FO_ANISOTROPIC -> FO_LINEAR
FO_LINEAR -> FO_LINEAR
FO_POINT -> FO_POINT
FO_NONE -> FO_POINT
mip = case mipFilter of
FO_ANISOTROPIC -> Just FO_LINEAR
FO_LINEAR -> Just FO_LINEAR
FO_POINT -> Just FO_POINT
FO_NONE -> Nothing
min'' = case (min',mip) of
(FO_POINT, Nothing) -> gl_NEAREST
(FO_LINEAR, Nothing) -> gl_LINEAR
(FO_POINT, Just FO_POINT) -> gl_NEAREST_MIPMAP_NEAREST
(FO_LINEAR, Just FO_POINT) -> gl_LINEAR_MIPMAP_NEAREST
(FO_POINT, Just FO_LINEAR) -> gl_NEAREST_MIPMAP_LINEAR
(FO_LINEAR, Just FO_LINEAR) -> gl_LINEAR_MIPMAP_LINEAR
_ -> error "glSetTextureUnitFiltering"
glTexParameteri target gl_TEXTURE_MAG_FILTER $ fromIntegral mag
glTexParameteri target gl_TEXTURE_MIN_FILTER $ fromIntegral min''
glSetTextureLayerAnisotropy :: TextureType -> Int -> IO ()
glSetTextureLayerAnisotropy texTarget maxAnisotropy = do
largest_supported_anisotropy <- alloca $ \p-> do
glGetFloatv EXT.gl_MAX_TEXTURE_MAX_ANISOTROPY p
peek p
let target = getGLTextureTarget texTarget
maxAnisotropy' = if fromIntegral maxAnisotropy > largest_supported_anisotropy then largest_supported_anisotropy else fromIntegral maxAnisotropy
glTexParameterf target EXT.gl_TEXTURE_MAX_ANISOTROPY maxAnisotropy'
glSetTextureMipmapBias :: FloatType -> IO ()
glSetTextureMipmapBias bias = do
Compat.glTexEnvf EXT.gl_TEXTURE_FILTER_CONTROL EXT.gl_TEXTURE_LOD_BIAS $ realToFrac bias
glSetTextureBlendMode :: RenderSystemCapabilities -> LayerBlendModeEx -> LayerBlendModeEx -> IO ()
glSetTextureBlendMode rsc colorbm alphabm = do
let caps = rscCapabilities rsc
hasDot3 = Set.member RSC_DOT3 caps
csrc1op = getLayerBlendSource $ lbSource1 colorbm
csrc2op = getLayerBlendSource $ lbSource2 colorbm
ccmd = getTextureCombineFunction hasDot3 $ lbOperation colorbm
asrc1op = getLayerBlendSource $ lbSource1 alphabm
asrc2op = getLayerBlendSource $ lbSource2 alphabm
acmd = getTextureCombineFunction hasDot3 $ lbOperation alphabm
f = realToFrac
src2Fun m = do
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_RGB m
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_ALPHA m
cf (r,g,b,a) = [f r, f g, f b, f a]
alphaCol (r,g,b,_) a = cf (r, g, b, a)
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_MODE $ fromIntegral Compat.gl_COMBINE
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_COMBINE_RGB $ fromIntegral ccmd
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE0_RGB $ fromIntegral csrc1op
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE1_RGB $ fromIntegral csrc2op
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_RGB $ fromIntegral Compat.gl_CONSTANT
case lbOperation colorbm of
LBX_BLEND_DIFFUSE_COLOUR -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
LBX_BLEND_DIFFUSE_ALPHA -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
LBX_BLEND_TEXTURE_ALPHA -> src2Fun $ fromIntegral gl_TEXTURE
LBX_BLEND_CURRENT_ALPHA -> src2Fun $ fromIntegral Compat.gl_PREVIOUS
LBX_BLEND_MANUAL -> withArray [0, 0, 0, realToFrac $ lbFactor colorbm] $ \p ->
Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
LBX_MODULATE_X2 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 2
LBX_MODULATE_X4 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 4
_ -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_RGB_SCALE 1
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_RGB $ fromIntegral gl_SRC_COLOR
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_RGB $ fromIntegral gl_SRC_COLOR
case lbOperation colorbm of
LBX_BLEND_DIFFUSE_COLOUR -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_RGB $ fromIntegral gl_SRC_COLOR
_ -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_RGB $ fromIntegral gl_SRC_ALPHA
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_ALPHA $ fromIntegral gl_SRC_ALPHA
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_ALPHA $ fromIntegral gl_SRC_ALPHA
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_ALPHA $ fromIntegral gl_SRC_ALPHA
when (lbSource1 colorbm == LBS_MANUAL) $ withArray (cf $ lbColourArg1 colorbm) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
when (lbSource2 colorbm == LBS_MANUAL) $ withArray (cf $ lbColourArg2 colorbm) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_MODE $ fromIntegral Compat.gl_COMBINE
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_COMBINE_ALPHA $ fromIntegral acmd
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE0_ALPHA $ fromIntegral asrc1op
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE1_ALPHA $ fromIntegral asrc2op
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_SOURCE2_ALPHA $ fromIntegral Compat.gl_CONSTANT
case lbOperation alphabm of
LBX_BLEND_DIFFUSE_COLOUR -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
LBX_BLEND_DIFFUSE_ALPHA -> src2Fun $ fromIntegral Compat.gl_PRIMARY_COLOR
LBX_BLEND_TEXTURE_ALPHA -> src2Fun $ fromIntegral gl_TEXTURE
LBX_BLEND_CURRENT_ALPHA -> src2Fun $ fromIntegral Compat.gl_PREVIOUS
LBX_BLEND_MANUAL -> withArray [0, 0, 0, realToFrac $ lbFactor alphabm] $ \p ->
Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
LBX_MODULATE_X2 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 2
LBX_MODULATE_X4 -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 4
_ -> Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_ALPHA_SCALE 1
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND0_ALPHA $ fromIntegral gl_SRC_ALPHA
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND1_ALPHA $ fromIntegral gl_SRC_ALPHA
Compat.glTexEnvi Compat.gl_TEXTURE_ENV Compat.gl_OPERAND2_ALPHA $ fromIntegral gl_SRC_ALPHA
when (lbSource1 alphabm == LBS_MANUAL) $ withArray (alphaCol (lbColourArg1 colorbm) (lbAlphaArg1 alphabm)) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
when (lbSource2 alphabm == LBS_MANUAL) $ withArray (alphaCol (lbColourArg2 colorbm) (lbAlphaArg2 alphabm)) $ \p -> Compat.glTexEnvfv Compat.gl_TEXTURE_ENV Compat.gl_TEXTURE_ENV_COLOR p
glSetCullingMode :: CullingMode -> IO ()
glSetCullingMode mode = case mode of
CULL_NONE -> glDisable gl_CULL_FACE
CULL_CLOCKWISE -> glEnable gl_CULL_FACE >> glCullFace gl_BACK
CULL_ANTICLOCKWISE -> glEnable gl_CULL_FACE >> glCullFace gl_FRONT
glSetColourBufferWriteEnabled :: Bool -> Bool -> Bool -> Bool -> IO ()
glSetColourBufferWriteEnabled r g b a = do
let f = fromBool
glColorMask (f r) (f g) (f b) (f a)
glBindLinkedGpuProgram :: GLLinkedGpuProgram -> IO ()
glBindLinkedGpuProgram lp = do
let p = gllgpProgramObject lp
withGLString :: String -> (Ptr GLchar -> IO a) -> IO a
withGLString s act = withCAString s $ act . castPtr
glUseProgram p
loc_tex0 <- withGLString "tex0" $ glGetUniformLocation p
loc_tex1 <- withGLString "tex1" $ glGetUniformLocation p
glUniform1i loc_tex0 0
glUniform1i loc_tex1 1
glUnBindLinkedGpuProgram :: IO ()
glUnBindLinkedGpuProgram = glUseProgram 0
glSetTextureMatrix :: Proj4 -> IO ()
glSetTextureMatrix xform = do
Compat.glMatrixMode gl_TEXTURE
with xform $ \p -> do
Compat.glLoadMatrixf $ castPtr p
glSetTextureCoordCalculation :: TexCoordCalcMethod -> IO ()
glSetTextureCoordCalculation m = case m of
TEXCALC_NONE -> do
glDisable Compat.gl_TEXTURE_GEN_S
glDisable Compat.gl_TEXTURE_GEN_T
glDisable Compat.gl_TEXTURE_GEN_R
glDisable Compat.gl_TEXTURE_GEN_Q
TEXCALC_ENVIRONMENT_MAP -> do
Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
glEnable Compat.gl_TEXTURE_GEN_S
glEnable Compat.gl_TEXTURE_GEN_T
glDisable Compat.gl_TEXTURE_GEN_R
glDisable Compat.gl_TEXTURE_GEN_Q
TEXCALC_ENVIRONMENT_MAP_PLANAR -> do
Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_SPHERE_MAP
glEnable Compat.gl_TEXTURE_GEN_S
glEnable Compat.gl_TEXTURE_GEN_T
glDisable Compat.gl_TEXTURE_GEN_R
glDisable Compat.gl_TEXTURE_GEN_Q
TEXCALC_ENVIRONMENT_MAP_REFLECTION -> do
Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_REFLECTION_MAP
glEnable Compat.gl_TEXTURE_GEN_S
glEnable Compat.gl_TEXTURE_GEN_T
glEnable Compat.gl_TEXTURE_GEN_R
glDisable Compat.gl_TEXTURE_GEN_Q
TEXCALC_ENVIRONMENT_MAP_NORMAL -> do
Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_NORMAL_MAP
glEnable Compat.gl_TEXTURE_GEN_S
glEnable Compat.gl_TEXTURE_GEN_T
glEnable Compat.gl_TEXTURE_GEN_R
glDisable Compat.gl_TEXTURE_GEN_Q
TEXCALC_PROJECTIVE_TEXTURE -> do
Compat.glTexGeni Compat.gl_S Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
Compat.glTexGeni Compat.gl_T Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
Compat.glTexGeni Compat.gl_R Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
Compat.glTexGeni Compat.gl_Q Compat.gl_TEXTURE_GEN_MODE $ fromIntegral Compat.gl_EYE_LINEAR
withArray [1, 0, 0, 0] $ \p -> Compat.glTexGenfv Compat.gl_S Compat.gl_EYE_PLANE p
withArray [0, 1, 0, 0] $ \p -> Compat.glTexGenfv Compat.gl_T Compat.gl_EYE_PLANE p
withArray [0, 0, 1, 0] $ \p -> Compat.glTexGenfv Compat.gl_R Compat.gl_EYE_PLANE p
withArray [0, 0, 0, 1] $ \p -> Compat.glTexGenfv Compat.gl_Q Compat.gl_EYE_PLANE p
glEnable Compat.gl_TEXTURE_GEN_S
glEnable Compat.gl_TEXTURE_GEN_T
glEnable Compat.gl_TEXTURE_GEN_R
glEnable Compat.gl_TEXTURE_GEN_Q