summaryrefslogtreecommitdiff
path: root/Backend/GL
diff options
context:
space:
mode:
authorCsaba Hruska <csaba.hruska@gmail.com>2016-01-08 12:01:39 +0100
committerCsaba Hruska <csaba.hruska@gmail.com>2016-01-08 12:01:39 +0100
commit64e13239772dae2a73e30bd0aa8ca2c70154987c (patch)
treed5f2e4d528fcf9b7815c2dcec255268413dfd61b /Backend/GL
parent65c124310c6aad1fa7a97c547292f8b90a70e991 (diff)
move to LambdaCube.GL, use more descriptive names, update for OpenGLRaw 3.0
Diffstat (limited to 'Backend/GL')
-rw-r--r--Backend/GL/Backend.hs833
-rw-r--r--Backend/GL/Data.hs113
-rw-r--r--Backend/GL/Input.hs387
-rw-r--r--Backend/GL/Mesh.hs238
-rw-r--r--Backend/GL/Type.hs541
-rw-r--r--Backend/GL/Util.hs719
6 files changed, 0 insertions, 2831 deletions
diff --git a/Backend/GL/Backend.hs b/Backend/GL/Backend.hs
deleted file mode 100644
index 55ae443..0000000
--- a/Backend/GL/Backend.hs
+++ /dev/null
@@ -1,833 +0,0 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-}
2module Backend.GL.Backend where
3
4import Control.Applicative
5import Control.Monad
6import Control.Monad.State
7import Data.Bits
8import Data.ByteString.Char8 (ByteString,pack)
9import Data.IORef
10import Data.IntMap (IntMap)
11import Data.Maybe (isNothing,fromJust)
12import Data.Map (Map)
13import Data.Set (Set)
14import Data.Trie as T
15import Data.Trie.Convenience as T
16import Data.Vector (Vector,(!),(//))
17import qualified Data.ByteString.Char8 as SB
18import qualified Data.Foldable as F
19import qualified Data.IntMap as IM
20import qualified Data.Map as Map
21import qualified Data.List as L
22import qualified Data.Set as S
23import qualified Data.Vector as V
24import qualified Data.Vector.Storable as SV
25
26import Graphics.Rendering.OpenGL.Raw.Core33
27import Foreign
28
29-- LC IR imports
30import Linear
31import IR hiding (streamType)
32import qualified IR as IR
33
34import Backend.GL.Type
35import Backend.GL.Util
36
37import Backend.GL.Data
38import Backend.GL.Input
39
40setupRasterContext :: RasterContext -> IO ()
41setupRasterContext = cvt
42 where
43 cff :: FrontFace -> GLenum
44 cff CCW = gl_CCW
45 cff CW = gl_CW
46
47 setProvokingVertex :: ProvokingVertex -> IO ()
48 setProvokingVertex pv = glProvokingVertex $ case pv of
49 FirstVertex -> gl_FIRST_VERTEX_CONVENTION
50 LastVertex -> gl_LAST_VERTEX_CONVENTION
51
52 setPointSize :: PointSize -> IO ()
53 setPointSize ps = case ps of
54 ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE
55 PointSize s -> do
56 glDisable gl_PROGRAM_POINT_SIZE
57 glPointSize $ realToFrac s
58
59 cvt :: RasterContext -> IO ()
60 cvt (PointCtx ps fts sc) = do
61 setPointSize ps
62 glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
63 glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
64 LowerLeft -> gl_LOWER_LEFT
65 UpperLeft -> gl_UPPER_LEFT
66
67 cvt (LineCtx lw pv) = do
68 glLineWidth (realToFrac lw)
69 setProvokingVertex pv
70
71 cvt (TriangleCtx cm pm po pv) = do
72 -- cull mode
73 case cm of
74 CullNone -> glDisable gl_CULL_FACE
75 CullFront f -> do
76 glEnable gl_CULL_FACE
77 glCullFace gl_FRONT
78 glFrontFace $ cff f
79 CullBack f -> do
80 glEnable gl_CULL_FACE
81 glCullFace gl_BACK
82 glFrontFace $ cff f
83
84 -- polygon mode
85 case pm of
86 PolygonPoint ps -> do
87 setPointSize ps
88 glPolygonMode gl_FRONT_AND_BACK gl_POINT
89 PolygonLine lw -> do
90 glLineWidth (realToFrac lw)
91 glPolygonMode gl_FRONT_AND_BACK gl_LINE
92 PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL
93
94 -- polygon offset
95 glDisable gl_POLYGON_OFFSET_POINT
96 glDisable gl_POLYGON_OFFSET_LINE
97 glDisable gl_POLYGON_OFFSET_FILL
98 case po of
99 NoOffset -> return ()
100 Offset f u -> do
101 glPolygonOffset (realToFrac f) (realToFrac u)
102 glEnable $ case pm of
103 PolygonPoint _ -> gl_POLYGON_OFFSET_POINT
104 PolygonLine _ -> gl_POLYGON_OFFSET_LINE
105 PolygonFill -> gl_POLYGON_OFFSET_FILL
106
107 -- provoking vertex
108 setProvokingVertex pv
109
110setupAccumulationContext :: AccumulationContext -> IO ()
111setupAccumulationContext (AccumulationContext n ops) = cvt ops
112 where
113 cvt :: [FragmentOperation] -> IO ()
114 cvt (StencilOp a b c : DepthOp f m : xs) = do
115 -- TODO
116 cvtC 0 xs
117 cvt (StencilOp a b c : xs) = do
118 -- TODO
119 cvtC 0 xs
120 cvt (DepthOp df dm : xs) = do
121 -- TODO
122 glDisable gl_STENCIL_TEST
123 case df == Always && dm == False of
124 True -> glDisable gl_DEPTH_TEST
125 False -> do
126 glEnable gl_DEPTH_TEST
127 glDepthFunc $! comparisonFunctionToGLType df
128 glDepthMask (cvtBool dm)
129 cvtC 0 xs
130 cvt xs = do
131 glDisable gl_DEPTH_TEST
132 glDisable gl_STENCIL_TEST
133 cvtC 0 xs
134
135 cvtC :: Int -> [FragmentOperation] -> IO ()
136 cvtC i (ColorOp b m : xs) = do
137 -- TODO
138 case b of
139 NoBlending -> do
140 -- FIXME: requires GL 3.1
141 --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
142 glDisable gl_BLEND -- workaround
143 glDisable gl_COLOR_LOGIC_OP
144 BlendLogicOp op -> do
145 glDisable gl_BLEND
146 glEnable gl_COLOR_LOGIC_OP
147 glLogicOp $ logicOperationToGLType op
148 Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do
149 glDisable gl_COLOR_LOGIC_OP
150 -- FIXME: requires GL 3.1
151 --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
152 glEnable gl_BLEND -- workaround
153 glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)
154 glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)
155 (blendingFactorToGLType saF) (blendingFactorToGLType daF)
156 glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
157 let cvt True = 1
158 cvt False = 0
159 (mr,mg,mb,ma) = case m of
160 VBool r -> (cvt r, 1, 1, 1)
161 VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)
162 VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)
163 VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)
164 _ -> (1,1,1,1)
165 glColorMask mr mg mb ma
166 cvtC (i + 1) xs
167 cvtC _ [] = return ()
168
169 cvtBool :: Bool -> GLboolean
170 cvtBool True = 1
171 cvtBool False = 0
172
173clearRenderTarget :: [ClearImage] -> IO ()
174clearRenderTarget values = do
175 let setClearValue (m,i) value = case value of
176 ClearImage Depth (VFloat v) -> do
177 glDepthMask 1
178 glClearDepth $ realToFrac v
179 return (m .|. gl_DEPTH_BUFFER_BIT, i)
180 ClearImage Stencil (VWord v) -> do
181 glClearStencil $ fromIntegral v
182 return (m .|. gl_STENCIL_BUFFER_BIT, i)
183 ClearImage Color c -> do
184 let (r,g,b,a) = case c of
185 VFloat r -> (realToFrac r, 0, 0, 1)
186 VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)
187 VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)
188 VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
189 _ -> (0,0,0,1)
190 glColorMask 1 1 1 1
191 glClearColor r g b a
192 return (m .|. gl_COLOR_BUFFER_BIT, i+1)
193 _ -> error "internal error (clearRenderTarget)"
194 (mask,_) <- foldM setClearValue (0,0) values
195 glClear $ fromIntegral mask
196
197
198printGLStatus = checkGL >>= print
199printFBOStatus = checkFBO >>= print
200
201compileProgram :: Trie InputType -> Program -> IO GLProgram
202compileProgram uniTrie p = do
203 po <- glCreateProgram
204 putStrLn $ "compile program: " ++ show po
205 let createAndAttach src t = do
206 o <- glCreateShader t
207 compileShader o $ map pack [src]
208 glAttachShader po o
209 putStr " + compile shader source: " >> printGLStatus
210 return o
211
212 objs <- sequence $ createAndAttach (vertexShader p) gl_VERTEX_SHADER : createAndAttach (fragmentShader p) gl_FRAGMENT_SHADER : case geometryShader p of
213 Nothing -> []
214 Just s -> [createAndAttach s gl_GEOMETRY_SHADER]
215
216 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do
217 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
218 glBindFragDataLocation po i $ castPtr pn
219 putStr " + setup shader output mapping: " >> printGLStatus
220
221 glLinkProgram po
222 printProgramLog po
223
224 -- check link status
225 status <- glGetProgramiv1 gl_LINK_STATUS po
226 when (status /= fromIntegral gl_TRUE) $ fail "link program failed!"
227
228 -- check program input
229 (uniforms,uniformsType) <- queryUniforms po
230 (attributes,attributesType) <- queryStreams po
231 print uniforms
232 print attributes
233 let lcUniforms = (toTrie $ programUniforms p) `unionL` (toTrie $ programInTextures p)
234 lcStreams = fmap ty (toTrie $ programStreams p)
235 check a m = and $ map go $ T.toList m
236 where go (k,b) = case T.lookup k a of
237 Nothing -> False
238 Just x -> x == b
239 unless (check lcUniforms uniformsType) $ do
240 putStrLn $ "expected: " ++ show lcUniforms
241 putStrLn $ "actual: " ++ show uniformsType
242 fail "shader program uniform input mismatch!"
243 unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)
244 -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input
245 let inUniNames = toTrie $ programUniforms p
246 inUniforms = L.filter (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms
247 inTextureNames = toTrie $ programInTextures p
248 inTextures = L.filter (\(n,v) -> T.member n inTextureNames) $ T.toList $ uniforms
249 texUnis = [n | (n,_) <- inTextures, T.member n uniTrie]
250 putStrLn $ "uniTrie: " ++ show (T.keys uniTrie)
251 putStrLn $ "inUniNames: " ++ show inUniNames
252 putStrLn $ "inUniforms: " ++ show inUniforms
253 putStrLn $ "inTextureNames: " ++ show inTextureNames
254 putStrLn $ "inTextures: " ++ show inTextures
255 putStrLn $ "texUnis: " ++ show texUnis
256 let valA = T.toList $ attributes
257 valB = T.toList $ toTrie $ programStreams p
258 putStrLn "------------"
259 print $ T.toList $ attributes
260 print $ T.toList $ toTrie $ programStreams p
261 let lcStreamName = fmap name (toTrie $ programStreams p)
262 return $ GLProgram
263 { shaderObjects = objs
264 , programObject = po
265 , inputUniforms = T.fromList inUniforms
266 , inputTextures = T.fromList inTextures
267 , inputTextureUniforms = S.fromList $ texUnis
268 , inputStreams = T.fromList [(n,(idx, pack attrName)) | (n,idx) <- T.toList $ attributes, let Just attrName = T.lookup n lcStreamName]
269 }
270
271compileSampler :: SamplerDescriptor -> IO GLSampler
272compileSampler s = return $ GLSampler {}
273
274{-
275data ImageIndex
276 = TextureImage TextureName Int (Maybe Int) -- Texture name, mip index, array index
277 | Framebuffer ImageSemantic
278
279data ImageSemantic
280 = Depth
281 | Stencil
282 | Color
283-}
284{-
285 = RenderTarget
286 { renderTargets :: [(ImageSemantic,Maybe ImageIndex)] -- render texture or default framebuffer (semantic, render texture for the program output)
287 }
288-}
289{-
290 glDrawBuffers
291 GL_NONE
292 --GL_FRONT_LEFT
293 --GL_FRONT_RIGHT
294 GL_BACK_LEFT
295 --GL_BACK_RIGHT
296 GL_COLOR_ATTACHMENTn
297-}
298compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
299compileRenderTarget texs glTexs (RenderTarget targets) = do
300 let isFB (Framebuffer _) = True
301 isFB _ = False
302 images = [img | TargetItem _ (Just img) <- V.toList targets]
303 case all isFB images of
304 True -> do
305 let bufs = [cvt img | TargetItem Color img <- V.toList targets]
306 cvt a = case a of
307 Nothing -> gl_NONE
308 Just (Framebuffer Color) -> gl_BACK_LEFT
309 _ -> error "internal error (compileRenderTarget)!"
310 return $ GLRenderTarget
311 { framebufferObject = 0
312 , framebufferDrawbuffers = Just bufs
313 }
314 False -> do
315 when (any isFB images) $ fail "internal error (compileRenderTarget)!"
316 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
317 glBindFramebuffer gl_DRAW_FRAMEBUFFER fbo
318 {-
319 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
320 GL_TEXTURE_1D
321 void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
322 GL_TEXTURE_2D
323 GL_TEXTURE_RECTANGLE
324 GL_TEXTURE_CUBE_MAP_POSITIVE_X
325 GL_TEXTURE_CUBE_MAP_POSITIVE_Y
326 GL_TEXTURE_CUBE_MAP_POSITIVE_Z
327 GL_TEXTURE_CUBE_MAP_NEGATIVE_X
328 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
329 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
330 GL_TEXTURE_2D_MULTISAMPLE
331 void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer);
332 void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer);
333 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);
334 -}
335 let attach attachment (TextureImage texIdx level (Just layer)) =
336 glFramebufferTextureLayer gl_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
337 attach attachment (TextureImage texIdx level Nothing) = do
338 let glTex = glTexs ! texIdx
339 tex = texs ! texIdx
340 txLevel = fromIntegral level
341 txTarget = glTextureTarget glTex
342 txObj = glTextureObject glTex
343 attachArray = glFramebufferTexture gl_DRAW_FRAMEBUFFER attachment txObj txLevel
344 attach2D = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
345 case textureType tex of
346 Texture1D _ n
347 | n > 1 -> attachArray
348 | otherwise -> glFramebufferTexture1D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
349 Texture2D _ n
350 | n > 1 -> attachArray
351 | otherwise -> attach2D
352 Texture3D _ -> attachArray
353 TextureCube _ -> attachArray
354 TextureRect _ -> attach2D
355 Texture2DMS _ n _ _
356 | n > 1 -> attachArray
357 | otherwise -> attach2D
358 TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"
359
360 go a (TargetItem Stencil (Just img)) = do
361 fail "Stencil support is not implemented yet!"
362 return a
363 go a (TargetItem Depth (Just img)) = do
364 attach gl_DEPTH_ATTACHMENT img
365 return a
366 go (bufs,colorIdx) (TargetItem Color (Just img)) = do
367 let attachment = gl_COLOR_ATTACHMENT0 + fromIntegral colorIdx
368 attach attachment img
369 return (attachment : bufs, colorIdx + 1)
370 go (bufs,colorIdx) (TargetItem Color Nothing) = return (gl_NONE : bufs, colorIdx + 1)
371 go a _ = return a
372 (bufs,_) <- foldM go ([],0) targets
373 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
374 return $ GLRenderTarget
375 { framebufferObject = fbo
376 , framebufferDrawbuffers = Nothing
377 }
378
379compileStreamData :: StreamData -> IO GLStream
380compileStreamData s = do
381 let withV w a f = w a (\p -> f $ castPtr p)
382 let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)
383 compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
384 compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
385 --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v)
386 (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]
387 getLength n = l `div` c
388 where
389 l = case Map.lookup n $ IR.streamData s of
390 Just (VFloatArray v) -> V.length v
391 Just (VIntArray v) -> V.length v
392 Just (VWordArray v) -> V.length v
393 _ -> error "compileStreamData - getLength"
394 c = case Map.lookup n $ IR.streamType s of
395 Just Bool -> 1
396 Just V2B -> 2
397 Just V3B -> 3
398 Just V4B -> 4
399 Just Word -> 1
400 Just V2U -> 2
401 Just V3U -> 3
402 Just V4U -> 4
403 Just Int -> 1
404 Just V2I -> 2
405 Just V3I -> 3
406 Just V4I -> 4
407 Just Float -> 1
408 Just V2F -> 2
409 Just V3F -> 3
410 Just V4F -> 4
411 Just M22F -> 4
412 Just M23F -> 6
413 Just M24F -> 8
414 Just M32F -> 6
415 Just M33F -> 9
416 Just M34F -> 12
417 Just M42F -> 8
418 Just M43F -> 12
419 Just M44F -> 16
420 _ -> error "compileStreamData - getLength element count"
421 buffer <- compileBuffer arrays
422 cmdRef <- newIORef []
423 let toStream (n,i) = (n,Stream
424 { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s)
425 , streamBuffer = buffer
426 , streamArrIdx = i
427 , streamStart = 0
428 , streamLength = getLength n
429 })
430 return $ GLStream
431 { glStreamCommands = cmdRef
432 , glStreamPrimitive = case streamPrimitive s of
433 Points -> PointList
434 Lines -> LineList
435 Triangles -> TriangleList
436 LinesAdjacency -> LineListAdjacency
437 TrianglesAdjacency -> TriangleListAdjacency
438 , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap
439 , glStreamProgram = V.head $ streamPrograms s
440 }
441
442createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
443createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]
444 where
445 -- object draw command
446 drawCmd = GLDrawArrays prim 0 (fromIntegral count)
447 where
448 prim = primitiveToGLType primitive
449 count = head [c | Stream _ _ _ _ c <- T.elems attrs]
450
451 -- object uniform commands
452 -- texture slot setup commands
453 streamUniCmds = uniCmds ++ texCmds
454 where
455 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n]
456 uniMap = T.toList $ inputUniforms prg
457 topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis
458 texUnis = S.toList $ inputTextureUniforms prg
459 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
460 | n <- texUnis
461 , let u = topUni n
462 , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
463 ]
464 uniInputType (GLUniform ty _) = ty
465
466 -- object attribute stream commands
467 streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs]
468 where
469 attrMap = inputStreams prg
470 attrCmd i s = case s of
471 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
472 TWord -> setIntAttrib 1
473 TV2U -> setIntAttrib 2
474 TV3U -> setIntAttrib 3
475 TV4U -> setIntAttrib 4
476 TInt -> setIntAttrib 1
477 TV2I -> setIntAttrib 2
478 TV3I -> setIntAttrib 3
479 TV4I -> setIntAttrib 4
480 TFloat -> setFloatAttrib 1
481 TV2F -> setFloatAttrib 2
482 TV3F -> setFloatAttrib 3
483 TV4F -> setFloatAttrib 4
484 TM22F -> setFloatAttrib 4
485 TM23F -> setFloatAttrib 6
486 TM24F -> setFloatAttrib 8
487 TM32F -> setFloatAttrib 6
488 TM33F -> setFloatAttrib 9
489 TM34F -> setFloatAttrib 12
490 TM42F -> setFloatAttrib 8
491 TM43F -> setFloatAttrib 12
492 TM44F -> setFloatAttrib 16
493 where
494 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
495 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
496 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
497 glType = arrayTypeToGLType arrType
498 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
499
500 -- constant generic attribute
501 constAttr -> GLSetVertexAttrib i constAttr
502
503allocPipeline :: Pipeline -> IO GLPipeline
504allocPipeline p = do
505 let uniTrie = uniforms $ schemaFromPipeline p
506 smps <- V.mapM compileSampler $ samplers p
507 texs <- V.mapM compileTexture $ textures p
508 trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
509 prgs <- V.mapM (compileProgram uniTrie) $ programs p
510 -- texture unit mapping ioref trie
511 -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
512 texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p)
513 let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState
514 input <- newIORef Nothing
515 -- default Vertex Array Object
516 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
517 strs <- V.mapM compileStreamData $ streams p
518 return $ GLPipeline
519 { glPrograms = prgs
520 , glTextures = texs
521 , glSamplers = smps
522 , glTargets = trgs
523 , glCommands = cmds
524 , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p
525 , glInput = input
526 , glSlotNames = V.map (pack . slotName) $ IR.slots p
527 , glVAO = vao
528 , glTexUnitMapping = texUnitMapRefs
529 , glStreams = strs
530 }
531
532disposePipeline :: GLPipeline -> IO ()
533disposePipeline p = do
534 setPipelineInput p Nothing
535 V.forM_ (glPrograms p) $ \prg -> do
536 glDeleteProgram $ programObject prg
537 mapM_ glDeleteShader $ shaderObjects prg
538 let targets = glTargets p
539 withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
540 let textures = glTextures p
541 withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
542 with (glVAO p) $ (glDeleteVertexArrays 1)
543
544{-
545data SlotSchema
546 = SlotSchema
547 { primitive :: FetchPrimitive
548 , attributes :: Trie StreamType
549 }
550 deriving Show
551
552data PipelineSchema
553 = PipelineSchema
554 { slots :: Trie SlotSchema
555 , uniforms :: Trie InputType
556 }
557 deriving Show
558-}
559isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool
560isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset]
561 where
562 isMember a Nothing = False
563 isMember a (Just b) = eqFun a b
564
565-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms
566{-
567 let sch = schema input
568 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
569 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
570 _ -> return ()
571 case T.lookup slotName (slots sch) of
572 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
573 Just (SlotSchema sPrim sAttrs) -> do
574 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
575 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
576 let sType = fmap streamToStreamType attribs
577 when (sType /= sAttrs) $ throw $ userError $ unlines $
578 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
579 , show sAttrs
580 , " but got "
581 , show sType
582 ]
583-}
584setPipelineInput :: GLPipeline -> Maybe GLPipelineInput -> IO ()
585setPipelineInput p input' = do
586 -- TODO: check matching input schema
587 {-
588 case input' of
589 Nothing -> return ()
590 Just input -> schemaFromPipeline p
591 -}
592 {-
593 deletion:
594 - remove pipeline's object commands from used slots
595 - remove pipeline from attached pipelines vector
596 -}
597 ic' <- readIORef $ glInput p
598 case ic' of
599 Nothing -> return ()
600 Just ic -> do
601 let idx = icId ic
602 oldInput = icInput ic
603 slotMask = icSlotMapPipelineToInput ic
604 slotRefs = slotVector oldInput
605 modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)]
606 V.forM_ slotMask $ \slotIdx -> do
607 slot <- readIORef (slotRefs ! slotIdx)
608 forM_ (IM.elems $ objectMap slot) $ \obj -> do
609 modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)]
610 {-
611 addition:
612 - get an id from pipeline input
613 - add to attached pipelines
614 - generate slot mappings
615 - update used slots, and generate object commands for objects in the related slots
616 -}
617 case input' of
618 Nothing -> writeIORef (glInput p) Nothing
619 Just input -> do
620 let pipelinesRef = pipelines input
621 oldPipelineV <- readIORef pipelinesRef
622 (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
623 Nothing -> do
624 -- we don't have empty space, hence we double the vector size
625 let len = V.length oldPipelineV
626 modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]
627 return (len,Just len)
628 Just i -> do
629 modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]
630 return (i,Nothing)
631 -- create input connection
632 let sm = slotMap input
633 pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm]
634 iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
635 writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP
636
637 -- generate object commands for related slots
638 {-
639 for each slot in pipeline:
640 map slot name to input slot name
641 for each object:
642 generate command program vector => for each dependent program:
643 generate object commands
644 -}
645 let slotV = slotVector input
646 progV = glPrograms p
647 texUnitMap = glTexUnitMapping p
648 topUnis = uniformSetup input
649 emptyV = V.replicate (V.length progV) []
650 extend v = case shouldExtend of
651 Nothing -> v
652 Just l -> V.concat [v,V.replicate l V.empty]
653 V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do
654 slot <- readIORef $ slotV ! slotIdx
655 forM_ (IM.elems $ objectMap slot) $ \obj -> do
656 let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
657 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
658 -- generate stream commands
659 V.forM_ (glStreams p) $ \s -> do
660 writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
661{-
662 track state:
663 - render target
664 - binded textures
665-}
666
667{-
668 render steps:
669 - update uniforms
670 - per uniform setup
671 - buffer setup (one buffer per object, which has per at least one object uniform)
672 - new command: set uniform buffer (binds uniform buffer to program's buffer slot)
673 - render slot steps:
674 - set uniform buffer or set uniforms separately
675 - set vertex and index array
676 - call draw command
677-}
678{-
679 storage alternatives:
680 - interleaved / separated
681 - VAO or VBOs
682-}
683 {-
684 strategy:
685 step 1: generate commands for an object
686 step 2: sort object merge and do optimization by filtering redundant commands
687 -}
688{-
689 design:
690 runtime eleminiation of redundant buffer bind commands and redundant texture bind commands
691-}
692{-
693 track:
694 buffer binding on various targets: gl_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER
695 glEnable/DisableVertexAttribArray
696-}
697renderSlot :: [GLObjectCommand] -> IO ()
698renderSlot cmds = forM_ cmds $ \cmd -> do
699 case cmd of
700 GLSetVertexAttribArray idx buf size typ ptr -> do
701 glBindBuffer gl_ARRAY_BUFFER buf
702 glEnableVertexAttribArray idx
703 glVertexAttribPointer idx size typ (fromIntegral gl_FALSE) 0 ptr
704 GLSetVertexAttribIArray idx buf size typ ptr -> do
705 glBindBuffer gl_ARRAY_BUFFER buf
706 glEnableVertexAttribArray idx
707 glVertexAttribIPointer idx size typ 0 ptr
708 GLDrawArrays mode first count -> glDrawArrays mode first count
709 GLDrawElements mode count typ buf indicesPtr -> do
710 glBindBuffer gl_ELEMENT_ARRAY_BUFFER buf
711 glDrawElements mode count typ indicesPtr
712 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
713 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
714 txObjVal <- readIORef ref
715 -- HINT: ugly and hacky
716 with txObjVal $ \txObjPtr -> do
717 txObj <- peek $ castPtr txObjPtr :: IO GLuint
718 texUnit <- readIORef tuRef
719 glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit
720 glBindTexture txTarget txObj
721 putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
722 GLSetVertexAttrib idx val -> do
723 glDisableVertexAttribArray idx
724 setVertexAttrib idx val
725 isOk <- checkGL
726 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
727
728renderPipeline :: GLPipeline -> IO ()
729renderPipeline glp = do
730 glBindVertexArray (glVAO glp)
731 forM_ (glCommands glp) $ \cmd -> do
732 case cmd of
733 GLSetRasterContext rCtx -> setupRasterContext rCtx
734 GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx
735 GLSetRenderTarget rt bufs -> do
736 -- set target viewport
737 --when (rt == 0) $ do -- screen out
738 ic' <- readIORef $ glInput glp
739 case ic' of
740 Nothing -> return ()
741 Just ic -> do
742 let input = icInput ic
743 (w,h) <- readIORef $ screenSize input
744 glViewport 0 0 (fromIntegral w) (fromIntegral h)
745 -- TODO: set FBO target viewport
746 glBindFramebuffer gl_DRAW_FRAMEBUFFER rt
747 case bufs of
748 Nothing -> return ()
749 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
750 GLSetProgram p -> glUseProgram p
751 GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu
752 GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx
753 GLClearRenderTarget vals -> clearRenderTarget vals
754 GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target
755 GLRenderStream streamIdx progIdx -> do
756 renderSlot =<< readIORef (glStreamCommands $ glStreams glp ! streamIdx)
757 GLRenderSlot slotIdx progIdx -> do
758 input <- readIORef (glInput glp)
759 case input of
760 Nothing -> putStrLn "Warning: No pipeline input!" >> return ()
761 Just ic -> do
762 GLSlot _ objs _ <- readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx))
763 --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects"
764 V.forM_ objs $ \(_,obj) -> do
765 enabled <- readIORef $ objEnabled obj
766 when enabled $ do
767 cmd <- readIORef $ objCommands obj
768 --putStrLn "Render object"
769 renderSlot ((cmd ! icId ic) ! progIdx)
770 {-
771 GLSetSampler
772 GLSaveImage
773 GLLoadImage
774 -}
775 isOk <- checkGL
776 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
777
778data CGState
779 = CGState
780 { currentProgram :: ProgramName
781 , textureBinding :: IntMap GLTexture
782 , samplerUniforms :: Map UniformName TextureUnit
783 }
784
785initCGState = CGState
786 { currentProgram = error "CGState: empty currentProgram"
787 , textureBinding = IM.empty
788 , samplerUniforms = mempty
789 }
790
791type CG a = State CGState a
792
793compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand
794compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
795 SetRasterContext rCtx -> return $ GLSetRasterContext rCtx
796 SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx
797 SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs
798 SetProgram p -> do
799 modify (\s -> s {currentProgram = p})
800 return $ GLSetProgram $ programObject $ programs ! p
801 SetSamplerUniform n tu -> do
802 modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms})
803 p <- currentProgram <$> get
804 case T.lookup (pack n) (inputTextures $ programs ! p) of
805 Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd
806 Just i -> case T.lookup (pack n) texUnitMap of
807 Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
808 Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r
809 SetTexture tu t -> do
810 let tex = textures ! t
811 modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
812 return $ GLSetTexture (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
813{-
814 SetSampler tu s -> liftIO $ do
815 glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
816-}
817 RenderSlot slot -> do
818 smpUnis <- samplerUniforms <$> get
819 p <- currentProgram <$> get
820 return $ GLRenderSlot slot p
821 RenderStream stream -> do
822 p <- currentProgram <$> get
823 return $ GLRenderStream stream p
824 ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals
825 GenerateMipMap tu -> do
826 tb <- textureBinding <$> get
827 case IM.lookup tu tb of
828 Nothing -> fail "internal error (GenerateMipMap)!"
829 Just tex -> return $ GLGenerateMipMap (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
830{-
831 SaveImage _ _ -> undefined
832 LoadImage _ _ -> undefined
833-}
diff --git a/Backend/GL/Data.hs b/Backend/GL/Data.hs
deleted file mode 100644
index 2c6e596..0000000
--- a/Backend/GL/Data.hs
+++ /dev/null
@@ -1,113 +0,0 @@
1module Backend.GL.Data where
2
3import Control.Applicative
4import Control.Monad
5import Data.ByteString.Char8 (ByteString)
6import Data.IORef
7import Data.List as L
8import Data.Maybe
9import Data.Trie as T
10import Foreign
11--import qualified Data.IntMap as IM
12import qualified Data.Map as Map
13import qualified Data.Set as Set
14import qualified Data.Vector as V
15import qualified Data.Vector.Storable as SV
16
17--import Control.DeepSeq
18
19import Graphics.Rendering.OpenGL.Raw.Core33
20import Data.Word
21import Codec.Picture
22import Codec.Picture.Types
23
24import Backend.GL.Type
25import Backend.GL.Util
26
27-- Buffer
28compileBuffer :: [Array] -> IO Buffer
29compileBuffer arrs = do
30 let calcDesc (offset,setters,descs) (Array arrType cnt setter) =
31 let size = cnt * sizeOfArrayType arrType
32 in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)
33 (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs
34 bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
35 glBindBuffer gl_ARRAY_BUFFER bo
36 glBufferData gl_ARRAY_BUFFER (fromIntegral bufSize) nullPtr gl_STATIC_DRAW
37 forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
38 glBindBuffer gl_ARRAY_BUFFER 0
39 return $! Buffer (V.fromList $! reverse arrDescs) bo
40
41updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
42updateBuffer (Buffer arrDescs bo) arrs = do
43 glBindBuffer gl_ARRAY_BUFFER bo
44 forM arrs $ \(i,Array arrType cnt setter) -> do
45 let ArrayDesc ty len offset size = arrDescs V.! i
46 when (ty == arrType && cnt == len) $
47 setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
48 glBindBuffer gl_ARRAY_BUFFER 0
49
50bufferSize :: Buffer -> Int
51bufferSize = V.length . bufArrays
52
53arraySize :: Buffer -> Int -> Int
54arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx
55
56arrayType :: Buffer -> Int -> ArrayType
57arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
58
59-- Texture
60
61-- FIXME: Temporary implemenation
62compileTexture2DRGBAF :: Bool -> Bool -> DynamicImage -> IO TextureData
63compileTexture2DRGBAF = compileTexture2DRGBAF' False
64
65compileTexture2DRGBAF' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData
66compileTexture2DRGBAF' isSRGB isMip isClamped bitmap' = do
67 let bitmap = case bitmap' of
68 ImageRGB8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGB8 r g b) -> [PixelRGBA8 r g b maxBound]) i
69 ImageRGBA8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGBA8 r g b a) -> [PixelRGBA8 r g b a]) i
70 ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i -- $ Image w h $ SV.fromList $ pixelFoldMap (\p -> let PixelRGB8 r g b = convertPixel p in [PixelRGBA8 r g b maxBound]) i
71 ImageCMYK16 _ -> error "compileTexture2DRGBAF: ImageCMYK16"
72 ImageCMYK8 _ -> error "compileTexture2DRGBAF: ImageCMYK8"
73 ImageRGBA16 _ -> error "compileTexture2DRGBAF: ImageRGBA16"
74 ImageRGBF _ -> error "compileTexture2DRGBAF: ImageRGBF"
75 ImageRGB16 _ -> error "compileTexture2DRGBAF: ImageRGB16"
76 ImageYA16 _ -> error "compileTexture2DRGBAF: ImageYA16"
77 ImageYA8 _ -> error "compileTexture2DRGBAF: ImageYA8"
78 ImageYF _ -> error "compileTexture2DRGBAF: ImageYF"
79 ImageY16 _ -> error "compileTexture2DRGBAF: ImageY16"
80 ImageY8 _ -> error "compileTexture2DRGBAF: ImageY8"
81 _ -> error "compileTexture2DRGBAF: unknown image"
82
83 glPixelStorei gl_UNPACK_ALIGNMENT 1
84 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
85 glBindTexture gl_TEXTURE_2D to
86 let (width,height) = bitmapSize bitmap
87 bitmapSize (ImageRGB8 (Image w h _)) = (w,h)
88 bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)
89 bitmapSize _ = error "unsupported image type :("
90 withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0
91 withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0
92 withBitmap _ _ = error "unsupported image type :("
93 wrapMode = case isClamped of
94 True -> gl_CLAMP_TO_EDGE
95 False -> gl_REPEAT
96 (minFilter,maxLevel) = case isMip of
97 False -> (gl_LINEAR,0)
98 True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
99 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode
100 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode
101 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter
102 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR
103 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0
104 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
105 withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
106 let internalFormat = fromIntegral $ if isSRGB then (if nchn == 3 then gl_SRGB8 else gl_SRGB8_ALPHA8) else (if nchn == 3 then gl_RGB8 else gl_RGBA8)
107 dataFormat = fromIntegral $ case nchn of
108 3 -> gl_RGB
109 4 -> gl_RGBA
110 _ -> error "unsupported texture format!"
111 glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr
112 when isMip $ glGenerateMipmap gl_TEXTURE_2D
113 return $ TextureData to
diff --git a/Backend/GL/Input.hs b/Backend/GL/Input.hs
deleted file mode 100644
index f92a9c9..0000000
--- a/Backend/GL/Input.hs
+++ /dev/null
@@ -1,387 +0,0 @@
1module Backend.GL.Input where
2
3import Control.Applicative
4import Control.Exception
5import Control.Monad
6import Data.ByteString.Char8 (ByteString,pack)
7import Data.IORef
8import Data.IntMap (IntMap)
9import Data.Trie (Trie)
10import Data.Trie.Convenience as T
11import Data.Vector (Vector,(//),(!))
12import Data.Word
13import Foreign
14import qualified Data.ByteString.Char8 as SB
15import qualified Data.IntMap as IM
16import qualified Data.Set as S
17import qualified Data.Map as Map
18import qualified Data.Trie as T
19import qualified Data.Vector as V
20import qualified Data.Vector.Algorithms.Intro as I
21
22import Graphics.Rendering.OpenGL.Raw.Core33
23
24import IR as IR
25import Linear as IR
26import Backend.GL.Type as T
27import Backend.GL.Util
28
29import qualified IR as IR
30
31schemaFromPipeline :: IR.Pipeline -> PipelineSchema
32schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul)
33 where
34 (sl,ul) = unzip [( (pack sName,SlotSchema sPrimitive (fmap cvt (toTrie sStreams)))
35 , toTrie sUniforms
36 )
37 | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a
38 ]
39 cvt a = case toStreamType a of
40 Just v -> v
41 Nothing -> error "internal error (schemaFromPipeline)"
42
43mkUniform :: [(ByteString,InputType)] -> IO (Trie InputSetter, Trie GLUniform)
44mkUniform l = do
45 unisAndSetters <- forM l $ \(n,t) -> do
46 (uni, setter) <- mkUniformSetter t
47 return ((n,uni),(n,setter))
48 let (unis,setters) = unzip unisAndSetters
49 return (T.fromList setters, T.fromList unis)
50
51mkGLPipelineInput :: PipelineSchema -> IO GLPipelineInput
52mkGLPipelineInput sch = do
53 let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..]
54 len = T.size sm
55 (setters,unis) <- mkUniform $ T.toList $ uniforms sch
56 seed <- newIORef 0
57 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered)
58 size <- newIORef (0,0)
59 ppls <- newIORef $ V.singleton Nothing
60 return $ GLPipelineInput
61 { schema = sch
62 , slotMap = sm
63 , slotVector = slotV
64 , objSeed = seed
65 , uniformSetter = setters
66 , uniformSetup = unis
67 , screenSize = size
68 , pipelines = ppls
69 }
70
71-- object
72addObject :: GLPipelineInput -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
73addObject input slotName prim indices attribs uniformNames = do
74 let sch = schema input
75 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
76 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
77 _ -> return ()
78 case T.lookup slotName (T.slots sch) of
79 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
80 Just (SlotSchema sPrim sAttrs) -> do
81 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
82 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
83 let sType = fmap streamToStreamType attribs
84 when (sType /= sAttrs) $ throw $ userError $ unlines $
85 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
86 , show sAttrs
87 , " but got "
88 , show sType
89 ]
90
91 let slotIdx = case slotName `T.lookup` slotMap input of
92 Nothing -> error $ "internal error (slot index): " ++ show slotName
93 Just i -> i
94 seed = objSeed input
95 order <- newIORef 0
96 enabled <- newIORef True
97 index <- readIORef seed
98 modifyIORef seed (1+)
99 (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = T.lookup n (uniforms sch)]
100 cmdsRef <- newIORef (V.singleton V.empty)
101 let obj = Object
102 { objSlot = slotIdx
103 , objPrimitive = prim
104 , objIndices = indices
105 , objAttributes = attribs
106 , objUniSetter = setters
107 , objUniSetup = unis
108 , objOrder = order
109 , objEnabled = enabled
110 , objId = index
111 , objCommands = cmdsRef
112 }
113
114 modifyIORef (slotVector input ! slotIdx) $ \(GLSlot objs _ _) -> GLSlot (IM.insert index obj objs) V.empty Generate
115
116 -- generate GLObjectCommands for the new object
117 {-
118 foreach pipeline:
119 foreach realted program:
120 generate commands
121 -}
122 ppls <- readIORef $ pipelines input
123 let topUnis = uniformSetup input
124 cmds <- V.forM ppls $ \mp -> case mp of
125 Nothing -> return V.empty
126 Just p -> do
127 Just ic <- readIORef $ glInput p
128 case icSlotMapInputToPipeline ic ! slotIdx of
129 Nothing -> do
130 putStrLn $ " ** slot is not used!"
131 return V.empty -- this slot is not used in that pipeline
132 Just pSlotIdx -> do
133 putStrLn "slot is used!"
134 --where
135 let emptyV = V.replicate (V.length $ glPrograms p) []
136 return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx]
137 writeIORef cmdsRef cmds
138 return obj
139
140removeObject :: GLPipelineInput -> Object -> IO ()
141removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate
142
143enableObject :: Object -> Bool -> IO ()
144enableObject obj b = writeIORef (objEnabled obj) b
145
146setObjectOrder :: GLPipelineInput -> Object -> Int -> IO ()
147setObjectOrder p obj i = do
148 writeIORef (objOrder obj) i
149 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
150
151objectUniformSetter :: Object -> Trie InputSetter
152objectUniformSetter = objUniSetter
153
154setScreenSize :: GLPipelineInput -> Word -> Word -> IO ()
155setScreenSize p w h = writeIORef (screenSize p) (w,h)
156
157sortSlotObjects :: GLPipelineInput -> IO ()
158sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do
159 GLSlot objMap sortedV ord <- readIORef slotRef
160 let cmpFun (a,_) (b,_) = a `compare` b
161 doSort objs = do
162 ordObjsM <- V.thaw objs
163 I.sortBy cmpFun ordObjsM
164 ordObjs <- V.freeze ordObjsM
165 writeIORef slotRef (GLSlot objMap ordObjs Ordered)
166 case ord of
167 Ordered -> return ()
168 Generate -> do
169 objs <- V.forM (V.fromList $ IM.elems objMap) $ \obj -> do
170 ord <- readIORef $ objOrder obj
171 return (ord,obj)
172 doSort objs
173 Reorder -> do
174 objs <- V.forM sortedV $ \(_,obj) -> do
175 ord <- readIORef $ objOrder obj
176 return (ord,obj)
177 doSort objs
178
179createObjectCommands :: Trie (IORef GLint) -> Trie GLUniform -> Object -> GLProgram -> [GLObjectCommand]
180createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd]
181 where
182 -- object draw command
183 objDrawCmd = case objIndices obj of
184 Nothing -> GLDrawArrays prim 0 (fromIntegral count)
185 Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
186 where
187 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
188 idxType = arrayTypeToGLType arrType
189 ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
190 where
191 objAttrs = objAttributes obj
192 prim = primitiveToGLType $ objPrimitive obj
193 count = head [c | Stream _ _ _ _ c <- T.elems objAttrs]
194
195 -- object uniform commands
196 -- texture slot setup commands
197 objUniCmds = uniCmds ++ texCmds
198 where
199 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis]
200 uniMap = T.toList $ inputUniforms prg
201 topUni n = T.lookupWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis
202 objUnis = objUniSetup obj
203 texUnis = S.toList $ inputTextureUniforms prg
204 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
205 | n <- texUnis
206 , let u = T.lookupWithDefault (topUni n) n objUnis
207 , let texUnit = T.lookupWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
208 ]
209 uniInputType (GLUniform ty _) = ty
210
211 -- object attribute stream commands
212 objStreamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name objAttrs]
213 where
214 attrMap = inputStreams prg
215 objAttrs = objAttributes obj
216 attrCmd i s = case s of
217 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
218 TWord -> setIntAttrib 1
219 TV2U -> setIntAttrib 2
220 TV3U -> setIntAttrib 3
221 TV4U -> setIntAttrib 4
222 TInt -> setIntAttrib 1
223 TV2I -> setIntAttrib 2
224 TV3I -> setIntAttrib 3
225 TV4I -> setIntAttrib 4
226 TFloat -> setFloatAttrib 1
227 TV2F -> setFloatAttrib 2
228 TV3F -> setFloatAttrib 3
229 TV4F -> setFloatAttrib 4
230 TM22F -> setFloatAttrib 4
231 TM23F -> setFloatAttrib 6
232 TM24F -> setFloatAttrib 8
233 TM32F -> setFloatAttrib 6
234 TM33F -> setFloatAttrib 9
235 TM34F -> setFloatAttrib 12
236 TM42F -> setFloatAttrib 8
237 TM43F -> setFloatAttrib 12
238 TM44F -> setFloatAttrib 16
239 where
240 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
241 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
242 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
243 glType = arrayTypeToGLType arrType
244 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
245
246 -- constant generic attribute
247 constAttr -> GLSetVertexAttrib i constAttr
248
249nullSetter :: ByteString -> String -> a -> IO ()
250--nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
251nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
252
253uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool
254uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B
255uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B
256uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B
257
258uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32
259uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U
260uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U
261uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U
262
263uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32
264uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I
265uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I
266uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I
267
268uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float
269uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F
270uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F
271uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F
272
273uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F
274uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F
275uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F
276uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F
277uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F
278uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F
279uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F
280uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F
281uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F
282
283uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData
284
285uniformBool n is = case T.lookup n is of
286 Just (SBool fun) -> fun
287 _ -> nullSetter n "Bool"
288
289uniformV2B n is = case T.lookup n is of
290 Just (SV2B fun) -> fun
291 _ -> nullSetter n "V2B"
292
293uniformV3B n is = case T.lookup n is of
294 Just (SV3B fun) -> fun
295 _ -> nullSetter n "V3B"
296
297uniformV4B n is = case T.lookup n is of
298 Just (SV4B fun) -> fun
299 _ -> nullSetter n "V4B"
300
301uniformWord n is = case T.lookup n is of
302 Just (SWord fun) -> fun
303 _ -> nullSetter n "Word"
304
305uniformV2U n is = case T.lookup n is of
306 Just (SV2U fun) -> fun
307 _ -> nullSetter n "V2U"
308
309uniformV3U n is = case T.lookup n is of
310 Just (SV3U fun) -> fun
311 _ -> nullSetter n "V3U"
312
313uniformV4U n is = case T.lookup n is of
314 Just (SV4U fun) -> fun
315 _ -> nullSetter n "V4U"
316
317uniformInt n is = case T.lookup n is of
318 Just (SInt fun) -> fun
319 _ -> nullSetter n "Int"
320
321uniformV2I n is = case T.lookup n is of
322 Just (SV2I fun) -> fun
323 _ -> nullSetter n "V2I"
324
325uniformV3I n is = case T.lookup n is of
326 Just (SV3I fun) -> fun
327 _ -> nullSetter n "V3I"
328
329uniformV4I n is = case T.lookup n is of
330 Just (SV4I fun) -> fun
331 _ -> nullSetter n "V4I"
332
333uniformFloat n is = case T.lookup n is of
334 Just (SFloat fun) -> fun
335 _ -> nullSetter n "Float"
336
337uniformV2F n is = case T.lookup n is of
338 Just (SV2F fun) -> fun
339 _ -> nullSetter n "V2F"
340
341uniformV3F n is = case T.lookup n is of
342 Just (SV3F fun) -> fun
343 _ -> nullSetter n "V3F"
344
345uniformV4F n is = case T.lookup n is of
346 Just (SV4F fun) -> fun
347 _ -> nullSetter n "V4F"
348
349uniformM22F n is = case T.lookup n is of
350 Just (SM22F fun) -> fun
351 _ -> nullSetter n "M22F"
352
353uniformM23F n is = case T.lookup n is of
354 Just (SM23F fun) -> fun
355 _ -> nullSetter n "M23F"
356
357uniformM24F n is = case T.lookup n is of
358 Just (SM24F fun) -> fun
359 _ -> nullSetter n "M24F"
360
361uniformM32F n is = case T.lookup n is of
362 Just (SM32F fun) -> fun
363 _ -> nullSetter n "M32F"
364
365uniformM33F n is = case T.lookup n is of
366 Just (SM33F fun) -> fun
367 _ -> nullSetter n "M33F"
368
369uniformM34F n is = case T.lookup n is of
370 Just (SM34F fun) -> fun
371 _ -> nullSetter n "M34F"
372
373uniformM42F n is = case T.lookup n is of
374 Just (SM42F fun) -> fun
375 _ -> nullSetter n "M42F"
376
377uniformM43F n is = case T.lookup n is of
378 Just (SM43F fun) -> fun
379 _ -> nullSetter n "M43F"
380
381uniformM44F n is = case T.lookup n is of
382 Just (SM44F fun) -> fun
383 _ -> nullSetter n "M44F"
384
385uniformFTexture2D n is = case T.lookup n is of
386 Just (SFTexture2D fun) -> fun
387 _ -> nullSetter n "FTexture2D"
diff --git a/Backend/GL/Mesh.hs b/Backend/GL/Mesh.hs
deleted file mode 100644
index 4539622..0000000
--- a/Backend/GL/Mesh.hs
+++ /dev/null
@@ -1,238 +0,0 @@
1{-# LANGUAGE TupleSections #-}
2module Backend.GL.Mesh (
3 loadMesh',
4 loadMesh,
5 saveMesh,
6 addMesh,
7 compileMesh,
8 updateMesh,
9 Mesh(..),
10 MeshPrimitive(..),
11 MeshAttribute(..),
12 GPUData
13) where
14
15import Control.Applicative
16import Control.Monad
17import Data.Binary
18import Data.ByteString.Char8 (ByteString)
19import Foreign.Ptr
20import Data.Int
21import Foreign.Storable
22import Foreign.Marshal.Utils
23import System.IO.Unsafe
24import qualified Data.ByteString.Char8 as SB
25import qualified Data.ByteString.Lazy as LB
26import qualified Data.Trie as T
27import qualified Data.Vector.Storable as V
28import qualified Data.Vector.Storable.Mutable as MV
29
30import Backend.GL
31import Backend.GL.Type as T
32import IR as IR
33import Linear as IR
34
35fileVersion :: Int32
36fileVersion = 1
37
38data MeshAttribute
39 = A_Float (V.Vector Float)
40 | A_V2F (V.Vector V2F)
41 | A_V3F (V.Vector V3F)
42 | A_V4F (V.Vector V4F)
43 | A_M22F (V.Vector M22F)
44 | A_M33F (V.Vector M33F)
45 | A_M44F (V.Vector M44F)
46 | A_Int (V.Vector Int32)
47 | A_Word (V.Vector Word32)
48
49data MeshPrimitive
50 = P_Points
51 | P_TriangleStrip
52 | P_Triangles
53 | P_TriangleStripI (V.Vector Int32)
54 | P_TrianglesI (V.Vector Int32)
55
56data Mesh
57 = Mesh
58 { mAttributes :: T.Trie MeshAttribute
59 , mPrimitive :: MeshPrimitive
60 , mGPUData :: Maybe GPUData
61 }
62
63data GPUData
64 = GPUData
65 { dPrimitive :: Primitive
66 , dStreams :: T.Trie (Stream Buffer)
67 , dIndices :: Maybe (IndexStream Buffer)
68 }
69
70loadMesh' :: String -> IO Mesh
71loadMesh' n = decode <$> LB.readFile n
72
73loadMesh :: String -> IO Mesh
74loadMesh n = compileMesh =<< loadMesh' n
75
76saveMesh :: String -> Mesh -> IO ()
77saveMesh n m = LB.writeFile n (encode m)
78
79addMesh :: GLPipelineInput -> ByteString -> Mesh -> [ByteString] -> IO Object
80addMesh input slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = do
81 -- select proper attributes
82 let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input
83 filterStream n s
84 | T.member n slotStreams = Just s
85 | otherwise = Nothing
86 addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames
87addMesh _ _ _ _ = fail "addMesh: only compiled mesh with GPUData is supported"
88
89withV w a f = w a (\p -> f $ castPtr p)
90
91meshAttrToArray :: MeshAttribute -> Array
92meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v
93meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v
94meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v
95meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v
96meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v
97meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v
98meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v
99meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v
100meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v
101
102meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
103meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v)
104meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v)
105meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v)
106meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v)
107meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v)
108meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v)
109meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v)
110meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v)
111meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v)
112
113{-
114updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
115
116 | Stream
117 { streamType :: StreamType
118 , streamBuffer :: b
119 , streamArrIdx :: Int
120 , streamStart :: Int
121 , streamLength :: Int
122 }
123
124-- stream of index values (for index buffer)
125data IndexStream b
126 = IndexStream
127 { indexBuffer :: b
128 , indexArrIdx :: Int
129 , indexStart :: Int
130 , indexLength :: Int
131 }
132-}
133updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()
134updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
135 -- check type match
136 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
137 ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA]
138 if not ok then putStrLn "updateMesh: attribute mismatch!"
139 else do
140 forM_ al $ \(n,a) -> do
141 case T.lookup n dS of
142 Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]
143 _ -> return ()
144{-
145 case mp of
146 Nothing -> return ()
147 Just p -> do
148 let ok2 = case (dMP,p) of
149 (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2
150 (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2
151 (a,b) -> a == b
152-}
153
154compileMesh :: Mesh -> IO Mesh
155compileMesh (Mesh attrs mPrim Nothing) = do
156 let mkIndexBuf v = do
157 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]
158 return $! Just $! IndexStream iBuf 0 0 (V.length v)
159 vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs]
160 (indices,prim) <- case mPrim of
161 P_Points -> return (Nothing,PointList)
162 P_TriangleStrip -> return (Nothing,TriangleStrip)
163 P_Triangles -> return (Nothing,TriangleList)
164 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v
165 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v
166 let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs)
167 gpuData = GPUData prim streams indices
168 return $! Mesh attrs mPrim (Just gpuData)
169
170compileMesh mesh = return mesh
171
172sblToV :: Storable a => [SB.ByteString] -> V.Vector a
173sblToV ls = v
174 where
175 offs o (s:xs) = (o,s):offs (o + SB.length s) xs
176 offs _ [] = []
177 cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v)
178 v = unsafePerformIO $ do
179 mv <- MV.new cnt
180 MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) ->
181 SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len
182 V.unsafeFreeze mv
183
184vToSB :: Storable a => V.Vector a -> SB.ByteString
185vToSB v = unsafePerformIO $ do
186 let len = V.length v * sizeOf (V.head v)
187 V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len)
188
189instance Storable a => Binary (V.Vector a) where
190 put v = put $ vToSB v
191 get = do s <- get ; return $ sblToV [s]
192
193instance Binary MeshAttribute where
194 put (A_Float a) = putWord8 0 >> put a
195 put (A_V2F a) = putWord8 1 >> put a
196 put (A_V3F a) = putWord8 2 >> put a
197 put (A_V4F a) = putWord8 3 >> put a
198 put (A_M22F a) = putWord8 4 >> put a
199 put (A_M33F a) = putWord8 5 >> put a
200 put (A_M44F a) = putWord8 6 >> put a
201 put (A_Int a) = putWord8 7 >> put a
202 put (A_Word a) = putWord8 8 >> put a
203 get = do
204 tag_ <- getWord8
205 case tag_ of
206 0 -> A_Float <$> get
207 1 -> A_V2F <$> get
208 2 -> A_V3F <$> get
209 3 -> A_V4F <$> get
210 4 -> A_M22F <$> get
211 5 -> A_M33F <$> get
212 6 -> A_M44F <$> get
213 7 -> A_Int <$> get
214 8 -> A_Word <$> get
215 _ -> fail "no parse"
216
217instance Binary MeshPrimitive where
218 put P_Points = putWord8 0
219 put P_TriangleStrip = putWord8 1
220 put P_Triangles = putWord8 2
221 put (P_TriangleStripI a) = putWord8 3 >> put a
222 put (P_TrianglesI a) = putWord8 4 >> put a
223 get = do
224 tag_ <- getWord8
225 case tag_ of
226 0 -> return P_Points
227 1 -> return P_TriangleStrip
228 2 -> return P_Triangles
229 3 -> P_TriangleStripI <$> get
230 4 -> P_TrianglesI <$> get
231 _ -> fail "no parse"
232
233instance Binary Mesh where
234 put (Mesh a b _) = put (T.toList a) >> put b
235 get = do
236 a <- get
237 b <- get
238 return $! Mesh (T.fromList a) b Nothing
diff --git a/Backend/GL/Type.hs b/Backend/GL/Type.hs
deleted file mode 100644
index f420e74..0000000
--- a/Backend/GL/Type.hs
+++ /dev/null
@@ -1,541 +0,0 @@
1{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2module Backend.GL.Type where
3
4import Data.ByteString.Char8 (ByteString)
5import Data.IORef
6import Data.Int
7import Data.IntMap (IntMap)
8import Data.Set (Set)
9import Data.Trie (Trie)
10import Data.Vector (Vector)
11import Data.Word
12import Foreign.Ptr
13import Foreign.Storable
14
15import Graphics.Rendering.OpenGL.Raw.Core33
16
17import Linear
18import IR
19
20---------------
21-- Input API --
22---------------
23{-
24-- Buffer
25 compileBuffer :: [Array] -> IO Buffer
26 bufferSize :: Buffer -> Int
27 arraySize :: Buffer -> Int -> Int
28 arrayType :: Buffer -> Int -> ArrayType
29
30-- Object
31 addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
32 removeObject :: Renderer -> Object -> IO ()
33 objectUniformSetter :: Object -> Trie InputSetter
34-}
35
36data Buffer -- internal type
37 = Buffer
38 { bufArrays :: Vector ArrayDesc
39 , bufGLObj :: GLuint
40 }
41 deriving (Show,Eq)
42
43data ArrayDesc
44 = ArrayDesc
45 { arrType :: ArrayType
46 , arrLength :: Int -- item count
47 , arrOffset :: Int -- byte position in buffer
48 , arrSize :: Int -- size in bytes
49 }
50 deriving (Show,Eq)
51
52{-
53 handles:
54 uniforms
55 textures
56 buffers
57 objects
58
59 GLPipelineInput can be attached to GLPipeline
60-}
61
62{-
63 pipeline input:
64 - independent from pipeline
65 - per object features: enable/disable visibility, set render ordering
66-}
67
68data SlotSchema
69 = SlotSchema
70 { primitive :: FetchPrimitive
71 , attributes :: Trie StreamType
72 }
73 deriving Show
74
75data PipelineSchema
76 = PipelineSchema
77 { slots :: Trie SlotSchema
78 , uniforms :: Trie InputType
79 }
80 deriving Show
81
82data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a)
83
84instance Show GLUniform where
85 show (GLUniform t _) = "GLUniform " ++ show t
86
87data OrderJob
88 = Generate
89 | Reorder
90 | Ordered
91
92data GLSlot
93 = GLSlot
94 { objectMap :: IntMap Object
95 , sortedObjects :: Vector (Int,Object)
96 , orderJob :: OrderJob
97 }
98
99data GLPipelineInput
100 = GLPipelineInput
101 { schema :: PipelineSchema
102 , slotMap :: Trie SlotName
103 , slotVector :: Vector (IORef GLSlot)
104 , objSeed :: IORef Int
105 , uniformSetter :: Trie InputSetter
106 , uniformSetup :: Trie GLUniform
107 , screenSize :: IORef (Word,Word)
108 , pipelines :: IORef (Vector (Maybe GLPipeline)) -- attached pipelines
109 }
110
111data Object -- internal type
112 = Object
113 { objSlot :: SlotName
114 , objPrimitive :: Primitive
115 , objIndices :: Maybe (IndexStream Buffer)
116 , objAttributes :: Trie (Stream Buffer)
117 , objUniSetter :: Trie InputSetter
118 , objUniSetup :: Trie GLUniform
119 , objOrder :: IORef Int
120 , objEnabled :: IORef Bool
121 , objId :: Int
122 , objCommands :: IORef (Vector (Vector [GLObjectCommand])) -- pipeline id, program name, commands
123 }
124
125--------------
126-- Pipeline --
127--------------
128
129data GLProgram
130 = GLProgram
131 { shaderObjects :: [GLuint]
132 , programObject :: GLuint
133 , inputUniforms :: Trie GLint
134 , inputTextures :: Trie GLint -- all input textures (render texture + uniform texture)
135 , inputTextureUniforms :: Set ByteString
136 , inputStreams :: Trie (GLuint,ByteString)
137 }
138
139data GLTexture
140 = GLTexture
141 { glTextureObject :: GLuint
142 , glTextureTarget :: GLenum
143 }
144
145data InputConnection
146 = InputConnection
147 { icId :: Int -- identifier (vector index) for attached pipeline
148 , icInput :: GLPipelineInput
149 , icSlotMapPipelineToInput :: Vector SlotName -- GLPipeline to GLPipelineInput slot name mapping
150 , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLPipelineInput to GLPipeline slot name mapping
151 }
152
153data GLStream
154 = GLStream
155 { glStreamCommands :: IORef [GLObjectCommand]
156 , glStreamPrimitive :: Primitive
157 , glStreamAttributes :: Trie (Stream Buffer)
158 , glStreamProgram :: ProgramName
159 }
160
161data GLPipeline
162 = GLPipeline
163 { glPrograms :: Vector GLProgram
164 , glTextures :: Vector GLTexture
165 , glSamplers :: Vector GLSampler
166 , glTargets :: Vector GLRenderTarget
167 , glCommands :: [GLCommand]
168 , glSlotPrograms :: Vector [ProgramName] -- programs depend on a slot
169 , glInput :: IORef (Maybe InputConnection)
170 , glSlotNames :: Vector ByteString
171 , glVAO :: GLuint
172 , glTexUnitMapping :: Trie (IORef GLint) -- maps texture uniforms to texture units
173 , glStreams :: Vector GLStream
174 }
175
176data GLSampler
177 = GLSampler
178 { samplerObject :: GLuint
179 }
180
181data GLRenderTarget
182 = GLRenderTarget
183 { framebufferObject :: GLuint
184 , framebufferDrawbuffers :: Maybe [GLenum]
185 }
186
187data GLCommand
188 = GLSetRasterContext !RasterContext
189 | GLSetAccumulationContext !AccumulationContext
190 | GLSetRenderTarget !GLuint !(Maybe [GLenum])
191 | GLSetProgram !GLuint
192 | GLSetSamplerUniform !GLint !GLint (IORef GLint) -- sampler index, texture unit, IORef stores the actual texture unit mapping
193 | GLSetTexture !GLenum !GLuint !GLuint
194 | GLSetSampler !GLuint !GLuint
195 | GLRenderSlot !SlotName !ProgramName
196 | GLRenderStream !StreamName !ProgramName
197 | GLClearRenderTarget [ClearImage]
198 | GLGenerateMipMap !GLenum !GLenum
199 | GLSaveImage FrameBufferComponent ImageRef -- from framebuffer component to texture (image)
200 | GLLoadImage ImageRef FrameBufferComponent -- from texture (image) to framebuffer component
201 deriving Show
202
203instance Show (IORef GLint) where
204 show _ = "(IORef GLint)"
205
206data GLObjectCommand
207 = GLSetUniform !GLint !GLUniform
208 | GLBindTexture !GLenum !(IORef GLint) !GLUniform -- binds the texture from the gluniform to the specified texture unit and target
209 | GLSetVertexAttribArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer
210 | GLSetVertexAttribIArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer
211 | GLSetVertexAttrib !GLuint !(Stream Buffer) -- index value
212 | GLDrawArrays !GLenum !GLint !GLsizei -- mode first count
213 | GLDrawElements !GLenum !GLsizei !GLenum !GLuint !(Ptr ()) -- mode count type buffer indicesPtr
214 deriving Show
215
216type SetterFun a = a -> IO ()
217
218-- user will provide scalar input data via this type
219data InputSetter
220 = SBool (SetterFun Bool)
221 | SV2B (SetterFun V2B)
222 | SV3B (SetterFun V3B)
223 | SV4B (SetterFun V4B)
224 | SWord (SetterFun Word32)
225 | SV2U (SetterFun V2U)
226 | SV3U (SetterFun V3U)
227 | SV4U (SetterFun V4U)
228 | SInt (SetterFun Int32)
229 | SV2I (SetterFun V2I)
230 | SV3I (SetterFun V3I)
231 | SV4I (SetterFun V4I)
232 | SFloat (SetterFun Float)
233 | SV2F (SetterFun V2F)
234 | SV3F (SetterFun V3F)
235 | SV4F (SetterFun V4F)
236 | SM22F (SetterFun M22F)
237 | SM23F (SetterFun M23F)
238 | SM24F (SetterFun M24F)
239 | SM32F (SetterFun M32F)
240 | SM33F (SetterFun M33F)
241 | SM34F (SetterFun M34F)
242 | SM42F (SetterFun M42F)
243 | SM43F (SetterFun M43F)
244 | SM44F (SetterFun M44F)
245 -- shadow textures
246 | SSTexture1D
247 | SSTexture2D
248 | SSTextureCube
249 | SSTexture1DArray
250 | SSTexture2DArray
251 | SSTexture2DRect
252 -- float textures
253 | SFTexture1D
254 | SFTexture2D (SetterFun TextureData)
255 | SFTexture3D
256 | SFTextureCube
257 | SFTexture1DArray
258 | SFTexture2DArray
259 | SFTexture2DMS
260 | SFTexture2DMSArray
261 | SFTextureBuffer
262 | SFTexture2DRect
263 -- int textures
264 | SITexture1D
265 | SITexture2D
266 | SITexture3D
267 | SITextureCube
268 | SITexture1DArray
269 | SITexture2DArray
270 | SITexture2DMS
271 | SITexture2DMSArray
272 | SITextureBuffer
273 | SITexture2DRect
274 -- uint textures
275 | SUTexture1D
276 | SUTexture2D
277 | SUTexture3D
278 | SUTextureCube
279 | SUTexture1DArray
280 | SUTexture2DArray
281 | SUTexture2DMS
282 | SUTexture2DMSArray
283 | SUTextureBuffer
284 | SUTexture2DRect
285
286-- buffer handling
287{-
288 user can fills a buffer (continuous memory region)
289 each buffer have a data descriptor, what describes the
290 buffer content. e.g. a buffer can contain more arrays of stream types
291-}
292
293-- user will provide stream data using this setup function
294type BufferSetter = (Ptr () -> IO ()) -> IO ()
295
296-- specifies array component type (stream type in storage side)
297-- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also
298data ArrayType
299 = ArrWord8
300 | ArrWord16
301 | ArrWord32
302 | ArrInt8
303 | ArrInt16
304 | ArrInt32
305 | ArrFloat
306 | ArrHalf -- Hint: half float is not supported in haskell
307 deriving (Show,Eq,Ord)
308
309sizeOfArrayType :: ArrayType -> Int
310sizeOfArrayType ArrWord8 = 1
311sizeOfArrayType ArrWord16 = 2
312sizeOfArrayType ArrWord32 = 4
313sizeOfArrayType ArrInt8 = 1
314sizeOfArrayType ArrInt16 = 2
315sizeOfArrayType ArrInt32 = 4
316sizeOfArrayType ArrFloat = 4
317sizeOfArrayType ArrHalf = 2
318
319-- describes an array in a buffer
320data Array -- array type, element count (NOT byte size!), setter
321 = Array ArrayType Int BufferSetter
322
323-- dev hint: this should be InputType
324-- we restrict StreamType using type class
325-- subset of InputType, describes a stream type (in GPU side)
326data StreamType
327 = TWord
328 | TV2U
329 | TV3U
330 | TV4U
331 | TInt
332 | TV2I
333 | TV3I
334 | TV4I
335 | TFloat
336 | TV2F
337 | TV3F
338 | TV4F
339 | TM22F
340 | TM23F
341 | TM24F
342 | TM32F
343 | TM33F
344 | TM34F
345 | TM42F
346 | TM43F
347 | TM44F
348 deriving (Show,Eq,Ord)
349
350toStreamType :: InputType -> Maybe StreamType
351toStreamType Word = Just TWord
352toStreamType V2U = Just TV2U
353toStreamType V3U = Just TV3U
354toStreamType V4U = Just TV4U
355toStreamType Int = Just TInt
356toStreamType V2I = Just TV2I
357toStreamType V3I = Just TV3I
358toStreamType V4I = Just TV4I
359toStreamType Float = Just TFloat
360toStreamType V2F = Just TV2F
361toStreamType V3F = Just TV3F
362toStreamType V4F = Just TV4F
363toStreamType M22F = Just TM22F
364toStreamType M23F = Just TM23F
365toStreamType M24F = Just TM24F
366toStreamType M32F = Just TM32F
367toStreamType M33F = Just TM33F
368toStreamType M34F = Just TM34F
369toStreamType M42F = Just TM42F
370toStreamType M43F = Just TM43F
371toStreamType M44F = Just TM44F
372toStreamType _ = Nothing
373
374fromStreamType :: StreamType -> InputType
375fromStreamType TWord = Word
376fromStreamType TV2U = V2U
377fromStreamType TV3U = V3U
378fromStreamType TV4U = V4U
379fromStreamType TInt = Int
380fromStreamType TV2I = V2I
381fromStreamType TV3I = V3I
382fromStreamType TV4I = V4I
383fromStreamType TFloat = Float
384fromStreamType TV2F = V2F
385fromStreamType TV3F = V3F
386fromStreamType TV4F = V4F
387fromStreamType TM22F = M22F
388fromStreamType TM23F = M23F
389fromStreamType TM24F = M24F
390fromStreamType TM32F = M32F
391fromStreamType TM33F = M33F
392fromStreamType TM34F = M34F
393fromStreamType TM42F = M42F
394fromStreamType TM43F = M43F
395fromStreamType TM44F = M44F
396
397-- user can specify streams using Stream type
398-- a stream can be constant (ConstXXX) or can came from a buffer
399data Stream b
400 = ConstWord Word32
401 | ConstV2U V2U
402 | ConstV3U V3U
403 | ConstV4U V4U
404 | ConstInt Int32
405 | ConstV2I V2I
406 | ConstV3I V3I
407 | ConstV4I V4I
408 | ConstFloat Float
409 | ConstV2F V2F
410 | ConstV3F V3F
411 | ConstV4F V4F
412 | ConstM22F M22F
413 | ConstM23F M23F
414 | ConstM24F M24F
415 | ConstM32F M32F
416 | ConstM33F M33F
417 | ConstM34F M34F
418 | ConstM42F M42F
419 | ConstM43F M43F
420 | ConstM44F M44F
421 | Stream
422 { streamType :: StreamType
423 , streamBuffer :: b
424 , streamArrIdx :: Int
425 , streamStart :: Int
426 , streamLength :: Int
427 }
428 deriving Show
429
430streamToStreamType :: Stream a -> StreamType
431streamToStreamType s = case s of
432 ConstWord _ -> TWord
433 ConstV2U _ -> TV2U
434 ConstV3U _ -> TV3U
435 ConstV4U _ -> TV4U
436 ConstInt _ -> TInt
437 ConstV2I _ -> TV2I
438 ConstV3I _ -> TV3I
439 ConstV4I _ -> TV4I
440 ConstFloat _ -> TFloat
441 ConstV2F _ -> TV2F
442 ConstV3F _ -> TV3F
443 ConstV4F _ -> TV4F
444 ConstM22F _ -> TM22F
445 ConstM23F _ -> TM23F
446 ConstM24F _ -> TM24F
447 ConstM32F _ -> TM32F
448 ConstM33F _ -> TM33F
449 ConstM34F _ -> TM34F
450 ConstM42F _ -> TM42F
451 ConstM43F _ -> TM43F
452 ConstM44F _ -> TM44F
453 Stream t _ _ _ _ -> t
454
455-- stream of index values (for index buffer)
456data IndexStream b
457 = IndexStream
458 { indexBuffer :: b
459 , indexArrIdx :: Int
460 , indexStart :: Int
461 , indexLength :: Int
462 }
463
464newtype TextureData
465 = TextureData
466 { textureObject :: GLuint
467 }
468 deriving Storable
469
470data Primitive
471 = TriangleStrip
472 | TriangleList
473 | TriangleFan
474 | LineStrip
475 | LineList
476 | PointList
477 | TriangleStripAdjacency
478 | TriangleListAdjacency
479 | LineStripAdjacency
480 | LineListAdjacency
481 deriving (Eq,Ord,Bounded,Enum,Show)
482
483type StreamSetter = Stream Buffer -> IO ()
484
485-- storable instances
486instance Storable a => Storable (V2 a) where
487 sizeOf _ = 2 * sizeOf (undefined :: a)
488 alignment _ = sizeOf (undefined :: a)
489
490 peek q = do
491 let p = castPtr q :: Ptr a
492 k = sizeOf (undefined :: a)
493 x <- peek p
494 y <- peekByteOff p k
495 return $! (V2 x y)
496
497 poke q (V2 x y) = do
498 let p = castPtr q :: Ptr a
499 k = sizeOf (undefined :: a)
500 poke p x
501 pokeByteOff p k y
502
503instance Storable a => Storable (V3 a) where
504 sizeOf _ = 3 * sizeOf (undefined :: a)
505 alignment _ = sizeOf (undefined :: a)
506
507 peek q = do
508 let p = castPtr q :: Ptr a
509 k = sizeOf (undefined :: a)
510 x <- peek p
511 y <- peekByteOff p k
512 z <- peekByteOff p (k*2)
513 return $! (V3 x y z)
514
515 poke q (V3 x y z) = do
516 let p = castPtr q :: Ptr a
517 k = sizeOf (undefined :: a)
518 poke p x
519 pokeByteOff p k y
520 pokeByteOff p (k*2) z
521
522instance Storable a => Storable (V4 a) where
523 sizeOf _ = 4 * sizeOf (undefined :: a)
524 alignment _ = sizeOf (undefined :: a)
525
526 peek q = do
527 let p = castPtr q :: Ptr a
528 k = sizeOf (undefined :: a)
529 x <- peek p
530 y <- peekByteOff p k
531 z <- peekByteOff p (k*2)
532 w <- peekByteOff p (k*3)
533 return $! (V4 x y z w)
534
535 poke q (V4 x y z w) = do
536 let p = castPtr q :: Ptr a
537 k = sizeOf (undefined :: a)
538 poke p x
539 pokeByteOff p k y
540 pokeByteOff p (k*2) z
541 pokeByteOff p (k*3) w
diff --git a/Backend/GL/Util.hs b/Backend/GL/Util.hs
deleted file mode 100644
index 75c2e3a..0000000
--- a/Backend/GL/Util.hs
+++ /dev/null
@@ -1,719 +0,0 @@
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 Linear
51import IR
52import Backend.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 = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I]
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-11-09 09:07:50 +0000