summaryrefslogtreecommitdiff
path: root/Backend/GL/Util.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Backend/GL/Util.hs')
-rw-r--r--Backend/GL/Util.hs717
1 files changed, 717 insertions, 0 deletions
diff --git a/Backend/GL/Util.hs b/Backend/GL/Util.hs
new file mode 100644
index 0000000..7a36290
--- /dev/null
+++ b/Backend/GL/Util.hs
@@ -0,0 +1,717 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Backend.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.Rendering.OpenGL.Raw.Core33
50import IR
51import Backend.GL.Type
52
53toTrie :: Map String a -> Trie a
54toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m]
55
56setSampler :: GLint -> Int32 -> IO ()
57setSampler i v = glUniform1i i $ fromIntegral v
58
59z2 = V2 0 0 :: V2F
60z3 = V3 0 0 0 :: V3F
61z4 = V4 0 0 0 0 :: V4F
62
63-- uniform functions
64queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)
65queryUniforms po = do
66 ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation gl_ACTIVE_UNIFORMS gl_ACTIVE_UNIFORM_MAX_LENGTH
67 let uNames = [n | (n,_,_,_) <- ul]
68 uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]
69 uLocation = [i | (_,i,_,_) <- ul]
70 return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes)
71
72b2w :: Bool -> GLuint
73b2w True = 1
74b2w False = 0
75
76mkUniformSetter :: InputType -> IO (GLUniform, InputSetter)
77mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)}
78mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)}
79mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)}
80mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)}
81mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)}
82mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)}
83mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)}
84mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)}
85mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)}
86mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)}
87mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)}
88mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)}
89mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)}
90mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)}
91mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)}
92mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)}
93mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)}
94mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)}
95mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)}
96mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)}
97mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)}
98mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)}
99mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)}
100mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)}
101mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)}
102mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)}
103
104-- sets value based uniforms only (does not handle textures)
105setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()
106setUniform i ty ref = do
107 v <- readIORef ref
108 let false = fromIntegral gl_FALSE
109 with v $ \p -> case ty of
110 Bool -> glUniform1uiv i 1 (castPtr p)
111 V2B -> glUniform2uiv i 1 (castPtr p)
112 V3B -> glUniform3uiv i 1 (castPtr p)
113 V4B -> glUniform4uiv i 1 (castPtr p)
114 Word -> glUniform1uiv i 1 (castPtr p)
115 V2U -> glUniform2uiv i 1 (castPtr p)
116 V3U -> glUniform3uiv i 1 (castPtr p)
117 V4U -> glUniform4uiv i 1 (castPtr p)
118 Int -> glUniform1iv i 1 (castPtr p)
119 V2I -> glUniform2iv i 1 (castPtr p)
120 V3I -> glUniform3iv i 1 (castPtr p)
121 V4I -> glUniform4iv i 1 (castPtr p)
122 Float -> glUniform1fv i 1 (castPtr p)
123 V2F -> glUniform2fv i 1 (castPtr p)
124 V3F -> glUniform3fv i 1 (castPtr p)
125 V4F -> glUniform4fv i 1 (castPtr p)
126 M22F -> glUniformMatrix2fv i 1 false (castPtr p)
127 M23F -> glUniformMatrix2x3fv i 1 false (castPtr p)
128 M24F -> glUniformMatrix2x4fv i 1 false (castPtr p)
129 M32F -> glUniformMatrix3x2fv i 1 false (castPtr p)
130 M33F -> glUniformMatrix3fv i 1 false (castPtr p)
131 M34F -> glUniformMatrix3x4fv i 1 false (castPtr p)
132 M42F -> glUniformMatrix4x2fv i 1 false (castPtr p)
133 M43F -> glUniformMatrix4x3fv i 1 false (castPtr p)
134 M44F -> glUniformMatrix4fv i 1 false (castPtr p)
135 _ -> fail "internal error (setUniform)!"
136
137-- attribute functions
138queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)
139queryStreams po = do
140 al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation gl_ACTIVE_ATTRIBUTES gl_ACTIVE_ATTRIBUTE_MAX_LENGTH
141 let aNames = [n | (n,_,_,_) <- al]
142 aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]
143 aLocation = [fromIntegral i | (_,i,_,_) <- al]
144 return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes)
145
146arrayTypeToGLType :: ArrayType -> GLenum
147arrayTypeToGLType a = case a of
148 ArrWord8 -> gl_UNSIGNED_BYTE
149 ArrWord16 -> gl_UNSIGNED_SHORT
150 ArrWord32 -> gl_UNSIGNED_INT
151 ArrInt8 -> gl_BYTE
152 ArrInt16 -> gl_SHORT
153 ArrInt32 -> gl_INT
154 ArrFloat -> gl_FLOAT
155 ArrHalf -> gl_HALF_FLOAT
156
157setVertexAttrib :: GLuint -> Stream Buffer -> IO ()
158setVertexAttrib i val = case val of
159 ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p
160 ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p
161 ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p
162 ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p
163 ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p
164 ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p
165 ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p
166 ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p
167 ConstFloat v -> setAFloat i v
168 ConstV2F v -> setAV2F i v
169 ConstV3F v -> setAV3F i v
170 ConstV4F v -> setAV4F i v
171 ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y
172 ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z
173 ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w
174 ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y
175 ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z
176 ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w
177 ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y
178 ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z
179 ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w
180 _ -> fail "internal error (setVertexAttrib)!"
181
182setAFloat :: GLuint -> Float -> IO ()
183setAV2F :: GLuint -> V2F -> IO ()
184setAV3F :: GLuint -> V3F -> IO ()
185setAV4F :: GLuint -> V4F -> IO ()
186setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p
187setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p
188setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p
189setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p
190
191-- result list: [(name string,location,gl type,component count)]
192getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())
193 -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)]
194getNameTypeSize o f g enum enumLen = do
195 nameLen <- glGetProgramiv1 enumLen o
196 allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do
197 n <- glGetProgramiv1 enum o
198 forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>
199 (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep
200
201fromGLType :: (GLenum,GLint) -> InputType
202fromGLType (t,1)
203 | t == gl_BOOL = Bool
204 | t == gl_BOOL_VEC2 = V2B
205 | t == gl_BOOL_VEC3 = V3B
206 | t == gl_BOOL_VEC4 = V4B
207 | t == gl_UNSIGNED_INT = Word
208 | t == gl_UNSIGNED_INT_VEC2 = V2U
209 | t == gl_UNSIGNED_INT_VEC3 = V3U
210 | t == gl_UNSIGNED_INT_VEC4 = V4U
211 | t == gl_INT = Int
212 | t == gl_INT_VEC2 = V2I
213 | t == gl_INT_VEC3 = V3I
214 | t == gl_INT_VEC4 = V4I
215 | t == gl_FLOAT = Float
216 | t == gl_FLOAT_VEC2 = V2F
217 | t == gl_FLOAT_VEC3 = V3F
218 | t == gl_FLOAT_VEC4 = V4F
219 | t == gl_FLOAT_MAT2 = M22F
220 | t == gl_FLOAT_MAT2x3 = M23F
221 | t == gl_FLOAT_MAT2x4 = M24F
222 | t == gl_FLOAT_MAT3x2 = M32F
223 | t == gl_FLOAT_MAT3 = M33F
224 | t == gl_FLOAT_MAT3x4 = M34F
225 | t == gl_FLOAT_MAT4x2 = M42F
226 | t == gl_FLOAT_MAT4x3 = M43F
227 | t == gl_FLOAT_MAT4 = M44F
228 | t == gl_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray
229 | t == gl_SAMPLER_1D_SHADOW = STexture1D
230 | t == gl_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray
231 | t == gl_SAMPLER_2D_RECT_SHADOW = STexture2DRect
232 | t == gl_SAMPLER_2D_SHADOW = STexture2D
233 | t == gl_SAMPLER_CUBE_SHADOW = STextureCube
234 | t == gl_INT_SAMPLER_1D = ITexture1D
235 | t == gl_INT_SAMPLER_1D_ARRAY = ITexture1DArray
236 | t == gl_INT_SAMPLER_2D = ITexture2D
237 | t == gl_INT_SAMPLER_2D_ARRAY = ITexture2DArray
238 | t == gl_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS
239 | t == gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray
240 | t == gl_INT_SAMPLER_2D_RECT = ITexture2DRect
241 | t == gl_INT_SAMPLER_3D = ITexture3D
242 | t == gl_INT_SAMPLER_BUFFER = ITextureBuffer
243 | t == gl_INT_SAMPLER_CUBE = ITextureCube
244 | t == gl_SAMPLER_1D = FTexture1D
245 | t == gl_SAMPLER_1D_ARRAY = FTexture1DArray
246 | t == gl_SAMPLER_2D = FTexture2D
247 | t == gl_SAMPLER_2D_ARRAY = FTexture2DArray
248 | t == gl_SAMPLER_2D_MULTISAMPLE = FTexture2DMS
249 | t == gl_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray
250 | t == gl_SAMPLER_2D_RECT = FTexture2DRect
251 | t == gl_SAMPLER_3D = FTexture3D
252 | t == gl_SAMPLER_BUFFER = FTextureBuffer
253 | t == gl_SAMPLER_CUBE = FTextureCube
254 | t == gl_UNSIGNED_INT_SAMPLER_1D = UTexture1D
255 | t == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray
256 | t == gl_UNSIGNED_INT_SAMPLER_2D = UTexture2D
257 | t == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray
258 | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS
259 | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray
260 | t == gl_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect
261 | t == gl_UNSIGNED_INT_SAMPLER_3D = UTexture3D
262 | t == gl_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer
263 | t == gl_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube
264 | otherwise = error "Failed fromGLType"
265fromGLUniformType _ = error "Failed fromGLType"
266
267printShaderLog :: GLuint -> IO ()
268printShaderLog o = do
269 i <- glGetShaderiv1 gl_INFO_LOG_LENGTH o
270 when (i > 0) $
271 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
272 glGetShaderInfoLog o (fromIntegral i) sizePtr ps
273 size <- peek sizePtr
274 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
275 SB.putStrLn log
276
277glGetShaderiv1 :: GLenum -> GLuint -> IO GLint
278glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi
279
280glGetProgramiv1 :: GLenum -> GLuint -> IO GLint
281glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi
282
283printProgramLog :: GLuint -> IO ()
284printProgramLog o = do
285 i <- glGetProgramiv1 gl_INFO_LOG_LENGTH o
286 when (i > 0) $
287 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
288 glGetProgramInfoLog o (fromIntegral i) sizePtr ps
289 size <- peek sizePtr
290 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
291 SB.putStrLn log
292
293compileShader :: GLuint -> [ByteString] -> IO ()
294compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do
295 glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
296 glCompileShader o
297 printShaderLog o
298 status <- glGetShaderiv1 gl_COMPILE_STATUS o
299 when (status /= fromIntegral gl_TRUE) $ fail "compileShader failed!"
300
301checkGL :: IO ByteString
302checkGL = do
303 let f e | e == gl_INVALID_ENUM = "INVALID_ENUM"
304 | e == gl_INVALID_VALUE = "INVALID_VALUE"
305 | e == gl_INVALID_OPERATION = "INVALID_OPERATION"
306 | e == gl_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"
307 | e == gl_OUT_OF_MEMORY = "OUT_OF_MEMORY"
308 | e == gl_NO_ERROR = "OK"
309 | otherwise = "Unknown error"
310 e <- glGetError
311 return $ f e
312
313streamToInputType :: Stream Buffer -> InputType
314streamToInputType s = case s of
315 ConstWord _ -> Word
316 ConstV2U _ -> V2U
317 ConstV3U _ -> V3U
318 ConstV4U _ -> V4U
319 ConstInt _ -> Int
320 ConstV2I _ -> V2I
321 ConstV3I _ -> V3I
322 ConstV4I _ -> V4I
323 ConstFloat _ -> Float
324 ConstV2F _ -> V2F
325 ConstV3F _ -> V3F
326 ConstV4F _ -> V4F
327 ConstM22F _ -> M22F
328 ConstM23F _ -> M23F
329 ConstM24F _ -> M24F
330 ConstM32F _ -> M32F
331 ConstM33F _ -> M33F
332 ConstM34F _ -> M34F
333 ConstM42F _ -> M42F
334 ConstM43F _ -> M43F
335 ConstM44F _ -> M44F
336 Stream t (Buffer a _) i _ _
337 | 0 <= i && i < V.length a &&
338 if elem t integralTypes then elem at integralArrTypes else True
339 -> fromStreamType t
340 | otherwise -> throw $ userError "streamToInputType failed"
341 where
342 at = arrType $! (a V.! i)
343 integralTypes = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I]
344 integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]
345
346comparisonFunctionToGLType :: ComparisonFunction -> GLenum
347comparisonFunctionToGLType a = case a of
348 Always -> gl_ALWAYS
349 Equal -> gl_EQUAL
350 Gequal -> gl_GEQUAL
351 Greater -> gl_GREATER
352 Lequal -> gl_LEQUAL
353 Less -> gl_LESS
354 Never -> gl_NEVER
355 Notequal -> gl_NOTEQUAL
356
357logicOperationToGLType :: LogicOperation -> GLenum
358logicOperationToGLType a = case a of
359 And -> gl_AND
360 AndInverted -> gl_AND_INVERTED
361 AndReverse -> gl_AND_REVERSE
362 Clear -> gl_CLEAR
363 Copy -> gl_COPY
364 CopyInverted -> gl_COPY_INVERTED
365 Equiv -> gl_EQUIV
366 Invert -> gl_INVERT
367 Nand -> gl_NAND
368 Noop -> gl_NOOP
369 Nor -> gl_NOR
370 Or -> gl_OR
371 OrInverted -> gl_OR_INVERTED
372 OrReverse -> gl_OR_REVERSE
373 Set -> gl_SET
374 Xor -> gl_XOR
375
376blendEquationToGLType :: BlendEquation -> GLenum
377blendEquationToGLType a = case a of
378 FuncAdd -> gl_FUNC_ADD
379 FuncReverseSubtract -> gl_FUNC_REVERSE_SUBTRACT
380 FuncSubtract -> gl_FUNC_SUBTRACT
381 Max -> gl_MAX
382 Min -> gl_MIN
383
384blendingFactorToGLType :: BlendingFactor -> GLenum
385blendingFactorToGLType a = case a of
386 ConstantAlpha -> gl_CONSTANT_ALPHA
387 ConstantColor -> gl_CONSTANT_COLOR
388 DstAlpha -> gl_DST_ALPHA
389 DstColor -> gl_DST_COLOR
390 One -> gl_ONE
391 OneMinusConstantAlpha -> gl_ONE_MINUS_CONSTANT_ALPHA
392 OneMinusConstantColor -> gl_ONE_MINUS_CONSTANT_COLOR
393 OneMinusDstAlpha -> gl_ONE_MINUS_DST_ALPHA
394 OneMinusDstColor -> gl_ONE_MINUS_DST_COLOR
395 OneMinusSrcAlpha -> gl_ONE_MINUS_SRC_ALPHA
396 OneMinusSrcColor -> gl_ONE_MINUS_SRC_COLOR
397 SrcAlpha -> gl_SRC_ALPHA
398 SrcAlphaSaturate -> gl_SRC_ALPHA_SATURATE
399 SrcColor -> gl_SRC_COLOR
400 Zero -> gl_ZERO
401
402textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum
403textureDataTypeToGLType Color a = case a of
404 FloatT Red -> gl_R32F
405 IntT Red -> gl_R32I
406 WordT Red -> gl_R32UI
407 FloatT RG -> gl_RG32F
408 IntT RG -> gl_RG32I
409 WordT RG -> gl_RG32UI
410 FloatT RGBA -> gl_RGBA32F
411 IntT RGBA -> gl_RGBA32I
412 WordT RGBA -> gl_RGBA32UI
413 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
414textureDataTypeToGLType Depth a = case a of
415 FloatT Red -> gl_DEPTH_COMPONENT32F
416 WordT Red -> gl_DEPTH_COMPONENT32
417 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
418textureDataTypeToGLType Stencil a = case a of
419 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
420
421textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum
422textureDataTypeToGLArityType Color a = case a of
423 FloatT Red -> gl_RED
424 IntT Red -> gl_RED
425 WordT Red -> gl_RED
426 FloatT RG -> gl_RG
427 IntT RG -> gl_RG
428 WordT RG -> gl_RG
429 FloatT RGBA -> gl_RGBA
430 IntT RGBA -> gl_RGBA
431 WordT RGBA -> gl_RGBA
432 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
433textureDataTypeToGLArityType Depth a = case a of
434 FloatT Red -> gl_DEPTH_COMPONENT
435 WordT Red -> gl_DEPTH_COMPONENT
436 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
437textureDataTypeToGLArityType Stencil a = case a of
438 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
439{-
440Texture and renderbuffer color formats (R):
441 R11F_G11F_B10F
442 R16
443 R16F
444 R16I
445 R16UI
446 R32F
447 R32I
448 R32UI
449 R8
450 R8I
451 R8UI
452 RG16
453 RG16F
454 RG16I
455 RG16UI
456 RG32F
457 RG32I
458 RG32UI
459 RG8
460 RG8I
461 RG8UI
462 RGB10_A2
463 RGB10_A2UI
464 RGBA16
465 RGBA16F
466 RGBA16I
467 RGBA16UI
468 RGBA32F
469 RGBA32I
470 RGBA32UI
471 RGBA8
472 RGBA8I
473 RGBA8UI
474 SRGB8_ALPHA8
475-}
476
477glGetIntegerv1 :: GLenum -> IO GLint
478glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi
479
480checkFBO :: IO ByteString
481checkFBO = do
482 let f e | e == gl_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"
483 | e == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"
484 | e == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"
485 | e == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"
486 | e == gl_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"
487 | e == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"
488 | e == gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"
489 | e == gl_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"
490 | otherwise = "Unknown error"
491 e <- glCheckFramebufferStatus gl_DRAW_FRAMEBUFFER
492 return $ f e
493
494filterToGLType :: Filter -> GLenum
495filterToGLType a = case a of
496 Nearest -> gl_NEAREST
497 Linear -> gl_LINEAR
498 NearestMipmapNearest -> gl_NEAREST_MIPMAP_NEAREST
499 NearestMipmapLinear -> gl_NEAREST_MIPMAP_LINEAR
500 LinearMipmapNearest -> gl_LINEAR_MIPMAP_NEAREST
501 LinearMipmapLinear -> gl_LINEAR_MIPMAP_LINEAR
502
503edgeModeToGLType :: EdgeMode -> GLenum
504edgeModeToGLType a = case a of
505 Repeat -> gl_REPEAT
506 MirroredRepeat -> gl_MIRRORED_REPEAT
507 ClampToEdge -> gl_CLAMP_TO_EDGE
508 ClampToBorder -> gl_CLAMP_TO_BORDER
509
510setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()
511setTextureSamplerParameters t s = do
512 glTexParameteri t gl_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
513 case samplerWrapT s of
514 Nothing -> return ()
515 Just a -> glTexParameteri t gl_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
516 case samplerWrapR s of
517 Nothing -> return ()
518 Just a -> glTexParameteri t gl_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
519 glTexParameteri t gl_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
520 glTexParameteri t gl_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
521
522 let setBColorV4F a = with a $ \p -> glTexParameterfv t gl_TEXTURE_BORDER_COLOR $ castPtr p
523 setBColorV4I a = with a $ \p -> glTexParameterIiv t gl_TEXTURE_BORDER_COLOR $ castPtr p
524 setBColorV4U a = with a $ \p -> glTexParameterIuiv t gl_TEXTURE_BORDER_COLOR $ castPtr p
525 case samplerBorderColor s of
526 -- float, word, int, red, rg, rgb, rgba
527 VFloat a -> setBColorV4F $ V4 a 0 0 0
528 VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0
529 VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0
530 VV4F a -> setBColorV4F a
531
532 VInt a -> setBColorV4I $ V4 a 0 0 0
533 VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0
534 VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0
535 VV4I a -> setBColorV4I a
536
537 VWord a -> setBColorV4U $ V4 a 0 0 0
538 VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0
539 VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0
540 VV4U a -> setBColorV4U a
541 _ -> fail "internal error (setTextureSamplerParameters)!"
542
543 case samplerMinLod s of
544 Nothing -> return ()
545 Just a -> glTexParameterf t gl_TEXTURE_MIN_LOD $ realToFrac a
546 case samplerMaxLod s of
547 Nothing -> return ()
548 Just a -> glTexParameterf t gl_TEXTURE_MAX_LOD $ realToFrac a
549 glTexParameterf t gl_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
550 case samplerCompareFunc s of
551 Nothing -> glTexParameteri t gl_TEXTURE_COMPARE_MODE $ fromIntegral gl_NONE
552 Just a -> do
553 glTexParameteri t gl_TEXTURE_COMPARE_MODE $ fromIntegral gl_COMPARE_REF_TO_TEXTURE
554 glTexParameteri t gl_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
555
556compileTexture :: TextureDescriptor -> IO GLTexture
557compileTexture txDescriptor = do
558 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
559 let TextureDescriptor
560 { textureType = txType
561 , textureSize = txSize
562 , textureSemantic = txSemantic
563 , textureSampler = txSampler
564 , textureBaseLevel = txBaseLevel
565 , textureMaxLevel = txMaxLevel
566 } = txDescriptor
567
568 txSetup txTarget dTy = do
569 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy
570 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy
571 glBindTexture txTarget to
572 glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel
573 glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel
574 setTextureSamplerParameters txTarget txSampler
575 return (internalFormat,dataFormat)
576
577 mipSize 0 x = [x]
578 mipSize n x = x : mipSize (n-1) (x `div` 2)
579 mipS = mipSize (txMaxLevel - txBaseLevel)
580 levels = [txBaseLevel..txMaxLevel]
581 target <- case txType of
582 Texture1D dTy layerCnt -> do
583 let VWord txW = txSize
584 txTarget = if layerCnt > 1 then gl_TEXTURE_1D_ARRAY else gl_TEXTURE_1D
585 (internalFormat,dataFormat) <- txSetup txTarget dTy
586 forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of
587 True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
588 False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
589 return txTarget
590 Texture2D dTy layerCnt -> do
591 let VV2U (V2 txW txH) = txSize
592 txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D
593 (internalFormat,dataFormat) <- txSetup txTarget dTy
594 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of
595 True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
596 False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
597 return txTarget
598 Texture3D dTy -> do
599 let VV3U (V3 txW txH txD) = txSize
600 txTarget = gl_TEXTURE_3D
601 (internalFormat,dataFormat) <- txSetup txTarget dTy
602 forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) ->
603 glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
604 return txTarget
605 TextureCube dTy -> do
606 let VV2U (V2 txW txH) = txSize
607 txTarget = gl_TEXTURE_CUBE_MAP
608 targets =
609 [ gl_TEXTURE_CUBE_MAP_POSITIVE_X
610 , gl_TEXTURE_CUBE_MAP_NEGATIVE_X
611 , gl_TEXTURE_CUBE_MAP_POSITIVE_Y
612 , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y
613 , gl_TEXTURE_CUBE_MAP_POSITIVE_Z
614 , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z
615 ]
616 (internalFormat,dataFormat) <- txSetup txTarget dTy
617 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
618 forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
619 return txTarget
620 TextureRect dTy -> do
621 let VV2U (V2 txW txH) = txSize
622 txTarget = gl_TEXTURE_RECTANGLE
623 (internalFormat,dataFormat) <- txSetup txTarget dTy
624 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
625 glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
626 return txTarget
627 Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do
628 let VV2U (V2 w h) = txSize
629 txTarget = if layerCnt > 1 then gl_TEXTURE_2D_MULTISAMPLE_ARRAY else gl_TEXTURE_2D_MULTISAMPLE
630 isFixed = fromIntegral $ if isFixedLocations then gl_TRUE else gl_FALSE
631 (internalFormat,dataFormat) <- txSetup txTarget dTy
632 case layerCnt > 1 of
633 True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed
634 False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed
635 return txTarget
636 TextureBuffer dTy -> do
637 fail "internal error: buffer texture is not supported yet"
638 -- TODO
639 let VV2U (V2 w h) = txSize
640 txTarget = gl_TEXTURE_2D
641 (internalFormat,dataFormat) <- txSetup txTarget dTy
642 glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
643 return txTarget
644 return $ GLTexture
645 { glTextureObject = to
646 , glTextureTarget = target
647 }
648
649primitiveToFetchPrimitive :: Primitive -> FetchPrimitive
650primitiveToFetchPrimitive prim = case prim of
651 TriangleStrip -> Triangles
652 TriangleList -> Triangles
653 TriangleFan -> Triangles
654 LineStrip -> Lines
655 LineList -> Lines
656 PointList -> Points
657 TriangleStripAdjacency -> TrianglesAdjacency
658 TriangleListAdjacency -> TrianglesAdjacency
659 LineStripAdjacency -> LinesAdjacency
660 LineListAdjacency -> LinesAdjacency
661
662primitiveToGLType :: Primitive -> GLenum
663primitiveToGLType p = case p of
664 TriangleStrip -> gl_TRIANGLE_STRIP
665 TriangleList -> gl_TRIANGLES
666 TriangleFan -> gl_TRIANGLE_FAN
667 LineStrip -> gl_LINE_STRIP
668 LineList -> gl_LINES
669 PointList -> gl_POINTS
670 TriangleStripAdjacency -> gl_TRIANGLE_STRIP_ADJACENCY
671 TriangleListAdjacency -> gl_TRIANGLES_ADJACENCY
672 LineStripAdjacency -> gl_LINE_STRIP_ADJACENCY
673 LineListAdjacency -> gl_LINES_ADJACENCY
674
675inputTypeToTextureTarget :: InputType -> GLenum
676inputTypeToTextureTarget ty = case ty of
677 STexture1D -> gl_TEXTURE_1D
678 STexture2D -> gl_TEXTURE_2D
679 STextureCube -> gl_TEXTURE_CUBE_MAP
680 STexture1DArray -> gl_TEXTURE_1D_ARRAY
681 STexture2DArray -> gl_TEXTURE_2D_ARRAY
682 STexture2DRect -> gl_TEXTURE_RECTANGLE
683
684 FTexture1D -> gl_TEXTURE_1D
685 FTexture2D -> gl_TEXTURE_2D
686 FTexture3D -> gl_TEXTURE_3D
687 FTextureCube -> gl_TEXTURE_CUBE_MAP
688 FTexture1DArray -> gl_TEXTURE_1D_ARRAY
689 FTexture2DArray -> gl_TEXTURE_2D_ARRAY
690 FTexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE
691 FTexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY
692 FTextureBuffer -> gl_TEXTURE_BUFFER
693 FTexture2DRect -> gl_TEXTURE_RECTANGLE
694
695 ITexture1D -> gl_TEXTURE_1D
696 ITexture2D -> gl_TEXTURE_2D
697 ITexture3D -> gl_TEXTURE_3D
698 ITextureCube -> gl_TEXTURE_CUBE_MAP
699 ITexture1DArray -> gl_TEXTURE_1D_ARRAY
700 ITexture2DArray -> gl_TEXTURE_2D_ARRAY
701 ITexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE
702 ITexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY
703 ITextureBuffer -> gl_TEXTURE_BUFFER
704 ITexture2DRect -> gl_TEXTURE_RECTANGLE
705
706 UTexture1D -> gl_TEXTURE_1D
707 UTexture2D -> gl_TEXTURE_2D
708 UTexture3D -> gl_TEXTURE_3D
709 UTextureCube -> gl_TEXTURE_CUBE_MAP
710 UTexture1DArray -> gl_TEXTURE_1D_ARRAY
711 UTexture2DArray -> gl_TEXTURE_2D_ARRAY
712 UTexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE
713 UTexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY
714 UTextureBuffer -> gl_TEXTURE_BUFFER
715 UTexture2DRect -> gl_TEXTURE_RECTANGLE
716
717 _ -> error "internal error (inputTypeToTextureTarget)!"
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-19 19:26:24 +0000