module LambdaCube.GL.Util (
queryUniforms,
queryStreams,
mkUniformSetter,
setUniform,
setVertexAttrib,
compileShader,
printProgramLog,
glGetShaderiv1,
glGetProgramiv1,
Buffer(..),
ArrayDesc(..),
StreamSetter,
streamToInputType,
arrayTypeToGLType,
comparisonFunctionToGLType,
logicOperationToGLType,
blendEquationToGLType,
blendingFactorToGLType,
checkGL,
textureDataTypeToGLType,
textureDataTypeToGLArityType,
glGetIntegerv1,
setSampler,
checkFBO,
compileSampler,
compileTexture,
primitiveToFetchPrimitive,
primitiveToGLType,
inputTypeToTextureTarget
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.IORef
import Data.List as L
import Foreign
import Foreign.C.String
import qualified Data.Vector as V
import Data.Vector.Unboxed.Mutable (IOVector)
import qualified Data.Vector.Unboxed.Mutable as MV
import Data.Map (Map)
import qualified Data.Map as Map
import Graphics.GL.Core33
import LambdaCube.Linear
import LambdaCube.IR
import LambdaCube.PipelineSchema
import LambdaCube.GL.Type
setSampler :: GLint -> Int32 -> IO ()
setSampler i v = glUniform1i i $ fromIntegral v
z2 = V2 0 0 :: V2F
z3 = V3 0 0 0 :: V3F
z4 = V4 0 0 0 0 :: V4F
queryUniforms :: GLuint -> IO (Map String GLint, Map String InputType)
queryUniforms po = do
ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH
let uNames = [n | (n,_,_,_) <- ul]
uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]
uLocation = [i | (_,i,_,_) <- ul]
return $! (Map.fromList $! zip uNames uLocation, Map.fromList $! zip uNames uTypes)
b2w :: Bool -> GLuint
b2w True = 1
b2w False = 0
mkUniformSetter :: InputType -> IO (GLUniform, InputSetter)
mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)}
mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)}
mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)}
mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)}
mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)}
mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)}
mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)}
mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)}
mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)}
mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)}
mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)}
mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)}
mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)}
mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)}
mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)}
mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)}
mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)}
mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)}
mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)}
mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)}
mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)}
mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)}
mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)}
mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)}
mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)}
mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)}
setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()
setUniform i ty ref = do
v <- readIORef ref
let false = fromIntegral GL_FALSE
with v $ \p -> case ty of
Bool -> glUniform1uiv i 1 (castPtr p)
V2B -> glUniform2uiv i 1 (castPtr p)
V3B -> glUniform3uiv i 1 (castPtr p)
V4B -> glUniform4uiv i 1 (castPtr p)
Word -> glUniform1uiv i 1 (castPtr p)
V2U -> glUniform2uiv i 1 (castPtr p)
V3U -> glUniform3uiv i 1 (castPtr p)
V4U -> glUniform4uiv i 1 (castPtr p)
Int -> glUniform1iv i 1 (castPtr p)
V2I -> glUniform2iv i 1 (castPtr p)
V3I -> glUniform3iv i 1 (castPtr p)
V4I -> glUniform4iv i 1 (castPtr p)
Float -> glUniform1fv i 1 (castPtr p)
V2F -> glUniform2fv i 1 (castPtr p)
V3F -> glUniform3fv i 1 (castPtr p)
V4F -> glUniform4fv i 1 (castPtr p)
M22F -> glUniformMatrix2fv i 1 false (castPtr p)
M23F -> glUniformMatrix2x3fv i 1 false (castPtr p)
M24F -> glUniformMatrix2x4fv i 1 false (castPtr p)
M32F -> glUniformMatrix3x2fv i 1 false (castPtr p)
M33F -> glUniformMatrix3fv i 1 false (castPtr p)
M34F -> glUniformMatrix3x4fv i 1 false (castPtr p)
M42F -> glUniformMatrix4x2fv i 1 false (castPtr p)
M43F -> glUniformMatrix4x3fv i 1 false (castPtr p)
M44F -> glUniformMatrix4fv i 1 false (castPtr p)
FTexture2D -> return ()
_ -> fail $ "internal error (setUniform)! - " ++ show ty
queryStreams :: GLuint -> IO (Map String GLuint, Map String InputType)
queryStreams po = do
al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH
let aNames = [n | (n,_,_,_) <- al]
aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]
aLocation = [fromIntegral i | (_,i,_,_) <- al]
return $! (Map.fromList $! zip aNames aLocation, Map.fromList $! zip aNames aTypes)
arrayTypeToGLType :: ArrayType -> GLenum
arrayTypeToGLType a = case a of
ArrWord8 -> GL_UNSIGNED_BYTE
ArrWord16 -> GL_UNSIGNED_SHORT
ArrWord32 -> GL_UNSIGNED_INT
ArrInt8 -> GL_BYTE
ArrInt16 -> GL_SHORT
ArrInt32 -> GL_INT
ArrFloat -> GL_FLOAT
ArrHalf -> GL_HALF_FLOAT
setVertexAttrib :: GLuint -> Stream Buffer -> IO ()
setVertexAttrib i val = case val of
ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p
ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p
ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p
ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p
ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p
ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p
ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p
ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p
ConstFloat v -> setAFloat i v
ConstV2F v -> setAV2F i v
ConstV3F v -> setAV3F i v
ConstV4F v -> setAV4F i v
ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y
ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z
ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w
ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y
ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z
ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w
ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y
ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z
ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w
_ -> fail "internal error (setVertexAttrib)!"
setAFloat :: GLuint -> Float -> IO ()
setAV2F :: GLuint -> V2F -> IO ()
setAV3F :: GLuint -> V3F -> IO ()
setAV4F :: GLuint -> V4F -> IO ()
setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p
setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p
setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p
setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p
getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())
-> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(String,GLint,GLenum,GLint)]
getNameTypeSize o f g enum enumLen = do
nameLen <- glGetProgramiv1 enumLen o
allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do
n <- glGetProgramiv1 enum o
forM [0..n1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>
(,,,) <$> peekCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep
fromGLType :: (GLenum,GLint) -> InputType
fromGLType (t,1)
| t == GL_BOOL = Bool
| t == GL_BOOL_VEC2 = V2B
| t == GL_BOOL_VEC3 = V3B
| t == GL_BOOL_VEC4 = V4B
| t == GL_UNSIGNED_INT = Word
| t == GL_UNSIGNED_INT_VEC2 = V2U
| t == GL_UNSIGNED_INT_VEC3 = V3U
| t == GL_UNSIGNED_INT_VEC4 = V4U
| t == GL_INT = Int
| t == GL_INT_VEC2 = V2I
| t == GL_INT_VEC3 = V3I
| t == GL_INT_VEC4 = V4I
| t == GL_FLOAT = Float
| t == GL_FLOAT_VEC2 = V2F
| t == GL_FLOAT_VEC3 = V3F
| t == GL_FLOAT_VEC4 = V4F
| t == GL_FLOAT_MAT2 = M22F
| t == GL_FLOAT_MAT2x3 = M23F
| t == GL_FLOAT_MAT2x4 = M24F
| t == GL_FLOAT_MAT3x2 = M32F
| t == GL_FLOAT_MAT3 = M33F
| t == GL_FLOAT_MAT3x4 = M34F
| t == GL_FLOAT_MAT4x2 = M42F
| t == GL_FLOAT_MAT4x3 = M43F
| t == GL_FLOAT_MAT4 = M44F
| t == GL_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray
| t == GL_SAMPLER_1D_SHADOW = STexture1D
| t == GL_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray
| t == GL_SAMPLER_2D_RECT_SHADOW = STexture2DRect
| t == GL_SAMPLER_2D_SHADOW = STexture2D
| t == GL_SAMPLER_CUBE_SHADOW = STextureCube
| t == GL_INT_SAMPLER_1D = ITexture1D
| t == GL_INT_SAMPLER_1D_ARRAY = ITexture1DArray
| t == GL_INT_SAMPLER_2D = ITexture2D
| t == GL_INT_SAMPLER_2D_ARRAY = ITexture2DArray
| t == GL_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS
| t == GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray
| t == GL_INT_SAMPLER_2D_RECT = ITexture2DRect
| t == GL_INT_SAMPLER_3D = ITexture3D
| t == GL_INT_SAMPLER_BUFFER = ITextureBuffer
| t == GL_INT_SAMPLER_CUBE = ITextureCube
| t == GL_SAMPLER_1D = FTexture1D
| t == GL_SAMPLER_1D_ARRAY = FTexture1DArray
| t == GL_SAMPLER_2D = FTexture2D
| t == GL_SAMPLER_2D_ARRAY = FTexture2DArray
| t == GL_SAMPLER_2D_MULTISAMPLE = FTexture2DMS
| t == GL_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray
| t == GL_SAMPLER_2D_RECT = FTexture2DRect
| t == GL_SAMPLER_3D = FTexture3D
| t == GL_SAMPLER_BUFFER = FTextureBuffer
| t == GL_SAMPLER_CUBE = FTextureCube
| t == GL_UNSIGNED_INT_SAMPLER_1D = UTexture1D
| t == GL_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray
| t == GL_UNSIGNED_INT_SAMPLER_2D = UTexture2D
| t == GL_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray
| t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS
| t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray
| t == GL_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect
| t == GL_UNSIGNED_INT_SAMPLER_3D = UTexture3D
| t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer
| t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube
| otherwise = error "Failed fromGLType"
fromGLUniformType _ = error "Failed fromGLType"
printShaderLog :: GLuint -> IO String
printShaderLog o = do
i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o
case (i > 0) of
False -> return ""
True -> do
alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
glGetShaderInfoLog o (fromIntegral i) sizePtr ps
size <- peek sizePtr
log <- peekCStringLen (castPtr ps, fromIntegral size)
putStrLn log
return log
glGetShaderiv1 :: GLenum -> GLuint -> IO GLint
glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi
glGetProgramiv1 :: GLenum -> GLuint -> IO GLint
glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi
printProgramLog :: GLuint -> IO String
printProgramLog o = do
i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o
case (i > 0) of
False -> return ""
True -> do
alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
glGetProgramInfoLog o (fromIntegral i) sizePtr ps
size <- peek sizePtr
log <- peekCStringLen (castPtr ps, fromIntegral size)
unless (null log) $ putStrLn log
return log
compileShader :: GLuint -> [String] -> IO ()
compileShader o srcl = withMany withCString srcl $! \l -> withArray l $! \p -> do
glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
glCompileShader o
log <- printShaderLog o
status <- glGetShaderiv1 GL_COMPILE_STATUS o
when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["compileShader failed:",log]
checkGL :: IO String
checkGL = do
let f e | e == GL_INVALID_ENUM = "INVALID_ENUM"
| e == GL_INVALID_VALUE = "INVALID_VALUE"
| e == GL_INVALID_OPERATION = "INVALID_OPERATION"
| e == GL_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"
| e == GL_OUT_OF_MEMORY = "OUT_OF_MEMORY"
| e == GL_NO_ERROR = "OK"
| otherwise = "Unknown error"
e <- glGetError
return $ f e
streamToInputType :: Stream Buffer -> InputType
streamToInputType s = case s of
ConstWord _ -> Word
ConstV2U _ -> V2U
ConstV3U _ -> V3U
ConstV4U _ -> V4U
ConstInt _ -> Int
ConstV2I _ -> V2I
ConstV3I _ -> V3I
ConstV4I _ -> V4I
ConstFloat _ -> Float
ConstV2F _ -> V2F
ConstV3F _ -> V3F
ConstV4F _ -> V4F
ConstM22F _ -> M22F
ConstM23F _ -> M23F
ConstM24F _ -> M24F
ConstM32F _ -> M32F
ConstM33F _ -> M33F
ConstM34F _ -> M34F
ConstM42F _ -> M42F
ConstM43F _ -> M43F
ConstM44F _ -> M44F
Stream t (Buffer a _) i _ _
| 0 <= i && i < V.length a &&
if elem t integralTypes then elem at integralArrTypes else True
-> fromStreamType t
| otherwise -> error "streamToInputType failed"
where
at = arrType $! (a V.! i)
integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I]
integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]
comparisonFunctionToGLType :: ComparisonFunction -> GLenum
comparisonFunctionToGLType a = case a of
Always -> GL_ALWAYS
Equal -> GL_EQUAL
Gequal -> GL_GEQUAL
Greater -> GL_GREATER
Lequal -> GL_LEQUAL
Less -> GL_LESS
Never -> GL_NEVER
Notequal -> GL_NOTEQUAL
logicOperationToGLType :: LogicOperation -> GLenum
logicOperationToGLType a = case a of
And -> GL_AND
AndInverted -> GL_AND_INVERTED
AndReverse -> GL_AND_REVERSE
Clear -> GL_CLEAR
Copy -> GL_COPY
CopyInverted -> GL_COPY_INVERTED
Equiv -> GL_EQUIV
Invert -> GL_INVERT
Nand -> GL_NAND
Noop -> GL_NOOP
Nor -> GL_NOR
Or -> GL_OR
OrInverted -> GL_OR_INVERTED
OrReverse -> GL_OR_REVERSE
Set -> GL_SET
Xor -> GL_XOR
blendEquationToGLType :: BlendEquation -> GLenum
blendEquationToGLType a = case a of
FuncAdd -> GL_FUNC_ADD
FuncReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT
FuncSubtract -> GL_FUNC_SUBTRACT
Max -> GL_MAX
Min -> GL_MIN
blendingFactorToGLType :: BlendingFactor -> GLenum
blendingFactorToGLType a = case a of
ConstantAlpha -> GL_CONSTANT_ALPHA
ConstantColor -> GL_CONSTANT_COLOR
DstAlpha -> GL_DST_ALPHA
DstColor -> GL_DST_COLOR
One -> GL_ONE
OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA
OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR
OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA
OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR
OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA
OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR
SrcAlpha -> GL_SRC_ALPHA
SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE
SrcColor -> GL_SRC_COLOR
Zero -> GL_ZERO
textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum
textureDataTypeToGLType Color a = case a of
FloatT Red -> GL_R32F
IntT Red -> GL_R32I
WordT Red -> GL_R32UI
FloatT RG -> GL_RG32F
IntT RG -> GL_RG32I
WordT RG -> GL_RG32UI
FloatT RGBA -> GL_RGBA32F
IntT RGBA -> GL_RGBA32I
WordT RGBA -> GL_RGBA32UI
a -> error $ "FIXME: This texture format is not yet supported" ++ show a
textureDataTypeToGLType Depth a = case a of
FloatT Red -> GL_DEPTH_COMPONENT32F
WordT Red -> GL_DEPTH_COMPONENT32
a -> error $ "FIXME: This texture format is not yet supported" ++ show a
textureDataTypeToGLType Stencil a = case a of
a -> error $ "FIXME: This texture format is not yet supported" ++ show a
textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum
textureDataTypeToGLArityType Color a = case a of
FloatT Red -> GL_RED
IntT Red -> GL_RED
WordT Red -> GL_RED
FloatT RG -> GL_RG
IntT RG -> GL_RG
WordT RG -> GL_RG
FloatT RGBA -> GL_RGBA
IntT RGBA -> GL_RGBA
WordT RGBA -> GL_RGBA
a -> error $ "FIXME: This texture format is not yet supported" ++ show a
textureDataTypeToGLArityType Depth a = case a of
FloatT Red -> GL_DEPTH_COMPONENT
WordT Red -> GL_DEPTH_COMPONENT
a -> error $ "FIXME: This texture format is not yet supported" ++ show a
textureDataTypeToGLArityType Stencil a = case a of
a -> error $ "FIXME: This texture format is not yet supported" ++ show a
glGetIntegerv1 :: GLenum -> IO GLint
glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi
checkFBO :: IO String
checkFBO = do
let f e | e == GL_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"
| e == GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"
| e == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"
| e == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"
| e == GL_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"
| e == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"
| e == GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"
| e == GL_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"
| otherwise = "Unknown error"
e <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER
return $ f e
filterToGLType :: Filter -> GLenum
filterToGLType a = case a of
Nearest -> GL_NEAREST
Linear -> GL_LINEAR
NearestMipmapNearest -> GL_NEAREST_MIPMAP_NEAREST
NearestMipmapLinear -> GL_NEAREST_MIPMAP_LINEAR
LinearMipmapNearest -> GL_LINEAR_MIPMAP_NEAREST
LinearMipmapLinear -> GL_LINEAR_MIPMAP_LINEAR
edgeModeToGLType :: EdgeMode -> GLenum
edgeModeToGLType a = case a of
Repeat -> GL_REPEAT
MirroredRepeat -> GL_MIRRORED_REPEAT
ClampToEdge -> GL_CLAMP_TO_EDGE
ClampToBorder -> GL_CLAMP_TO_BORDER
data ParameterSetup
= ParameterSetup
{ setParameteri :: GLenum -> GLint -> IO ()
, setParameterfv :: GLenum -> Ptr GLfloat -> IO ()
, setParameterIiv :: GLenum -> Ptr GLint -> IO ()
, setParameterIuiv :: GLenum -> Ptr GLuint -> IO ()
, setParameterf :: GLenum -> GLfloat -> IO ()
}
setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()
setTextureSamplerParameters target = setParameters $ ParameterSetup
{ setParameteri = glTexParameteri target
, setParameterfv = glTexParameterfv target
, setParameterIiv = glTexParameterIiv target
, setParameterIuiv = glTexParameterIuiv target
, setParameterf = glTexParameterf target
}
setSamplerParameters :: GLuint -> SamplerDescriptor -> IO ()
setSamplerParameters samplerObj = setParameters $ ParameterSetup
{ setParameteri = glSamplerParameteri samplerObj
, setParameterfv = glSamplerParameterfv samplerObj
, setParameterIiv = glSamplerParameterIiv samplerObj
, setParameterIuiv = glSamplerParameterIuiv samplerObj
, setParameterf = glSamplerParameterf samplerObj
}
setParameters :: ParameterSetup -> SamplerDescriptor -> IO ()
setParameters ParameterSetup{..} s = do
setParameteri GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
case samplerWrapT s of
Nothing -> return ()
Just a -> setParameteri GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
case samplerWrapR s of
Nothing -> return ()
Just a -> setParameteri GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
setParameteri GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
setParameteri GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
let setBColorV4F a = with a $ \p -> setParameterfv GL_TEXTURE_BORDER_COLOR $ castPtr p
setBColorV4I a = with a $ \p -> setParameterIiv GL_TEXTURE_BORDER_COLOR $ castPtr p
setBColorV4U a = with a $ \p -> setParameterIuiv GL_TEXTURE_BORDER_COLOR $ castPtr p
case samplerBorderColor s of
VFloat a -> setBColorV4F $ V4 a 0 0 0
VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0
VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0
VV4F a -> setBColorV4F a
VInt a -> setBColorV4I $ V4 a 0 0 0
VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0
VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0
VV4I a -> setBColorV4I a
VWord a -> setBColorV4U $ V4 a 0 0 0
VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0
VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0
VV4U a -> setBColorV4U a
_ -> fail "internal error (setTextureSamplerParameters)!"
case samplerMinLod s of
Nothing -> return ()
Just a -> setParameterf GL_TEXTURE_MIN_LOD $ realToFrac a
case samplerMaxLod s of
Nothing -> return ()
Just a -> setParameterf GL_TEXTURE_MAX_LOD $ realToFrac a
setParameterf GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
case samplerCompareFunc s of
Nothing -> setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE
Just a -> do
setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE
setParameteri GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
compileSampler :: SamplerDescriptor -> IO GLSampler
compileSampler s = do
so <- alloca $! \po -> glGenSamplers 1 po >> peek po
setSamplerParameters so s
return $ GLSampler
{ glSamplerObject = so
}
compileTexture :: TextureDescriptor -> IO GLTexture
compileTexture txDescriptor = do
to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
let TextureDescriptor
{ textureType = txType
, textureSize = txSize
, textureSemantic = txSemantic
, textureSampler = txSampler
, textureBaseLevel = txBaseLevel
, textureMaxLevel = txMaxLevel
} = txDescriptor
txSetup txTarget dTy = do
let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy
dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy
glBindTexture txTarget to
glTexParameteri txTarget GL_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel
glTexParameteri txTarget GL_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel
setTextureSamplerParameters txTarget txSampler
return (internalFormat,dataFormat)
mipSize 0 x = [x]
mipSize n x = x : mipSize (n1) (x `div` 2)
mipS = mipSize (txMaxLevel txBaseLevel)
levels = [txBaseLevel..txMaxLevel]
target <- case txType of
Texture1D dTy layerCnt -> do
let VWord txW = txSize
txTarget = if layerCnt > 1 then GL_TEXTURE_1D_ARRAY else GL_TEXTURE_1D
(internalFormat,dataFormat) <- txSetup txTarget dTy
forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of
True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
return txTarget
Texture2D dTy layerCnt -> do
let VV2U (V2 txW txH) = txSize
txTarget = if layerCnt > 1 then GL_TEXTURE_2D_ARRAY else GL_TEXTURE_2D
(internalFormat,dataFormat) <- txSetup txTarget dTy
forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of
True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
return txTarget
Texture3D dTy -> do
let VV3U (V3 txW txH txD) = txSize
txTarget = GL_TEXTURE_3D
(internalFormat,dataFormat) <- txSetup txTarget dTy
forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) ->
glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
return txTarget
TextureCube dTy -> do
let VV2U (V2 txW txH) = txSize
txTarget = GL_TEXTURE_CUBE_MAP
targets =
[ GL_TEXTURE_CUBE_MAP_POSITIVE_X
, GL_TEXTURE_CUBE_MAP_NEGATIVE_X
, GL_TEXTURE_CUBE_MAP_POSITIVE_Y
, GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
, GL_TEXTURE_CUBE_MAP_POSITIVE_Z
, GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
]
(internalFormat,dataFormat) <- txSetup txTarget dTy
forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
return txTarget
TextureRect dTy -> do
let VV2U (V2 txW txH) = txSize
txTarget = GL_TEXTURE_RECTANGLE
(internalFormat,dataFormat) <- txSetup txTarget dTy
forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
return txTarget
Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do
let VV2U (V2 w h) = txSize
txTarget = if layerCnt > 1 then GL_TEXTURE_2D_MULTISAMPLE_ARRAY else GL_TEXTURE_2D_MULTISAMPLE
isFixed = fromIntegral $ if isFixedLocations then GL_TRUE else GL_FALSE
(internalFormat,dataFormat) <- txSetup txTarget dTy
case layerCnt > 1 of
True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed
False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed
return txTarget
TextureBuffer dTy -> do
fail "internal error: buffer texture is not supported yet"
let VV2U (V2 w h) = txSize
txTarget = GL_TEXTURE_2D
(internalFormat,dataFormat) <- txSetup txTarget dTy
glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
return txTarget
return $ GLTexture
{ glTextureObject = to
, glTextureTarget = target
}
primitiveToFetchPrimitive :: Primitive -> FetchPrimitive
primitiveToFetchPrimitive prim = case prim of
TriangleStrip -> Triangles
TriangleList -> Triangles
TriangleFan -> Triangles
LineStrip -> Lines
LineList -> Lines
PointList -> Points
TriangleStripAdjacency -> TrianglesAdjacency
TriangleListAdjacency -> TrianglesAdjacency
LineStripAdjacency -> LinesAdjacency
LineListAdjacency -> LinesAdjacency
primitiveToGLType :: Primitive -> GLenum
primitiveToGLType p = case p of
TriangleStrip -> GL_TRIANGLE_STRIP
TriangleList -> GL_TRIANGLES
TriangleFan -> GL_TRIANGLE_FAN
LineStrip -> GL_LINE_STRIP
LineList -> GL_LINES
PointList -> GL_POINTS
TriangleStripAdjacency -> GL_TRIANGLE_STRIP_ADJACENCY
TriangleListAdjacency -> GL_TRIANGLES_ADJACENCY
LineStripAdjacency -> GL_LINE_STRIP_ADJACENCY
LineListAdjacency -> GL_LINES_ADJACENCY
inputTypeToTextureTarget :: InputType -> GLenum
inputTypeToTextureTarget ty = case ty of
STexture1D -> GL_TEXTURE_1D
STexture2D -> GL_TEXTURE_2D
STextureCube -> GL_TEXTURE_CUBE_MAP
STexture1DArray -> GL_TEXTURE_1D_ARRAY
STexture2DArray -> GL_TEXTURE_2D_ARRAY
STexture2DRect -> GL_TEXTURE_RECTANGLE
FTexture1D -> GL_TEXTURE_1D
FTexture2D -> GL_TEXTURE_2D
FTexture3D -> GL_TEXTURE_3D
FTextureCube -> GL_TEXTURE_CUBE_MAP
FTexture1DArray -> GL_TEXTURE_1D_ARRAY
FTexture2DArray -> GL_TEXTURE_2D_ARRAY
FTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
FTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
FTextureBuffer -> GL_TEXTURE_BUFFER
FTexture2DRect -> GL_TEXTURE_RECTANGLE
ITexture1D -> GL_TEXTURE_1D
ITexture2D -> GL_TEXTURE_2D
ITexture3D -> GL_TEXTURE_3D
ITextureCube -> GL_TEXTURE_CUBE_MAP
ITexture1DArray -> GL_TEXTURE_1D_ARRAY
ITexture2DArray -> GL_TEXTURE_2D_ARRAY
ITexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
ITexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
ITextureBuffer -> GL_TEXTURE_BUFFER
ITexture2DRect -> GL_TEXTURE_RECTANGLE
UTexture1D -> GL_TEXTURE_1D
UTexture2D -> GL_TEXTURE_2D
UTexture3D -> GL_TEXTURE_3D
UTextureCube -> GL_TEXTURE_CUBE_MAP
UTexture1DArray -> GL_TEXTURE_1D_ARRAY
UTexture2DArray -> GL_TEXTURE_2D_ARRAY
UTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
UTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
UTextureBuffer -> GL_TEXTURE_BUFFER
UTexture2DRect -> GL_TEXTURE_RECTANGLE
_ -> error "internal error (inputTypeToTextureTarget)!"