{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} module LambdaCube.GL.Util ( queryUniforms, queryStreams, initializeUniform, 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, TypeMismatch(..), typeMismatch ) 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 Data.Typeable import Data.Dependent.Sum import qualified Data.Dependent.Map as DMap import Data.Some import Graphics.GL.Core33 import LambdaCube.Linear import LambdaCube.IR import LambdaCube.PipelineSchema import LambdaCube.GL.Type import LambdaCube.GL.Input.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 -- uniform functions 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 instance GLData Bool (GLVector 1 GLuint) where marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w b) (f 1) instance GLData (V2 Bool) (GLVector 2 GLuint) where marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr) instance GLData (V3 Bool) (GLVector 3 GLuint) where marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr) instance GLData (V4 Bool) (GLVector 4 GLuint) where marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr) instance Uniformable Bool where uniformContexts _ = contexts $ supports TypeBool instance Uniformable (V2 Bool) where uniformContexts _ = contexts $ supports TypeV2B instance Uniformable (V3 Bool) where uniformContexts _ = contexts $ supports TypeV3B instance Uniformable (V4 Bool) where uniformContexts _ = contexts $ supports TypeV4B instance GLData Word32 (GLVector 1 GLuint) instance GLData (V2 Word32) (GLVector 2 GLuint) instance GLData (V3 Word32) (GLVector 3 GLuint) instance GLData (V4 Word32) (GLVector 4 GLuint) instance Uniformable Word32 where uniformContexts _ = contexts $ supports TypeWord instance Uniformable (V2 Word32) where uniformContexts _ = contexts $ supports TypeV2U instance Uniformable (V3 Word32) where uniformContexts _ = contexts $ supports TypeV3U instance Uniformable (V4 Word32) where uniformContexts _ = contexts $ supports TypeV4U instance GLData Int32 (GLVector 1 GLint) instance GLData (V2 Int32) (GLVector 2 GLint) instance GLData (V3 Int32) (GLVector 3 GLint) instance GLData (V4 Int32) (GLVector 4 GLint) instance Uniformable Int32 where uniformContexts _ = contexts $ supports TypeInt instance Uniformable (V2 Int32) where uniformContexts _ = contexts $ supports TypeV2I instance Uniformable (V3 Int32) where uniformContexts _ = contexts $ supports TypeV3I instance Uniformable (V4 Int32) where uniformContexts _ = contexts $ supports TypeV4I instance GLData Float (GLVector 1 GLfloat) instance GLData (V2 Float) (GLVector 2 GLfloat) instance GLData (V3 Float) (GLVector 3 GLfloat) instance GLData (V4 Float) (GLVector 4 GLfloat) instance Uniformable Float where uniformContexts _ = contexts $ supports TypeFloat instance Uniformable (V2 Float) where uniformContexts _ = contexts $ supports TypeV2F instance Uniformable (V3 Float) where uniformContexts _ = contexts $ supports TypeV3F instance Uniformable (V4 Float) where uniformContexts _ = contexts $ supports TypeV4F instance GLData (V2 V2F) (GLMatrix 2 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V3 V2F) (GLMatrix 3 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V4 V2F) (GLMatrix 4 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V2 V3F) (GLMatrix 2 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V3 V3F) (GLMatrix 3 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V4 V3F) (GLMatrix 4 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V2 V4F) (GLMatrix 2 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V3 V4F) (GLMatrix 3 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance GLData (V4 V4F) (GLMatrix 4 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor instance Uniformable (V2 V2F) where uniformContexts _ = contexts $ supports TypeM22F instance Uniformable (V3 V2F) where uniformContexts _ = contexts $ supports TypeM23F instance Uniformable (V4 V2F) where uniformContexts _ = contexts $ supports TypeM24F instance Uniformable (V2 V3F) where uniformContexts _ = contexts $ supports TypeM32F instance Uniformable (V3 V3F) where uniformContexts _ = contexts $ supports TypeM33F instance Uniformable (V4 V3F) where uniformContexts _ = contexts $ supports TypeM34F instance Uniformable (V2 V4F) where uniformContexts _ = contexts $ supports TypeM42F instance Uniformable (V3 V4F) where uniformContexts _ = contexts $ supports TypeM43F instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports TypeM44F instance Uniformable TextureData where uniformContexts _ = DMap.empty instance Uniformable TextureCubeData where uniformContexts _ = DMap.empty mkU :: GLData a c => TypeTag c -> a -> IO GLUniform mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a) initializeUniform :: InputType -> IO GLUniform initializeUniform t = case witnessType t of Just (This ty) -> case ty of TypeBool -> mkU ty False TypeV2B -> mkU ty (V2 False False) TypeV3B -> mkU ty (V3 False False False) TypeV4B -> mkU ty (V4 False False False False) TypeWord -> mkU ty (0::Word32) TypeV2U -> mkU ty (V2 0 0 :: V2 Word32) TypeV3U -> mkU ty (V3 0 0 0 :: V3 Word32) TypeV4U -> mkU ty (V4 0 0 0 0 :: V4 Word32) TypeInt -> mkU ty (0::Int32) TypeV2I -> mkU ty (V2 0 0 :: V2 Int32) TypeV3I -> mkU ty (V3 0 0 0 :: V3 Int32) TypeV4I -> mkU ty (V4 0 0 0 0 :: V4 Int32) TypeFloat -> mkU ty (0::Float) TypeV2F -> mkU ty (V2 0 0 :: V2 Float) TypeV3F -> mkU ty (V3 0 0 0 :: V3 Float) TypeV4F -> mkU ty (V4 0 0 0 0 :: V4 Float) TypeM22F -> mkU ty (V2 z2 z2) TypeM23F -> mkU ty (V3 z2 z2 z2) TypeM24F -> mkU ty (V4 z2 z2 z2 z2) TypeM32F -> mkU ty (V2 z3 z3) TypeM33F -> mkU ty (V3 z3 z3 z3) TypeM34F -> mkU ty (V4 z3 z3 z3 z3) TypeM42F -> mkU ty (V2 z4 z4) TypeM43F -> mkU ty (V3 z4 z4 z4) TypeM44F -> mkU ty (V4 z4 z4 z4 z4) Nothing -> case t of FTexture2D -> GLUniform <$> newIORef (Texture2DName 0) FTextureCube -> GLUniform <$> newIORef (TextureCubeName 0) _ -> fail $ "initializeUniform: " ++ show t data TypeMismatch c a = TypeMismatch instance (Typeable c, Typeable a) => Show (TypeMismatch c a) where showsPrec d ty = paren '(' . mappend "TypeMismatch @" . showsPrec 11 (typeRep $ ctx ty) . mappend " @" . showsPrec 0 (typeRep ty) . paren ')' where ctx :: ty c a -> Proxy c ctx _ = Proxy paren | d<=10 = (:) | otherwise = \_ -> id instance (Typeable c, Typeable a) => Exception (TypeMismatch c a) typeMismatch :: ctx c -> ref a -> TypeMismatch c a typeMismatch _ _ = TypeMismatch -- sets value based uniforms only (does not handle textures) setUniform :: GLint -> TypeTag c -> IO (GLUniformValue c) -> IO () setUniform i ty ref = do GLUniformValue v <- ref let false = GL_FALSE case marshalUniform (glABI ty) v of Just (MarshalGLVector withU) -> withU $ \n ptr -> case glUniform ty of GLVector f -> f i n ptr Just (MarshalGLMatrix withU) -> withU $ \n isRowMajor ptr -> case glUniform ty of GLMatrix f -> f i n isRowMajor ptr Nothing -> throwIO (typeMismatch ty ref) -- attribute functions 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 -- result list: [(name string,location,gl type,component count)] 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..n-1] $! \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" 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 -- XXX: we need to extend IR.TextureDescriptor to carry component bit depth -- if we want to avoid making arbitrary decisions here 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_RGBA8I WordT RGBA -> GL_RGBA8UI 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_INTEGER WordT Red -> GL_RED_INTEGER FloatT RG -> GL_RG IntT RG -> GL_RG_INTEGER WordT RG -> GL_RG_INTEGER FloatT RGBA -> GL_RGBA IntT RGBA -> GL_RGBA_INTEGER WordT RGBA -> GL_RGBA_INTEGER 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 {- Texture and renderbuffer color formats (R): R11F_G11F_B10F R16 R16F R16I R16UI R32F R32I R32UI R8 R8I R8UI RG16 RG16F RG16I RG16UI RG32F RG32I RG32UI RG8 RG8I RG8UI RGB10_A2 RGB10_A2UI RGBA16 RGBA16F RGBA16I RGBA16UI RGBA32F RGBA32I RGBA32UI RGBA8 RGBA8I RGBA8UI SRGB8_ALPHA8 -} 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 -- float, word, int, red, rg, rgb, rgba 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 :: Num a => GLenum -> TextureDataType -> IO (a,GLenum) 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 (n-1) (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" -- TODO 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)!"