summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL/Util.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL/Util.hs')
-rw-r--r--src/LambdaCube/GL/Util.hs719
1 files changed, 719 insertions, 0 deletions
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
new file mode 100644
index 0000000..2059415
--- /dev/null
+++ b/src/LambdaCube/GL/Util.hs
@@ -0,0 +1,719 @@
1{-# LANGUAGE OverloadedStrings #-}
2module LambdaCube.GL.Util (
3 queryUniforms,
4 queryStreams,
5 mkUniformSetter,
6 setUniform,
7 setVertexAttrib,
8 compileShader,
9 printProgramLog,
10 glGetShaderiv1,
11 glGetProgramiv1,
12 Buffer(..),
13 ArrayDesc(..),
14 StreamSetter,
15 streamToInputType,
16 arrayTypeToGLType,
17 comparisonFunctionToGLType,
18 logicOperationToGLType,
19 blendEquationToGLType,
20 blendingFactorToGLType,
21 checkGL,
22 textureDataTypeToGLType,
23 textureDataTypeToGLArityType,
24 glGetIntegerv1,
25 setSampler,
26 checkFBO,
27 compileTexture,
28 primitiveToFetchPrimitive,
29 primitiveToGLType,
30 inputTypeToTextureTarget,
31 toTrie
32) where
33
34import Control.Applicative
35import Control.Exception
36import Control.Monad
37import Data.ByteString.Char8 (ByteString,pack,unpack)
38import Data.IORef
39import Data.List as L
40import Data.Trie as T
41import Foreign
42import qualified Data.ByteString.Char8 as SB
43import qualified Data.Vector as V
44import Data.Vector.Unboxed.Mutable (IOVector)
45import qualified Data.Vector.Unboxed.Mutable as MV
46import Data.Map (Map)
47import qualified Data.Map as Map
48
49import Graphics.GL.Core33
50import Linear
51import IR
52import LambdaCube.GL.Type
53
54toTrie :: Map String a -> Trie a
55toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m]
56
57setSampler :: GLint -> Int32 -> IO ()
58setSampler i v = glUniform1i i $ fromIntegral v
59
60z2 = V2 0 0 :: V2F
61z3 = V3 0 0 0 :: V3F
62z4 = V4 0 0 0 0 :: V4F
63
64-- uniform functions
65queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)
66queryUniforms po = do
67 ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH
68 let uNames = [n | (n,_,_,_) <- ul]
69 uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]
70 uLocation = [i | (_,i,_,_) <- ul]
71 return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes)
72
73b2w :: Bool -> GLuint
74b2w True = 1
75b2w False = 0
76
77mkUniformSetter :: InputType -> IO (GLUniform, InputSetter)
78mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)}
79mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)}
80mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)}
81mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)}
82mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)}
83mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)}
84mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)}
85mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)}
86mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)}
87mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)}
88mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)}
89mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)}
90mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)}
91mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)}
92mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)}
93mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)}
94mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)}
95mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)}
96mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)}
97mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)}
98mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)}
99mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)}
100mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)}
101mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)}
102mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)}
103mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)}
104
105-- sets value based uniforms only (does not handle textures)
106setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()
107setUniform i ty ref = do
108 v <- readIORef ref
109 let false = fromIntegral GL_FALSE
110 with v $ \p -> case ty of
111 Bool -> glUniform1uiv i 1 (castPtr p)
112 V2B -> glUniform2uiv i 1 (castPtr p)
113 V3B -> glUniform3uiv i 1 (castPtr p)
114 V4B -> glUniform4uiv i 1 (castPtr p)
115 Word -> glUniform1uiv i 1 (castPtr p)
116 V2U -> glUniform2uiv i 1 (castPtr p)
117 V3U -> glUniform3uiv i 1 (castPtr p)
118 V4U -> glUniform4uiv i 1 (castPtr p)
119 Int -> glUniform1iv i 1 (castPtr p)
120 V2I -> glUniform2iv i 1 (castPtr p)
121 V3I -> glUniform3iv i 1 (castPtr p)
122 V4I -> glUniform4iv i 1 (castPtr p)
123 Float -> glUniform1fv i 1 (castPtr p)
124 V2F -> glUniform2fv i 1 (castPtr p)
125 V3F -> glUniform3fv i 1 (castPtr p)
126 V4F -> glUniform4fv i 1 (castPtr p)
127 M22F -> glUniformMatrix2fv i 1 false (castPtr p)
128 M23F -> glUniformMatrix2x3fv i 1 false (castPtr p)
129 M24F -> glUniformMatrix2x4fv i 1 false (castPtr p)
130 M32F -> glUniformMatrix3x2fv i 1 false (castPtr p)
131 M33F -> glUniformMatrix3fv i 1 false (castPtr p)
132 M34F -> glUniformMatrix3x4fv i 1 false (castPtr p)
133 M42F -> glUniformMatrix4x2fv i 1 false (castPtr p)
134 M43F -> glUniformMatrix4x3fv i 1 false (castPtr p)
135 M44F -> glUniformMatrix4fv i 1 false (castPtr p)
136 FTexture2D -> return () --putStrLn $ "TODO: setUniform FTexture2D"
137 _ -> fail $ "internal error (setUniform)! - " ++ show ty
138
139-- attribute functions
140queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)
141queryStreams po = do
142 al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH
143 let aNames = [n | (n,_,_,_) <- al]
144 aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]
145 aLocation = [fromIntegral i | (_,i,_,_) <- al]
146 return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes)
147
148arrayTypeToGLType :: ArrayType -> GLenum
149arrayTypeToGLType a = case a of
150 ArrWord8 -> GL_UNSIGNED_BYTE
151 ArrWord16 -> GL_UNSIGNED_SHORT
152 ArrWord32 -> GL_UNSIGNED_INT
153 ArrInt8 -> GL_BYTE
154 ArrInt16 -> GL_SHORT
155 ArrInt32 -> GL_INT
156 ArrFloat -> GL_FLOAT
157 ArrHalf -> GL_HALF_FLOAT
158
159setVertexAttrib :: GLuint -> Stream Buffer -> IO ()
160setVertexAttrib i val = case val of
161 ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p
162 ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p
163 ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p
164 ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p
165 ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p
166 ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p
167 ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p
168 ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p
169 ConstFloat v -> setAFloat i v
170 ConstV2F v -> setAV2F i v
171 ConstV3F v -> setAV3F i v
172 ConstV4F v -> setAV4F i v
173 ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y
174 ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z
175 ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w
176 ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y
177 ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z
178 ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w
179 ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y
180 ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z
181 ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w
182 _ -> fail "internal error (setVertexAttrib)!"
183
184setAFloat :: GLuint -> Float -> IO ()
185setAV2F :: GLuint -> V2F -> IO ()
186setAV3F :: GLuint -> V3F -> IO ()
187setAV4F :: GLuint -> V4F -> IO ()
188setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p
189setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p
190setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p
191setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p
192
193-- result list: [(name string,location,gl type,component count)]
194getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())
195 -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)]
196getNameTypeSize o f g enum enumLen = do
197 nameLen <- glGetProgramiv1 enumLen o
198 allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do
199 n <- glGetProgramiv1 enum o
200 forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>
201 (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep
202
203fromGLType :: (GLenum,GLint) -> InputType
204fromGLType (t,1)
205 | t == GL_BOOL = Bool
206 | t == GL_BOOL_VEC2 = V2B
207 | t == GL_BOOL_VEC3 = V3B
208 | t == GL_BOOL_VEC4 = V4B
209 | t == GL_UNSIGNED_INT = Word
210 | t == GL_UNSIGNED_INT_VEC2 = V2U
211 | t == GL_UNSIGNED_INT_VEC3 = V3U
212 | t == GL_UNSIGNED_INT_VEC4 = V4U
213 | t == GL_INT = Int
214 | t == GL_INT_VEC2 = V2I
215 | t == GL_INT_VEC3 = V3I
216 | t == GL_INT_VEC4 = V4I
217 | t == GL_FLOAT = Float
218 | t == GL_FLOAT_VEC2 = V2F
219 | t == GL_FLOAT_VEC3 = V3F
220 | t == GL_FLOAT_VEC4 = V4F
221 | t == GL_FLOAT_MAT2 = M22F
222 | t == GL_FLOAT_MAT2x3 = M23F
223 | t == GL_FLOAT_MAT2x4 = M24F
224 | t == GL_FLOAT_MAT3x2 = M32F
225 | t == GL_FLOAT_MAT3 = M33F
226 | t == GL_FLOAT_MAT3x4 = M34F
227 | t == GL_FLOAT_MAT4x2 = M42F
228 | t == GL_FLOAT_MAT4x3 = M43F
229 | t == GL_FLOAT_MAT4 = M44F
230 | t == GL_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray
231 | t == GL_SAMPLER_1D_SHADOW = STexture1D
232 | t == GL_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray
233 | t == GL_SAMPLER_2D_RECT_SHADOW = STexture2DRect
234 | t == GL_SAMPLER_2D_SHADOW = STexture2D
235 | t == GL_SAMPLER_CUBE_SHADOW = STextureCube
236 | t == GL_INT_SAMPLER_1D = ITexture1D
237 | t == GL_INT_SAMPLER_1D_ARRAY = ITexture1DArray
238 | t == GL_INT_SAMPLER_2D = ITexture2D
239 | t == GL_INT_SAMPLER_2D_ARRAY = ITexture2DArray
240 | t == GL_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS
241 | t == GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray
242 | t == GL_INT_SAMPLER_2D_RECT = ITexture2DRect
243 | t == GL_INT_SAMPLER_3D = ITexture3D
244 | t == GL_INT_SAMPLER_BUFFER = ITextureBuffer
245 | t == GL_INT_SAMPLER_CUBE = ITextureCube
246 | t == GL_SAMPLER_1D = FTexture1D
247 | t == GL_SAMPLER_1D_ARRAY = FTexture1DArray
248 | t == GL_SAMPLER_2D = FTexture2D
249 | t == GL_SAMPLER_2D_ARRAY = FTexture2DArray
250 | t == GL_SAMPLER_2D_MULTISAMPLE = FTexture2DMS
251 | t == GL_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray
252 | t == GL_SAMPLER_2D_RECT = FTexture2DRect
253 | t == GL_SAMPLER_3D = FTexture3D
254 | t == GL_SAMPLER_BUFFER = FTextureBuffer
255 | t == GL_SAMPLER_CUBE = FTextureCube
256 | t == GL_UNSIGNED_INT_SAMPLER_1D = UTexture1D
257 | t == GL_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray
258 | t == GL_UNSIGNED_INT_SAMPLER_2D = UTexture2D
259 | t == GL_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray
260 | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS
261 | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray
262 | t == GL_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect
263 | t == GL_UNSIGNED_INT_SAMPLER_3D = UTexture3D
264 | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer
265 | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube
266 | otherwise = error "Failed fromGLType"
267fromGLUniformType _ = error "Failed fromGLType"
268
269printShaderLog :: GLuint -> IO ()
270printShaderLog o = do
271 i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o
272 when (i > 0) $
273 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
274 glGetShaderInfoLog o (fromIntegral i) sizePtr ps
275 size <- peek sizePtr
276 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
277 SB.putStrLn log
278
279glGetShaderiv1 :: GLenum -> GLuint -> IO GLint
280glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi
281
282glGetProgramiv1 :: GLenum -> GLuint -> IO GLint
283glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi
284
285printProgramLog :: GLuint -> IO ()
286printProgramLog o = do
287 i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o
288 when (i > 0) $
289 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
290 glGetProgramInfoLog o (fromIntegral i) sizePtr ps
291 size <- peek sizePtr
292 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
293 SB.putStrLn log
294
295compileShader :: GLuint -> [ByteString] -> IO ()
296compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do
297 glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
298 glCompileShader o
299 printShaderLog o
300 status <- glGetShaderiv1 GL_COMPILE_STATUS o
301 when (status /= fromIntegral GL_TRUE) $ fail "compileShader failed!"
302
303checkGL :: IO ByteString
304checkGL = do
305 let f e | e == GL_INVALID_ENUM = "INVALID_ENUM"
306 | e == GL_INVALID_VALUE = "INVALID_VALUE"
307 | e == GL_INVALID_OPERATION = "INVALID_OPERATION"
308 | e == GL_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"
309 | e == GL_OUT_OF_MEMORY = "OUT_OF_MEMORY"
310 | e == GL_NO_ERROR = "OK"
311 | otherwise = "Unknown error"
312 e <- glGetError
313 return $ f e
314
315streamToInputType :: Stream Buffer -> InputType
316streamToInputType s = case s of
317 ConstWord _ -> Word
318 ConstV2U _ -> V2U
319 ConstV3U _ -> V3U
320 ConstV4U _ -> V4U
321 ConstInt _ -> Int
322 ConstV2I _ -> V2I
323 ConstV3I _ -> V3I
324 ConstV4I _ -> V4I
325 ConstFloat _ -> Float
326 ConstV2F _ -> V2F
327 ConstV3F _ -> V3F
328 ConstV4F _ -> V4F
329 ConstM22F _ -> M22F
330 ConstM23F _ -> M23F
331 ConstM24F _ -> M24F
332 ConstM32F _ -> M32F
333 ConstM33F _ -> M33F
334 ConstM34F _ -> M34F
335 ConstM42F _ -> M42F
336 ConstM43F _ -> M43F
337 ConstM44F _ -> M44F
338 Stream t (Buffer a _) i _ _
339 | 0 <= i && i < V.length a &&
340 if elem t integralTypes then elem at integralArrTypes else True
341 -> fromStreamType t
342 | otherwise -> throw $ userError "streamToInputType failed"
343 where
344 at = arrType $! (a V.! i)
345 integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I]
346 integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]
347
348comparisonFunctionToGLType :: ComparisonFunction -> GLenum
349comparisonFunctionToGLType a = case a of
350 Always -> GL_ALWAYS
351 Equal -> GL_EQUAL
352 Gequal -> GL_GEQUAL
353 Greater -> GL_GREATER
354 Lequal -> GL_LEQUAL
355 Less -> GL_LESS
356 Never -> GL_NEVER
357 Notequal -> GL_NOTEQUAL
358
359logicOperationToGLType :: LogicOperation -> GLenum
360logicOperationToGLType a = case a of
361 And -> GL_AND
362 AndInverted -> GL_AND_INVERTED
363 AndReverse -> GL_AND_REVERSE
364 Clear -> GL_CLEAR
365 Copy -> GL_COPY
366 CopyInverted -> GL_COPY_INVERTED
367 Equiv -> GL_EQUIV
368 Invert -> GL_INVERT
369 Nand -> GL_NAND
370 Noop -> GL_NOOP
371 Nor -> GL_NOR
372 Or -> GL_OR
373 OrInverted -> GL_OR_INVERTED
374 OrReverse -> GL_OR_REVERSE
375 Set -> GL_SET
376 Xor -> GL_XOR
377
378blendEquationToGLType :: BlendEquation -> GLenum
379blendEquationToGLType a = case a of
380 FuncAdd -> GL_FUNC_ADD
381 FuncReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT
382 FuncSubtract -> GL_FUNC_SUBTRACT
383 Max -> GL_MAX
384 Min -> GL_MIN
385
386blendingFactorToGLType :: BlendingFactor -> GLenum
387blendingFactorToGLType a = case a of
388 ConstantAlpha -> GL_CONSTANT_ALPHA
389 ConstantColor -> GL_CONSTANT_COLOR
390 DstAlpha -> GL_DST_ALPHA
391 DstColor -> GL_DST_COLOR
392 One -> GL_ONE
393 OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA
394 OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR
395 OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA
396 OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR
397 OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA
398 OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR
399 SrcAlpha -> GL_SRC_ALPHA
400 SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE
401 SrcColor -> GL_SRC_COLOR
402 Zero -> GL_ZERO
403
404textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum
405textureDataTypeToGLType Color a = case a of
406 FloatT Red -> GL_R32F
407 IntT Red -> GL_R32I
408 WordT Red -> GL_R32UI
409 FloatT RG -> GL_RG32F
410 IntT RG -> GL_RG32I
411 WordT RG -> GL_RG32UI
412 FloatT RGBA -> GL_RGBA32F
413 IntT RGBA -> GL_RGBA32I
414 WordT RGBA -> GL_RGBA32UI
415 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
416textureDataTypeToGLType Depth a = case a of
417 FloatT Red -> GL_DEPTH_COMPONENT32F
418 WordT Red -> GL_DEPTH_COMPONENT32
419 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
420textureDataTypeToGLType Stencil a = case a of
421 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
422
423textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum
424textureDataTypeToGLArityType Color a = case a of
425 FloatT Red -> GL_RED
426 IntT Red -> GL_RED
427 WordT Red -> GL_RED
428 FloatT RG -> GL_RG
429 IntT RG -> GL_RG
430 WordT RG -> GL_RG
431 FloatT RGBA -> GL_RGBA
432 IntT RGBA -> GL_RGBA
433 WordT RGBA -> GL_RGBA
434 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
435textureDataTypeToGLArityType Depth a = case a of
436 FloatT Red -> GL_DEPTH_COMPONENT
437 WordT Red -> GL_DEPTH_COMPONENT
438 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
439textureDataTypeToGLArityType Stencil a = case a of
440 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
441{-
442Texture and renderbuffer color formats (R):
443 R11F_G11F_B10F
444 R16
445 R16F
446 R16I
447 R16UI
448 R32F
449 R32I
450 R32UI
451 R8
452 R8I
453 R8UI
454 RG16
455 RG16F
456 RG16I
457 RG16UI
458 RG32F
459 RG32I
460 RG32UI
461 RG8
462 RG8I
463 RG8UI
464 RGB10_A2
465 RGB10_A2UI
466 RGBA16
467 RGBA16F
468 RGBA16I
469 RGBA16UI
470 RGBA32F
471 RGBA32I
472 RGBA32UI
473 RGBA8
474 RGBA8I
475 RGBA8UI
476 SRGB8_ALPHA8
477-}
478
479glGetIntegerv1 :: GLenum -> IO GLint
480glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi
481
482checkFBO :: IO ByteString
483checkFBO = do
484 let f e | e == GL_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"
485 | e == GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"
486 | e == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"
487 | e == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"
488 | e == GL_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"
489 | e == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"
490 | e == GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"
491 | e == GL_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"
492 | otherwise = "Unknown error"
493 e <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER
494 return $ f e
495
496filterToGLType :: Filter -> GLenum
497filterToGLType a = case a of
498 Nearest -> GL_NEAREST
499 Linear -> GL_LINEAR
500 NearestMipmapNearest -> GL_NEAREST_MIPMAP_NEAREST
501 NearestMipmapLinear -> GL_NEAREST_MIPMAP_LINEAR
502 LinearMipmapNearest -> GL_LINEAR_MIPMAP_NEAREST
503 LinearMipmapLinear -> GL_LINEAR_MIPMAP_LINEAR
504
505edgeModeToGLType :: EdgeMode -> GLenum
506edgeModeToGLType a = case a of
507 Repeat -> GL_REPEAT
508 MirroredRepeat -> GL_MIRRORED_REPEAT
509 ClampToEdge -> GL_CLAMP_TO_EDGE
510 ClampToBorder -> GL_CLAMP_TO_BORDER
511
512setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()
513setTextureSamplerParameters t s = do
514 glTexParameteri t GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
515 case samplerWrapT s of
516 Nothing -> return ()
517 Just a -> glTexParameteri t GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
518 case samplerWrapR s of
519 Nothing -> return ()
520 Just a -> glTexParameteri t GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
521 glTexParameteri t GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
522 glTexParameteri t GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
523
524 let setBColorV4F a = with a $ \p -> glTexParameterfv t GL_TEXTURE_BORDER_COLOR $ castPtr p
525 setBColorV4I a = with a $ \p -> glTexParameterIiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
526 setBColorV4U a = with a $ \p -> glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
527 case samplerBorderColor s of
528 -- float, word, int, red, rg, rgb, rgba
529 VFloat a -> setBColorV4F $ V4 a 0 0 0
530 VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0
531 VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0
532 VV4F a -> setBColorV4F a
533
534 VInt a -> setBColorV4I $ V4 a 0 0 0
535 VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0
536 VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0
537 VV4I a -> setBColorV4I a
538
539 VWord a -> setBColorV4U $ V4 a 0 0 0
540 VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0
541 VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0
542 VV4U a -> setBColorV4U a
543 _ -> fail "internal error (setTextureSamplerParameters)!"
544
545 case samplerMinLod s of
546 Nothing -> return ()
547 Just a -> glTexParameterf t GL_TEXTURE_MIN_LOD $ realToFrac a
548 case samplerMaxLod s of
549 Nothing -> return ()
550 Just a -> glTexParameterf t GL_TEXTURE_MAX_LOD $ realToFrac a
551 glTexParameterf t GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
552 case samplerCompareFunc s of
553 Nothing -> glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE
554 Just a -> do
555 glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE
556 glTexParameteri t GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
557
558compileTexture :: TextureDescriptor -> IO GLTexture
559compileTexture txDescriptor = do
560 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
561 let TextureDescriptor
562 { textureType = txType
563 , textureSize = txSize
564 , textureSemantic = txSemantic
565 , textureSampler = txSampler
566 , textureBaseLevel = txBaseLevel
567 , textureMaxLevel = txMaxLevel
568 } = txDescriptor
569
570 txSetup txTarget dTy = do
571 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy
572 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy
573 glBindTexture txTarget to
574 glTexParameteri txTarget GL_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel
575 glTexParameteri txTarget GL_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel
576 setTextureSamplerParameters txTarget txSampler
577 return (internalFormat,dataFormat)
578
579 mipSize 0 x = [x]
580 mipSize n x = x : mipSize (n-1) (x `div` 2)
581 mipS = mipSize (txMaxLevel - txBaseLevel)
582 levels = [txBaseLevel..txMaxLevel]
583 target <- case txType of
584 Texture1D dTy layerCnt -> do
585 let VWord txW = txSize
586 txTarget = if layerCnt > 1 then GL_TEXTURE_1D_ARRAY else GL_TEXTURE_1D
587 (internalFormat,dataFormat) <- txSetup txTarget dTy
588 forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of
589 True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
590 False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
591 return txTarget
592 Texture2D dTy layerCnt -> do
593 let VV2U (V2 txW txH) = txSize
594 txTarget = if layerCnt > 1 then GL_TEXTURE_2D_ARRAY else GL_TEXTURE_2D
595 (internalFormat,dataFormat) <- txSetup txTarget dTy
596 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of
597 True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
598 False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
599 return txTarget
600 Texture3D dTy -> do
601 let VV3U (V3 txW txH txD) = txSize
602 txTarget = GL_TEXTURE_3D
603 (internalFormat,dataFormat) <- txSetup txTarget dTy
604 forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) ->
605 glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
606 return txTarget
607 TextureCube dTy -> do
608 let VV2U (V2 txW txH) = txSize
609 txTarget = GL_TEXTURE_CUBE_MAP
610 targets =
611 [ GL_TEXTURE_CUBE_MAP_POSITIVE_X
612 , GL_TEXTURE_CUBE_MAP_NEGATIVE_X
613 , GL_TEXTURE_CUBE_MAP_POSITIVE_Y
614 , GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
615 , GL_TEXTURE_CUBE_MAP_POSITIVE_Z
616 , GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
617 ]
618 (internalFormat,dataFormat) <- txSetup txTarget dTy
619 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
620 forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
621 return txTarget
622 TextureRect dTy -> do
623 let VV2U (V2 txW txH) = txSize
624 txTarget = GL_TEXTURE_RECTANGLE
625 (internalFormat,dataFormat) <- txSetup txTarget dTy
626 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
627 glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
628 return txTarget
629 Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do
630 let VV2U (V2 w h) = txSize
631 txTarget = if layerCnt > 1 then GL_TEXTURE_2D_MULTISAMPLE_ARRAY else GL_TEXTURE_2D_MULTISAMPLE
632 isFixed = fromIntegral $ if isFixedLocations then GL_TRUE else GL_FALSE
633 (internalFormat,dataFormat) <- txSetup txTarget dTy
634 case layerCnt > 1 of
635 True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed
636 False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed
637 return txTarget
638 TextureBuffer dTy -> do
639 fail "internal error: buffer texture is not supported yet"
640 -- TODO
641 let VV2U (V2 w h) = txSize
642 txTarget = GL_TEXTURE_2D
643 (internalFormat,dataFormat) <- txSetup txTarget dTy
644 glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
645 return txTarget
646 return $ GLTexture
647 { glTextureObject = to
648 , glTextureTarget = target
649 }
650
651primitiveToFetchPrimitive :: Primitive -> FetchPrimitive
652primitiveToFetchPrimitive prim = case prim of
653 TriangleStrip -> Triangles
654 TriangleList -> Triangles
655 TriangleFan -> Triangles
656 LineStrip -> Lines
657 LineList -> Lines
658 PointList -> Points
659 TriangleStripAdjacency -> TrianglesAdjacency
660 TriangleListAdjacency -> TrianglesAdjacency
661 LineStripAdjacency -> LinesAdjacency
662 LineListAdjacency -> LinesAdjacency
663
664primitiveToGLType :: Primitive -> GLenum
665primitiveToGLType p = case p of
666 TriangleStrip -> GL_TRIANGLE_STRIP
667 TriangleList -> GL_TRIANGLES
668 TriangleFan -> GL_TRIANGLE_FAN
669 LineStrip -> GL_LINE_STRIP
670 LineList -> GL_LINES
671 PointList -> GL_POINTS
672 TriangleStripAdjacency -> GL_TRIANGLE_STRIP_ADJACENCY
673 TriangleListAdjacency -> GL_TRIANGLES_ADJACENCY
674 LineStripAdjacency -> GL_LINE_STRIP_ADJACENCY
675 LineListAdjacency -> GL_LINES_ADJACENCY
676
677inputTypeToTextureTarget :: InputType -> GLenum
678inputTypeToTextureTarget ty = case ty of
679 STexture1D -> GL_TEXTURE_1D
680 STexture2D -> GL_TEXTURE_2D
681 STextureCube -> GL_TEXTURE_CUBE_MAP
682 STexture1DArray -> GL_TEXTURE_1D_ARRAY
683 STexture2DArray -> GL_TEXTURE_2D_ARRAY
684 STexture2DRect -> GL_TEXTURE_RECTANGLE
685
686 FTexture1D -> GL_TEXTURE_1D
687 FTexture2D -> GL_TEXTURE_2D
688 FTexture3D -> GL_TEXTURE_3D
689 FTextureCube -> GL_TEXTURE_CUBE_MAP
690 FTexture1DArray -> GL_TEXTURE_1D_ARRAY
691 FTexture2DArray -> GL_TEXTURE_2D_ARRAY
692 FTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
693 FTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
694 FTextureBuffer -> GL_TEXTURE_BUFFER
695 FTexture2DRect -> GL_TEXTURE_RECTANGLE
696
697 ITexture1D -> GL_TEXTURE_1D
698 ITexture2D -> GL_TEXTURE_2D
699 ITexture3D -> GL_TEXTURE_3D
700 ITextureCube -> GL_TEXTURE_CUBE_MAP
701 ITexture1DArray -> GL_TEXTURE_1D_ARRAY
702 ITexture2DArray -> GL_TEXTURE_2D_ARRAY
703 ITexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
704 ITexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
705 ITextureBuffer -> GL_TEXTURE_BUFFER
706 ITexture2DRect -> GL_TEXTURE_RECTANGLE
707
708 UTexture1D -> GL_TEXTURE_1D
709 UTexture2D -> GL_TEXTURE_2D
710 UTexture3D -> GL_TEXTURE_3D
711 UTextureCube -> GL_TEXTURE_CUBE_MAP
712 UTexture1DArray -> GL_TEXTURE_1D_ARRAY
713 UTexture2DArray -> GL_TEXTURE_2D_ARRAY
714 UTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
715 UTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
716 UTextureBuffer -> GL_TEXTURE_BUFFER
717 UTexture2DRect -> GL_TEXTURE_RECTANGLE
718
719 _ -> error "internal error (inputTypeToTextureTarget)!"
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-01 00:24:57 +0000