summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL')
-rw-r--r--src/LambdaCube/GL/Backend.hs814
-rw-r--r--src/LambdaCube/GL/Data.hs113
-rw-r--r--src/LambdaCube/GL/Input.hs390
-rw-r--r--src/LambdaCube/GL/Mesh.hs218
-rw-r--r--src/LambdaCube/GL/Type.hs541
-rw-r--r--src/LambdaCube/GL/Util.hs719
6 files changed, 2795 insertions, 0 deletions
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
new file mode 100644
index 0000000..7251a78
--- /dev/null
+++ b/src/LambdaCube/GL/Backend.hs
@@ -0,0 +1,814 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-}
2module LambdaCube.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.GL.Core33
27import Foreign
28
29-- LC IR imports
30import Linear
31import IR hiding (streamType)
32import qualified IR as IR
33
34import LambdaCube.GL.Type
35import LambdaCube.GL.Util
36
37import LambdaCube.GL.Data
38import LambdaCube.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 {} -- TODO
273
274compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
275compileRenderTarget texs glTexs (RenderTarget targets) = do
276 let isFB (Framebuffer _) = True
277 isFB _ = False
278 images = [img | TargetItem _ (Just img) <- V.toList targets]
279 case all isFB images of
280 True -> do
281 let bufs = [cvt img | TargetItem Color img <- V.toList targets]
282 cvt a = case a of
283 Nothing -> GL_NONE
284 Just (Framebuffer Color) -> GL_BACK_LEFT
285 _ -> error "internal error (compileRenderTarget)!"
286 return $ GLRenderTarget
287 { framebufferObject = 0
288 , framebufferDrawbuffers = Just bufs
289 }
290 False -> do
291 when (any isFB images) $ fail "internal error (compileRenderTarget)!"
292 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
293 glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo
294 {-
295 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
296 GL_TEXTURE_1D
297 void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
298 GL_TEXTURE_2D
299 GL_TEXTURE_RECTANGLE
300 GL_TEXTURE_CUBE_MAP_POSITIVE_X
301 GL_TEXTURE_CUBE_MAP_POSITIVE_Y
302 GL_TEXTURE_CUBE_MAP_POSITIVE_Z
303 GL_TEXTURE_CUBE_MAP_NEGATIVE_X
304 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
305 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
306 GL_TEXTURE_2D_MULTISAMPLE
307 void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer);
308 void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer);
309 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);
310 -}
311 let attach attachment (TextureImage texIdx level (Just layer)) =
312 glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
313 attach attachment (TextureImage texIdx level Nothing) = do
314 let glTex = glTexs ! texIdx
315 tex = texs ! texIdx
316 txLevel = fromIntegral level
317 txTarget = glTextureTarget glTex
318 txObj = glTextureObject glTex
319 attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel
320 attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
321 case textureType tex of
322 Texture1D _ n
323 | n > 1 -> attachArray
324 | otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
325 Texture2D _ n
326 | n > 1 -> attachArray
327 | otherwise -> attach2D
328 Texture3D _ -> attachArray
329 TextureCube _ -> attachArray
330 TextureRect _ -> attach2D
331 Texture2DMS _ n _ _
332 | n > 1 -> attachArray
333 | otherwise -> attach2D
334 TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"
335
336 go a (TargetItem Stencil (Just img)) = do
337 fail "Stencil support is not implemented yet!"
338 return a
339 go a (TargetItem Depth (Just img)) = do
340 attach GL_DEPTH_ATTACHMENT img
341 return a
342 go (bufs,colorIdx) (TargetItem Color (Just img)) = do
343 let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx
344 attach attachment img
345 return (attachment : bufs, colorIdx + 1)
346 go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1)
347 go a _ = return a
348 (bufs,_) <- foldM go ([],0) targets
349 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
350 return $ GLRenderTarget
351 { framebufferObject = fbo
352 , framebufferDrawbuffers = Nothing
353 }
354
355compileStreamData :: StreamData -> IO GLStream
356compileStreamData s = do
357 let withV w a f = w a (\p -> f $ castPtr p)
358 let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)
359 compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
360 compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
361 --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v)
362 (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]
363 getLength n = l `div` c
364 where
365 l = case Map.lookup n $ IR.streamData s of
366 Just (VFloatArray v) -> V.length v
367 Just (VIntArray v) -> V.length v
368 Just (VWordArray v) -> V.length v
369 _ -> error "compileStreamData - getLength"
370 c = case Map.lookup n $ IR.streamType s of
371 Just Bool -> 1
372 Just V2B -> 2
373 Just V3B -> 3
374 Just V4B -> 4
375 Just Word -> 1
376 Just V2U -> 2
377 Just V3U -> 3
378 Just V4U -> 4
379 Just Int -> 1
380 Just V2I -> 2
381 Just V3I -> 3
382 Just V4I -> 4
383 Just Float -> 1
384 Just V2F -> 2
385 Just V3F -> 3
386 Just V4F -> 4
387 Just M22F -> 4
388 Just M23F -> 6
389 Just M24F -> 8
390 Just M32F -> 6
391 Just M33F -> 9
392 Just M34F -> 12
393 Just M42F -> 8
394 Just M43F -> 12
395 Just M44F -> 16
396 _ -> error "compileStreamData - getLength element count"
397 buffer <- compileBuffer arrays
398 cmdRef <- newIORef []
399 let toStream (n,i) = (n,Stream
400 { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s)
401 , streamBuffer = buffer
402 , streamArrIdx = i
403 , streamStart = 0
404 , streamLength = getLength n
405 })
406 return $ GLStream
407 { glStreamCommands = cmdRef
408 , glStreamPrimitive = case streamPrimitive s of
409 Points -> PointList
410 Lines -> LineList
411 Triangles -> TriangleList
412 LinesAdjacency -> LineListAdjacency
413 TrianglesAdjacency -> TriangleListAdjacency
414 , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap
415 , glStreamProgram = V.head $ streamPrograms s
416 }
417
418createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
419createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]
420 where
421 -- object draw command
422 drawCmd = GLDrawArrays prim 0 (fromIntegral count)
423 where
424 prim = primitiveToGLType primitive
425 count = head [c | Stream _ _ _ _ c <- T.elems attrs]
426
427 -- object uniform commands
428 -- texture slot setup commands
429 streamUniCmds = uniCmds ++ texCmds
430 where
431 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n]
432 uniMap = T.toList $ inputUniforms prg
433 topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis
434 texUnis = S.toList $ inputTextureUniforms prg
435 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
436 | n <- texUnis
437 , let u = topUni n
438 , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
439 ]
440 uniInputType (GLUniform ty _) = ty
441
442 -- object attribute stream commands
443 streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs]
444 where
445 attrMap = inputStreams prg
446 attrCmd i s = case s of
447 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
448 Attribute_Word -> setIntAttrib 1
449 Attribute_V2U -> setIntAttrib 2
450 Attribute_V3U -> setIntAttrib 3
451 Attribute_V4U -> setIntAttrib 4
452 Attribute_Int -> setIntAttrib 1
453 Attribute_V2I -> setIntAttrib 2
454 Attribute_V3I -> setIntAttrib 3
455 Attribute_V4I -> setIntAttrib 4
456 Attribute_Float -> setFloatAttrib 1
457 Attribute_V2F -> setFloatAttrib 2
458 Attribute_V3F -> setFloatAttrib 3
459 Attribute_V4F -> setFloatAttrib 4
460 Attribute_M22F -> setFloatAttrib 4
461 Attribute_M23F -> setFloatAttrib 6
462 Attribute_M24F -> setFloatAttrib 8
463 Attribute_M32F -> setFloatAttrib 6
464 Attribute_M33F -> setFloatAttrib 9
465 Attribute_M34F -> setFloatAttrib 12
466 Attribute_M42F -> setFloatAttrib 8
467 Attribute_M43F -> setFloatAttrib 12
468 Attribute_M44F -> setFloatAttrib 16
469 where
470 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
471 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
472 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
473 glType = arrayTypeToGLType arrType
474 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
475
476 -- constant generic attribute
477 constAttr -> GLSetVertexAttrib i constAttr
478
479allocRenderer :: Pipeline -> IO GLRenderer
480allocRenderer p = do
481 let uniTrie = uniforms $ schemaFromPipeline p
482 smps <- V.mapM compileSampler $ samplers p
483 texs <- V.mapM compileTexture $ textures p
484 trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
485 prgs <- V.mapM (compileProgram uniTrie) $ programs p
486 -- texture unit mapping ioref trie
487 -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
488 texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p)
489 let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState
490 input <- newIORef Nothing
491 -- default Vertex Array Object
492 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
493 strs <- V.mapM compileStreamData $ streams p
494 return $ GLRenderer
495 { glPrograms = prgs
496 , glTextures = texs
497 , glSamplers = smps
498 , glTargets = trgs
499 , glCommands = cmds
500 , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p
501 , glInput = input
502 , glSlotNames = V.map (pack . slotName) $ IR.slots p
503 , glVAO = vao
504 , glTexUnitMapping = texUnitMapRefs
505 , glStreams = strs
506 }
507
508disposeRenderer :: GLRenderer -> IO ()
509disposeRenderer p = do
510 setStorage' p Nothing
511 V.forM_ (glPrograms p) $ \prg -> do
512 glDeleteProgram $ programObject prg
513 mapM_ glDeleteShader $ shaderObjects prg
514 let targets = glTargets p
515 withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
516 let textures = glTextures p
517 withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
518 with (glVAO p) $ (glDeleteVertexArrays 1)
519
520{-
521data SlotSchema
522 = SlotSchema
523 { primitive :: FetchPrimitive
524 , attributes :: Trie StreamType
525 }
526 deriving Show
527
528data PipelineSchema
529 = PipelineSchema
530 { slots :: Trie SlotSchema
531 , uniforms :: Trie InputType
532 }
533 deriving Show
534-}
535isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool
536isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset]
537 where
538 isMember a Nothing = False
539 isMember a (Just b) = eqFun a b
540
541-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms
542{-
543 let sch = schema input
544 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
545 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
546 _ -> return ()
547 case T.lookup slotName (slots sch) of
548 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
549 Just (SlotSchema sPrim sAttrs) -> do
550 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
551 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
552 let sType = fmap streamToStreamType attribs
553 when (sType /= sAttrs) $ throw $ userError $ unlines $
554 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
555 , show sAttrs
556 , " but got "
557 , show sType
558 ]
559-}
560
561setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)
562setStorage p input' = setStorage' p (Just input')
563
564setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)
565setStorage' p input' = do
566 -- TODO: check matching input schema
567 {-
568 case input' of
569 Nothing -> return ()
570 Just input -> schemaFromPipeline p
571 -}
572 {-
573 deletion:
574 - remove pipeline's object commands from used slots
575 - remove pipeline from attached pipelines vector
576 -}
577 ic' <- readIORef $ glInput p
578 case ic' of
579 Nothing -> return ()
580 Just ic -> do
581 let idx = icId ic
582 oldInput = icInput ic
583 slotMask = icSlotMapPipelineToInput ic
584 slotRefs = slotVector oldInput
585 modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)]
586 V.forM_ slotMask $ \slotIdx -> do
587 slot <- readIORef (slotRefs ! slotIdx)
588 forM_ (IM.elems $ objectMap slot) $ \obj -> do
589 modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)]
590 {-
591 addition:
592 - get an id from pipeline input
593 - add to attached pipelines
594 - generate slot mappings
595 - update used slots, and generate object commands for objects in the related slots
596 -}
597 case input' of
598 Nothing -> writeIORef (glInput p) Nothing >> return Nothing
599 Just input -> do
600 let pipelinesRef = pipelines input
601 oldPipelineV <- readIORef pipelinesRef
602 (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
603 Nothing -> do
604 -- we don't have empty space, hence we double the vector size
605 let len = V.length oldPipelineV
606 modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]
607 return (len,Just len)
608 Just i -> do
609 modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]
610 return (i,Nothing)
611 -- create input connection
612 let sm = slotMap input
613 pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm]
614 iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
615 writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP
616
617 -- generate object commands for related slots
618 {-
619 for each slot in pipeline:
620 map slot name to input slot name
621 for each object:
622 generate command program vector => for each dependent program:
623 generate object commands
624 -}
625 let slotV = slotVector input
626 progV = glPrograms p
627 texUnitMap = glTexUnitMapping p
628 topUnis = uniformSetup input
629 emptyV = V.replicate (V.length progV) []
630 extend v = case shouldExtend of
631 Nothing -> v
632 Just l -> V.concat [v,V.replicate l V.empty]
633 V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do
634 slot <- readIORef $ slotV ! slotIdx
635 forM_ (IM.elems $ objectMap slot) $ \obj -> do
636 let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
637 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
638 -- generate stream commands
639 V.forM_ (glStreams p) $ \s -> do
640 writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
641 return Nothing
642{-
643 track state:
644 - render target
645 - binded textures
646-}
647
648{-
649 render steps:
650 - update uniforms
651 - per uniform setup
652 - buffer setup (one buffer per object, which has per at least one object uniform)
653 - new command: set uniform buffer (binds uniform buffer to program's buffer slot)
654 - render slot steps:
655 - set uniform buffer or set uniforms separately
656 - set vertex and index array
657 - call draw command
658-}
659{-
660 storage alternatives:
661 - interleaved / separated
662 - VAO or VBOs
663-}
664 {-
665 strategy:
666 step 1: generate commands for an object
667 step 2: sort object merge and do optimization by filtering redundant commands
668 -}
669{-
670 design:
671 runtime eleminiation of redundant buffer bind commands and redundant texture bind commands
672-}
673{-
674 track:
675 buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER
676 glEnable/DisableVertexAttribArray
677-}
678renderSlot :: [GLObjectCommand] -> IO ()
679renderSlot cmds = forM_ cmds $ \cmd -> do
680 case cmd of
681 GLSetVertexAttribArray idx buf size typ ptr -> do
682 glBindBuffer GL_ARRAY_BUFFER buf
683 glEnableVertexAttribArray idx
684 glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr
685 GLSetVertexAttribIArray idx buf size typ ptr -> do
686 glBindBuffer GL_ARRAY_BUFFER buf
687 glEnableVertexAttribArray idx
688 glVertexAttribIPointer idx size typ 0 ptr
689 GLDrawArrays mode first count -> glDrawArrays mode first count
690 GLDrawElements mode count typ buf indicesPtr -> do
691 glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf
692 glDrawElements mode count typ indicesPtr
693 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
694 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
695 txObjVal <- readIORef ref
696 -- HINT: ugly and hacky
697 with txObjVal $ \txObjPtr -> do
698 txObj <- peek $ castPtr txObjPtr :: IO GLuint
699 texUnit <- readIORef tuRef
700 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
701 glBindTexture txTarget txObj
702 putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
703 GLSetVertexAttrib idx val -> do
704 glDisableVertexAttribArray idx
705 setVertexAttrib idx val
706 isOk <- checkGL
707 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
708
709renderFrame :: GLRenderer -> IO ()
710renderFrame glp = do
711 glBindVertexArray (glVAO glp)
712 forM_ (glCommands glp) $ \cmd -> do
713 case cmd of
714 GLSetRasterContext rCtx -> setupRasterContext rCtx
715 GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx
716 GLSetRenderTarget rt bufs -> do
717 -- set target viewport
718 --when (rt == 0) $ do -- screen out
719 ic' <- readIORef $ glInput glp
720 case ic' of
721 Nothing -> return ()
722 Just ic -> do
723 let input = icInput ic
724 (w,h) <- readIORef $ screenSize input
725 glViewport 0 0 (fromIntegral w) (fromIntegral h)
726 -- TODO: set FBO target viewport
727 glBindFramebuffer GL_DRAW_FRAMEBUFFER rt
728 case bufs of
729 Nothing -> return ()
730 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
731 GLSetProgram p -> glUseProgram p
732 GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu
733 GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx
734 GLClearRenderTarget vals -> clearRenderTarget vals
735 GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target
736 GLRenderStream streamIdx progIdx -> do
737 renderSlot =<< readIORef (glStreamCommands $ glStreams glp ! streamIdx)
738 GLRenderSlot slotIdx progIdx -> do
739 input <- readIORef (glInput glp)
740 case input of
741 Nothing -> putStrLn "Warning: No pipeline input!" >> return ()
742 Just ic -> do
743 GLSlot _ objs _ <- readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx))
744 --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects"
745 V.forM_ objs $ \(_,obj) -> do
746 enabled <- readIORef $ objEnabled obj
747 when enabled $ do
748 cmd <- readIORef $ objCommands obj
749 --putStrLn "Render object"
750 renderSlot ((cmd ! icId ic) ! progIdx)
751 {-
752 GLSetSampler
753 GLSaveImage
754 GLLoadImage
755 -}
756 isOk <- checkGL
757 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
758
759data CGState
760 = CGState
761 { currentProgram :: ProgramName
762 , textureBinding :: IntMap GLTexture
763 , samplerUniforms :: Map UniformName TextureUnit
764 }
765
766initCGState = CGState
767 { currentProgram = error "CGState: empty currentProgram"
768 , textureBinding = IM.empty
769 , samplerUniforms = mempty
770 }
771
772type CG a = State CGState a
773
774compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand
775compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
776 SetRasterContext rCtx -> return $ GLSetRasterContext rCtx
777 SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx
778 SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs
779 SetProgram p -> do
780 modify (\s -> s {currentProgram = p})
781 return $ GLSetProgram $ programObject $ programs ! p
782 SetSamplerUniform n tu -> do
783 modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms})
784 p <- currentProgram <$> get
785 case T.lookup (pack n) (inputTextures $ programs ! p) of
786 Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd
787 Just i -> case T.lookup (pack n) texUnitMap of
788 Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
789 Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r
790 SetTexture tu t -> do
791 let tex = textures ! t
792 modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
793 return $ GLSetTexture (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
794{-
795 SetSampler tu s -> liftIO $ do
796 glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
797-}
798 RenderSlot slot -> do
799 smpUnis <- samplerUniforms <$> get
800 p <- currentProgram <$> get
801 return $ GLRenderSlot slot p
802 RenderStream stream -> do
803 p <- currentProgram <$> get
804 return $ GLRenderStream stream p
805 ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals
806 GenerateMipMap tu -> do
807 tb <- textureBinding <$> get
808 case IM.lookup tu tb of
809 Nothing -> fail "internal error (GenerateMipMap)!"
810 Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
811{-
812 SaveImage _ _ -> undefined
813 LoadImage _ _ -> undefined
814-}
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs
new file mode 100644
index 0000000..231da8b
--- /dev/null
+++ b/src/LambdaCube/GL/Data.hs
@@ -0,0 +1,113 @@
1module LambdaCube.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.GL.Core33
20import Data.Word
21import Codec.Picture
22import Codec.Picture.Types
23
24import LambdaCube.GL.Type
25import LambdaCube.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
62uploadTexture2DToGPU :: DynamicImage -> IO TextureData
63uploadTexture2DToGPU = uploadTexture2DToGPU' False True False
64
65uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData
66uploadTexture2DToGPU' 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 "uploadTexture2DToGPU: ImageCMYK16"
72 ImageCMYK8 _ -> error "uploadTexture2DToGPU: ImageCMYK8"
73 ImageRGBA16 _ -> error "uploadTexture2DToGPU: ImageRGBA16"
74 ImageRGBF _ -> error "uploadTexture2DToGPU: ImageRGBF"
75 ImageRGB16 _ -> error "uploadTexture2DToGPU: ImageRGB16"
76 ImageYA16 _ -> error "uploadTexture2DToGPU: ImageYA16"
77 ImageYA8 _ -> error "uploadTexture2DToGPU: ImageYA8"
78 ImageYF _ -> error "uploadTexture2DToGPU: ImageYF"
79 ImageY16 _ -> error "uploadTexture2DToGPU: ImageY16"
80 ImageY8 _ -> error "uploadTexture2DToGPU: ImageY8"
81 _ -> error "uploadTexture2DToGPU: 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/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
new file mode 100644
index 0000000..aabf0e6
--- /dev/null
+++ b/src/LambdaCube/GL/Input.hs
@@ -0,0 +1,390 @@
1module LambdaCube.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.GL.Core33
23
24import IR as IR
25import Linear as IR
26import LambdaCube.GL.Type as T
27import LambdaCube.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
51allocStorage :: PipelineSchema -> IO GLStorage
52allocStorage 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 $ GLStorage
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
71disposeStorage :: GLStorage -> IO ()
72disposeStorage = error "not implemented: disposeStorage"
73
74-- object
75addObject :: GLStorage -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
76addObject input slotName prim indices attribs uniformNames = do
77 let sch = schema input
78 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
79 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
80 _ -> return ()
81 case T.lookup slotName (T.slots sch) of
82 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
83 Just (SlotSchema sPrim sAttrs) -> do
84 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
85 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
86 let sType = fmap streamToStreamType attribs
87 when (sType /= sAttrs) $ throw $ userError $ unlines $
88 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
89 , show sAttrs
90 , " but got "
91 , show sType
92 ]
93
94 let slotIdx = case slotName `T.lookup` slotMap input of
95 Nothing -> error $ "internal error (slot index): " ++ show slotName
96 Just i -> i
97 seed = objSeed input
98 order <- newIORef 0
99 enabled <- newIORef True
100 index <- readIORef seed
101 modifyIORef seed (1+)
102 (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = T.lookup n (uniforms sch)]
103 cmdsRef <- newIORef (V.singleton V.empty)
104 let obj = Object
105 { objSlot = slotIdx
106 , objPrimitive = prim
107 , objIndices = indices
108 , objAttributes = attribs
109 , objUniSetter = setters
110 , objUniSetup = unis
111 , objOrder = order
112 , objEnabled = enabled
113 , objId = index
114 , objCommands = cmdsRef
115 }
116
117 modifyIORef (slotVector input ! slotIdx) $ \(GLSlot objs _ _) -> GLSlot (IM.insert index obj objs) V.empty Generate
118
119 -- generate GLObjectCommands for the new object
120 {-
121 foreach pipeline:
122 foreach realted program:
123 generate commands
124 -}
125 ppls <- readIORef $ pipelines input
126 let topUnis = uniformSetup input
127 cmds <- V.forM ppls $ \mp -> case mp of
128 Nothing -> return V.empty
129 Just p -> do
130 Just ic <- readIORef $ glInput p
131 case icSlotMapInputToPipeline ic ! slotIdx of
132 Nothing -> do
133 putStrLn $ " ** slot is not used!"
134 return V.empty -- this slot is not used in that pipeline
135 Just pSlotIdx -> do
136 putStrLn "slot is used!"
137 --where
138 let emptyV = V.replicate (V.length $ glPrograms p) []
139 return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx]
140 writeIORef cmdsRef cmds
141 return obj
142
143removeObject :: GLStorage -> Object -> IO ()
144removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate
145
146enableObject :: Object -> Bool -> IO ()
147enableObject obj b = writeIORef (objEnabled obj) b
148
149setObjectOrder :: GLStorage -> Object -> Int -> IO ()
150setObjectOrder p obj i = do
151 writeIORef (objOrder obj) i
152 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
153
154objectUniformSetter :: Object -> Trie InputSetter
155objectUniformSetter = objUniSetter
156
157setScreenSize :: GLStorage -> Word -> Word -> IO ()
158setScreenSize p w h = writeIORef (screenSize p) (w,h)
159
160sortSlotObjects :: GLStorage -> IO ()
161sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do
162 GLSlot objMap sortedV ord <- readIORef slotRef
163 let cmpFun (a,_) (b,_) = a `compare` b
164 doSort objs = do
165 ordObjsM <- V.thaw objs
166 I.sortBy cmpFun ordObjsM
167 ordObjs <- V.freeze ordObjsM
168 writeIORef slotRef (GLSlot objMap ordObjs Ordered)
169 case ord of
170 Ordered -> return ()
171 Generate -> do
172 objs <- V.forM (V.fromList $ IM.elems objMap) $ \obj -> do
173 ord <- readIORef $ objOrder obj
174 return (ord,obj)
175 doSort objs
176 Reorder -> do
177 objs <- V.forM sortedV $ \(_,obj) -> do
178 ord <- readIORef $ objOrder obj
179 return (ord,obj)
180 doSort objs
181
182createObjectCommands :: Trie (IORef GLint) -> Trie GLUniform -> Object -> GLProgram -> [GLObjectCommand]
183createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd]
184 where
185 -- object draw command
186 objDrawCmd = case objIndices obj of
187 Nothing -> GLDrawArrays prim 0 (fromIntegral count)
188 Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
189 where
190 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
191 idxType = arrayTypeToGLType arrType
192 ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
193 where
194 objAttrs = objAttributes obj
195 prim = primitiveToGLType $ objPrimitive obj
196 count = head [c | Stream _ _ _ _ c <- T.elems objAttrs]
197
198 -- object uniform commands
199 -- texture slot setup commands
200 objUniCmds = uniCmds ++ texCmds
201 where
202 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis]
203 uniMap = T.toList $ inputUniforms prg
204 topUni n = T.lookupWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis
205 objUnis = objUniSetup obj
206 texUnis = S.toList $ inputTextureUniforms prg
207 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
208 | n <- texUnis
209 , let u = T.lookupWithDefault (topUni n) n objUnis
210 , let texUnit = T.lookupWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
211 ]
212 uniInputType (GLUniform ty _) = ty
213
214 -- object attribute stream commands
215 objStreamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name objAttrs]
216 where
217 attrMap = inputStreams prg
218 objAttrs = objAttributes obj
219 attrCmd i s = case s of
220 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
221 Attribute_Word -> setIntAttrib 1
222 Attribute_V2U -> setIntAttrib 2
223 Attribute_V3U -> setIntAttrib 3
224 Attribute_V4U -> setIntAttrib 4
225 Attribute_Int -> setIntAttrib 1
226 Attribute_V2I -> setIntAttrib 2
227 Attribute_V3I -> setIntAttrib 3
228 Attribute_V4I -> setIntAttrib 4
229 Attribute_Float -> setFloatAttrib 1
230 Attribute_V2F -> setFloatAttrib 2
231 Attribute_V3F -> setFloatAttrib 3
232 Attribute_V4F -> setFloatAttrib 4
233 Attribute_M22F -> setFloatAttrib 4
234 Attribute_M23F -> setFloatAttrib 6
235 Attribute_M24F -> setFloatAttrib 8
236 Attribute_M32F -> setFloatAttrib 6
237 Attribute_M33F -> setFloatAttrib 9
238 Attribute_M34F -> setFloatAttrib 12
239 Attribute_M42F -> setFloatAttrib 8
240 Attribute_M43F -> setFloatAttrib 12
241 Attribute_M44F -> setFloatAttrib 16
242 where
243 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
244 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
245 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
246 glType = arrayTypeToGLType arrType
247 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
248
249 -- constant generic attribute
250 constAttr -> GLSetVertexAttrib i constAttr
251
252nullSetter :: ByteString -> String -> a -> IO ()
253--nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
254nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
255
256uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool
257uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B
258uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B
259uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B
260
261uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32
262uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U
263uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U
264uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U
265
266uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32
267uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I
268uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I
269uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I
270
271uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float
272uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F
273uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F
274uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F
275
276uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F
277uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F
278uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F
279uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F
280uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F
281uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F
282uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F
283uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F
284uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F
285
286uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData
287
288uniformBool n is = case T.lookup n is of
289 Just (SBool fun) -> fun
290 _ -> nullSetter n "Bool"
291
292uniformV2B n is = case T.lookup n is of
293 Just (SV2B fun) -> fun
294 _ -> nullSetter n "V2B"
295
296uniformV3B n is = case T.lookup n is of
297 Just (SV3B fun) -> fun
298 _ -> nullSetter n "V3B"
299
300uniformV4B n is = case T.lookup n is of
301 Just (SV4B fun) -> fun
302 _ -> nullSetter n "V4B"
303
304uniformWord n is = case T.lookup n is of
305 Just (SWord fun) -> fun
306 _ -> nullSetter n "Word"
307
308uniformV2U n is = case T.lookup n is of
309 Just (SV2U fun) -> fun
310 _ -> nullSetter n "V2U"
311
312uniformV3U n is = case T.lookup n is of
313 Just (SV3U fun) -> fun
314 _ -> nullSetter n "V3U"
315
316uniformV4U n is = case T.lookup n is of
317 Just (SV4U fun) -> fun
318 _ -> nullSetter n "V4U"
319
320uniformInt n is = case T.lookup n is of
321 Just (SInt fun) -> fun
322 _ -> nullSetter n "Int"
323
324uniformV2I n is = case T.lookup n is of
325 Just (SV2I fun) -> fun
326 _ -> nullSetter n "V2I"
327
328uniformV3I n is = case T.lookup n is of
329 Just (SV3I fun) -> fun
330 _ -> nullSetter n "V3I"
331
332uniformV4I n is = case T.lookup n is of
333 Just (SV4I fun) -> fun
334 _ -> nullSetter n "V4I"
335
336uniformFloat n is = case T.lookup n is of
337 Just (SFloat fun) -> fun
338 _ -> nullSetter n "Float"
339
340uniformV2F n is = case T.lookup n is of
341 Just (SV2F fun) -> fun
342 _ -> nullSetter n "V2F"
343
344uniformV3F n is = case T.lookup n is of
345 Just (SV3F fun) -> fun
346 _ -> nullSetter n "V3F"
347
348uniformV4F n is = case T.lookup n is of
349 Just (SV4F fun) -> fun
350 _ -> nullSetter n "V4F"
351
352uniformM22F n is = case T.lookup n is of
353 Just (SM22F fun) -> fun
354 _ -> nullSetter n "M22F"
355
356uniformM23F n is = case T.lookup n is of
357 Just (SM23F fun) -> fun
358 _ -> nullSetter n "M23F"
359
360uniformM24F n is = case T.lookup n is of
361 Just (SM24F fun) -> fun
362 _ -> nullSetter n "M24F"
363
364uniformM32F n is = case T.lookup n is of
365 Just (SM32F fun) -> fun
366 _ -> nullSetter n "M32F"
367
368uniformM33F n is = case T.lookup n is of
369 Just (SM33F fun) -> fun
370 _ -> nullSetter n "M33F"
371
372uniformM34F n is = case T.lookup n is of
373 Just (SM34F fun) -> fun
374 _ -> nullSetter n "M34F"
375
376uniformM42F n is = case T.lookup n is of
377 Just (SM42F fun) -> fun
378 _ -> nullSetter n "M42F"
379
380uniformM43F n is = case T.lookup n is of
381 Just (SM43F fun) -> fun
382 _ -> nullSetter n "M43F"
383
384uniformM44F n is = case T.lookup n is of
385 Just (SM44F fun) -> fun
386 _ -> nullSetter n "M44F"
387
388uniformFTexture2D n is = case T.lookup n is of
389 Just (SFTexture2D fun) -> fun
390 _ -> nullSetter n "FTexture2D"
diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs
new file mode 100644
index 0000000..f8a0bb9
--- /dev/null
+++ b/src/LambdaCube/GL/Mesh.hs
@@ -0,0 +1,218 @@
1{-# LANGUAGE TupleSections #-}
2module LambdaCube.GL.Mesh (
3 loadMesh',
4 loadMesh,
5 saveMesh,
6 addMeshToObjectArray,
7 uploadMeshToGPU,
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 LambdaCube.GL
31import LambdaCube.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 = uploadMeshToGPU =<< loadMesh' n
75
76saveMesh :: String -> Mesh -> IO ()
77saveMesh n m = LB.writeFile n (encode m)
78
79addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object
80addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = 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
87addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: 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 Attribute_Float b i 0 (V.length v)
104meshAttrToStream b i (A_V2F v) = Stream Attribute_V2F b i 0 (V.length v)
105meshAttrToStream b i (A_V3F v) = Stream Attribute_V3F b i 0 (V.length v)
106meshAttrToStream b i (A_V4F v) = Stream Attribute_V4F b i 0 (V.length v)
107meshAttrToStream b i (A_M22F v) = Stream Attribute_M22F b i 0 (V.length v)
108meshAttrToStream b i (A_M33F v) = Stream Attribute_M33F b i 0 (V.length v)
109meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v)
110meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v)
111meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v)
112
113updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()
114updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
115 -- check type match
116 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
117 ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA]
118 if not ok then putStrLn "updateMesh: attribute mismatch!"
119 else do
120 forM_ al $ \(n,a) -> do
121 case T.lookup n dS of
122 Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]
123 _ -> return ()
124{-
125 case mp of
126 Nothing -> return ()
127 Just p -> do
128 let ok2 = case (dMP,p) of
129 (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2
130 (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2
131 (a,b) -> a == b
132-}
133
134uploadMeshToGPU :: Mesh -> IO Mesh
135uploadMeshToGPU (Mesh attrs mPrim Nothing) = do
136 let mkIndexBuf v = do
137 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]
138 return $! Just $! IndexStream iBuf 0 0 (V.length v)
139 vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs]
140 (indices,prim) <- case mPrim of
141 P_Points -> return (Nothing,PointList)
142 P_TriangleStrip -> return (Nothing,TriangleStrip)
143 P_Triangles -> return (Nothing,TriangleList)
144 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v
145 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v
146 let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs)
147 gpuData = GPUData prim streams indices
148 return $! Mesh attrs mPrim (Just gpuData)
149
150uploadMeshToGPU mesh = return mesh
151
152sblToV :: Storable a => [SB.ByteString] -> V.Vector a
153sblToV ls = v
154 where
155 offs o (s:xs) = (o,s):offs (o + SB.length s) xs
156 offs _ [] = []
157 cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v)
158 v = unsafePerformIO $ do
159 mv <- MV.new cnt
160 MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) ->
161 SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len
162 V.unsafeFreeze mv
163
164vToSB :: Storable a => V.Vector a -> SB.ByteString
165vToSB v = unsafePerformIO $ do
166 let len = V.length v * sizeOf (V.head v)
167 V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len)
168
169instance Storable a => Binary (V.Vector a) where
170 put v = put $ vToSB v
171 get = do s <- get ; return $ sblToV [s]
172
173instance Binary MeshAttribute where
174 put (A_Float a) = putWord8 0 >> put a
175 put (A_V2F a) = putWord8 1 >> put a
176 put (A_V3F a) = putWord8 2 >> put a
177 put (A_V4F a) = putWord8 3 >> put a
178 put (A_M22F a) = putWord8 4 >> put a
179 put (A_M33F a) = putWord8 5 >> put a
180 put (A_M44F a) = putWord8 6 >> put a
181 put (A_Int a) = putWord8 7 >> put a
182 put (A_Word a) = putWord8 8 >> put a
183 get = do
184 tag_ <- getWord8
185 case tag_ of
186 0 -> A_Float <$> get
187 1 -> A_V2F <$> get
188 2 -> A_V3F <$> get
189 3 -> A_V4F <$> get
190 4 -> A_M22F <$> get
191 5 -> A_M33F <$> get
192 6 -> A_M44F <$> get
193 7 -> A_Int <$> get
194 8 -> A_Word <$> get
195 _ -> fail "no parse"
196
197instance Binary MeshPrimitive where
198 put P_Points = putWord8 0
199 put P_TriangleStrip = putWord8 1
200 put P_Triangles = putWord8 2
201 put (P_TriangleStripI a) = putWord8 3 >> put a
202 put (P_TrianglesI a) = putWord8 4 >> put a
203 get = do
204 tag_ <- getWord8
205 case tag_ of
206 0 -> return P_Points
207 1 -> return P_TriangleStrip
208 2 -> return P_Triangles
209 3 -> P_TriangleStripI <$> get
210 4 -> P_TrianglesI <$> get
211 _ -> fail "no parse"
212
213instance Binary Mesh where
214 put (Mesh a b _) = put (T.toList a) >> put b
215 get = do
216 a <- get
217 b <- get
218 return $! Mesh (T.fromList a) b Nothing
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
new file mode 100644
index 0000000..c82a8f0
--- /dev/null
+++ b/src/LambdaCube/GL/Type.hs
@@ -0,0 +1,541 @@
1{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2module LambdaCube.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.GL.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 GLStorage can be attached to GLRenderer
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 GLStorage
100 = GLStorage
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 GLRenderer)) -- 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 :: GLStorage
149 , icSlotMapPipelineToInput :: Vector SlotName -- GLRenderer to GLStorage slot name mapping
150 , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLStorage to GLRenderer 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 GLRenderer
162 = GLRenderer
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 = Attribute_Word
328 | Attribute_V2U
329 | Attribute_V3U
330 | Attribute_V4U
331 | Attribute_Int
332 | Attribute_V2I
333 | Attribute_V3I
334 | Attribute_V4I
335 | Attribute_Float
336 | Attribute_V2F
337 | Attribute_V3F
338 | Attribute_V4F
339 | Attribute_M22F
340 | Attribute_M23F
341 | Attribute_M24F
342 | Attribute_M32F
343 | Attribute_M33F
344 | Attribute_M34F
345 | Attribute_M42F
346 | Attribute_M43F
347 | Attribute_M44F
348 deriving (Show,Eq,Ord)
349
350toStreamType :: InputType -> Maybe StreamType
351toStreamType Word = Just Attribute_Word
352toStreamType V2U = Just Attribute_V2U
353toStreamType V3U = Just Attribute_V3U
354toStreamType V4U = Just Attribute_V4U
355toStreamType Int = Just Attribute_Int
356toStreamType V2I = Just Attribute_V2I
357toStreamType V3I = Just Attribute_V3I
358toStreamType V4I = Just Attribute_V4I
359toStreamType Float = Just Attribute_Float
360toStreamType V2F = Just Attribute_V2F
361toStreamType V3F = Just Attribute_V3F
362toStreamType V4F = Just Attribute_V4F
363toStreamType M22F = Just Attribute_M22F
364toStreamType M23F = Just Attribute_M23F
365toStreamType M24F = Just Attribute_M24F
366toStreamType M32F = Just Attribute_M32F
367toStreamType M33F = Just Attribute_M33F
368toStreamType M34F = Just Attribute_M34F
369toStreamType M42F = Just Attribute_M42F
370toStreamType M43F = Just Attribute_M43F
371toStreamType M44F = Just Attribute_M44F
372toStreamType _ = Nothing
373
374fromStreamType :: StreamType -> InputType
375fromStreamType Attribute_Word = Word
376fromStreamType Attribute_V2U = V2U
377fromStreamType Attribute_V3U = V3U
378fromStreamType Attribute_V4U = V4U
379fromStreamType Attribute_Int = Int
380fromStreamType Attribute_V2I = V2I
381fromStreamType Attribute_V3I = V3I
382fromStreamType Attribute_V4I = V4I
383fromStreamType Attribute_Float = Float
384fromStreamType Attribute_V2F = V2F
385fromStreamType Attribute_V3F = V3F
386fromStreamType Attribute_V4F = V4F
387fromStreamType Attribute_M22F = M22F
388fromStreamType Attribute_M23F = M23F
389fromStreamType Attribute_M24F = M24F
390fromStreamType Attribute_M32F = M32F
391fromStreamType Attribute_M33F = M33F
392fromStreamType Attribute_M34F = M34F
393fromStreamType Attribute_M42F = M42F
394fromStreamType Attribute_M43F = M43F
395fromStreamType Attribute_M44F = 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 _ -> Attribute_Word
433 ConstV2U _ -> Attribute_V2U
434 ConstV3U _ -> Attribute_V3U
435 ConstV4U _ -> Attribute_V4U
436 ConstInt _ -> Attribute_Int
437 ConstV2I _ -> Attribute_V2I
438 ConstV3I _ -> Attribute_V3I
439 ConstV4I _ -> Attribute_V4I
440 ConstFloat _ -> Attribute_Float
441 ConstV2F _ -> Attribute_V2F
442 ConstV3F _ -> Attribute_V3F
443 ConstV4F _ -> Attribute_V4F
444 ConstM22F _ -> Attribute_M22F
445 ConstM23F _ -> Attribute_M23F
446 ConstM24F _ -> Attribute_M24F
447 ConstM32F _ -> Attribute_M32F
448 ConstM33F _ -> Attribute_M33F
449 ConstM34F _ -> Attribute_M34F
450 ConstM42F _ -> Attribute_M42F
451 ConstM43F _ -> Attribute_M43F
452 ConstM44F _ -> Attribute_M44F
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/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
new file mode 100644
index 0000000..2059415
--- /dev/null
+++ b/src/LambdaCube/GL/Util.hs
@@ -0,0 +1,719 @@
1{-# LANGUAGE OverloadedStrings #-}
2module LambdaCube.GL.Util (
3 queryUniforms,
4 queryStreams,
5 mkUniformSetter,
6 setUniform,
7 setVertexAttrib,
8 compileShader,
9 printProgramLog,
10 glGetShaderiv1,
11 glGetProgramiv1,
12 Buffer(..),
13 ArrayDesc(..),
14 StreamSetter,
15 streamToInputType,
16 arrayTypeToGLType,
17 comparisonFunctionToGLType,
18 logicOperationToGLType,
19 blendEquationToGLType,
20 blendingFactorToGLType,
21 checkGL,
22 textureDataTypeToGLType,
23 textureDataTypeToGLArityType,
24 glGetIntegerv1,
25 setSampler,
26 checkFBO,
27 compileTexture,
28 primitiveToFetchPrimitive,
29 primitiveToGLType,
30 inputTypeToTextureTarget,
31 toTrie
32) where
33
34import Control.Applicative
35import Control.Exception
36import Control.Monad
37import Data.ByteString.Char8 (ByteString,pack,unpack)
38import Data.IORef
39import Data.List as L
40import Data.Trie as T
41import Foreign
42import qualified Data.ByteString.Char8 as SB
43import qualified Data.Vector as V
44import Data.Vector.Unboxed.Mutable (IOVector)
45import qualified Data.Vector.Unboxed.Mutable as MV
46import Data.Map (Map)
47import qualified Data.Map as Map
48
49import Graphics.GL.Core33
50import Linear
51import IR
52import LambdaCube.GL.Type
53
54toTrie :: Map String a -> Trie a
55toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m]
56
57setSampler :: GLint -> Int32 -> IO ()
58setSampler i v = glUniform1i i $ fromIntegral v
59
60z2 = V2 0 0 :: V2F
61z3 = V3 0 0 0 :: V3F
62z4 = V4 0 0 0 0 :: V4F
63
64-- uniform functions
65queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)
66queryUniforms po = do
67 ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH
68 let uNames = [n | (n,_,_,_) <- ul]
69 uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]
70 uLocation = [i | (_,i,_,_) <- ul]
71 return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes)
72
73b2w :: Bool -> GLuint
74b2w True = 1
75b2w False = 0
76
77mkUniformSetter :: InputType -> IO (GLUniform, InputSetter)
78mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)}
79mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)}
80mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)}
81mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)}
82mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)}
83mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)}
84mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)}
85mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)}
86mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)}
87mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)}
88mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)}
89mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)}
90mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)}
91mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)}
92mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)}
93mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)}
94mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)}
95mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)}
96mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)}
97mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)}
98mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)}
99mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)}
100mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)}
101mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)}
102mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)}
103mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)}
104
105-- sets value based uniforms only (does not handle textures)
106setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()
107setUniform i ty ref = do
108 v <- readIORef ref
109 let false = fromIntegral GL_FALSE
110 with v $ \p -> case ty of
111 Bool -> glUniform1uiv i 1 (castPtr p)
112 V2B -> glUniform2uiv i 1 (castPtr p)
113 V3B -> glUniform3uiv i 1 (castPtr p)
114 V4B -> glUniform4uiv i 1 (castPtr p)
115 Word -> glUniform1uiv i 1 (castPtr p)
116 V2U -> glUniform2uiv i 1 (castPtr p)
117 V3U -> glUniform3uiv i 1 (castPtr p)
118 V4U -> glUniform4uiv i 1 (castPtr p)
119 Int -> glUniform1iv i 1 (castPtr p)
120 V2I -> glUniform2iv i 1 (castPtr p)
121 V3I -> glUniform3iv i 1 (castPtr p)
122 V4I -> glUniform4iv i 1 (castPtr p)
123 Float -> glUniform1fv i 1 (castPtr p)
124 V2F -> glUniform2fv i 1 (castPtr p)
125 V3F -> glUniform3fv i 1 (castPtr p)
126 V4F -> glUniform4fv i 1 (castPtr p)
127 M22F -> glUniformMatrix2fv i 1 false (castPtr p)
128 M23F -> glUniformMatrix2x3fv i 1 false (castPtr p)
129 M24F -> glUniformMatrix2x4fv i 1 false (castPtr p)
130 M32F -> glUniformMatrix3x2fv i 1 false (castPtr p)
131 M33F -> glUniformMatrix3fv i 1 false (castPtr p)
132 M34F -> glUniformMatrix3x4fv i 1 false (castPtr p)
133 M42F -> glUniformMatrix4x2fv i 1 false (castPtr p)
134 M43F -> glUniformMatrix4x3fv i 1 false (castPtr p)
135 M44F -> glUniformMatrix4fv i 1 false (castPtr p)
136 FTexture2D -> return () --putStrLn $ "TODO: setUniform FTexture2D"
137 _ -> fail $ "internal error (setUniform)! - " ++ show ty
138
139-- attribute functions
140queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)
141queryStreams po = do
142 al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH
143 let aNames = [n | (n,_,_,_) <- al]
144 aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]
145 aLocation = [fromIntegral i | (_,i,_,_) <- al]
146 return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes)
147
148arrayTypeToGLType :: ArrayType -> GLenum
149arrayTypeToGLType a = case a of
150 ArrWord8 -> GL_UNSIGNED_BYTE
151 ArrWord16 -> GL_UNSIGNED_SHORT
152 ArrWord32 -> GL_UNSIGNED_INT
153 ArrInt8 -> GL_BYTE
154 ArrInt16 -> GL_SHORT
155 ArrInt32 -> GL_INT
156 ArrFloat -> GL_FLOAT
157 ArrHalf -> GL_HALF_FLOAT
158
159setVertexAttrib :: GLuint -> Stream Buffer -> IO ()
160setVertexAttrib i val = case val of
161 ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p
162 ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p
163 ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p
164 ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p
165 ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p
166 ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p
167 ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p
168 ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p
169 ConstFloat v -> setAFloat i v
170 ConstV2F v -> setAV2F i v
171 ConstV3F v -> setAV3F i v
172 ConstV4F v -> setAV4F i v
173 ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y
174 ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z
175 ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w
176 ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y
177 ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z
178 ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w
179 ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y
180 ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z
181 ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w
182 _ -> fail "internal error (setVertexAttrib)!"
183
184setAFloat :: GLuint -> Float -> IO ()
185setAV2F :: GLuint -> V2F -> IO ()
186setAV3F :: GLuint -> V3F -> IO ()
187setAV4F :: GLuint -> V4F -> IO ()
188setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p
189setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p
190setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p
191setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p
192
193-- result list: [(name string,location,gl type,component count)]
194getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())
195 -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)]
196getNameTypeSize o f g enum enumLen = do
197 nameLen <- glGetProgramiv1 enumLen o
198 allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do
199 n <- glGetProgramiv1 enum o
200 forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>
201 (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep
202
203fromGLType :: (GLenum,GLint) -> InputType
204fromGLType (t,1)
205 | t == GL_BOOL = Bool
206 | t == GL_BOOL_VEC2 = V2B
207 | t == GL_BOOL_VEC3 = V3B
208 | t == GL_BOOL_VEC4 = V4B
209 | t == GL_UNSIGNED_INT = Word
210 | t == GL_UNSIGNED_INT_VEC2 = V2U
211 | t == GL_UNSIGNED_INT_VEC3 = V3U
212 | t == GL_UNSIGNED_INT_VEC4 = V4U
213 | t == GL_INT = Int
214 | t == GL_INT_VEC2 = V2I
215 | t == GL_INT_VEC3 = V3I
216 | t == GL_INT_VEC4 = V4I
217 | t == GL_FLOAT = Float
218 | t == GL_FLOAT_VEC2 = V2F
219 | t == GL_FLOAT_VEC3 = V3F
220 | t == GL_FLOAT_VEC4 = V4F
221 | t == GL_FLOAT_MAT2 = M22F
222 | t == GL_FLOAT_MAT2x3 = M23F
223 | t == GL_FLOAT_MAT2x4 = M24F
224 | t == GL_FLOAT_MAT3x2 = M32F
225 | t == GL_FLOAT_MAT3 = M33F
226 | t == GL_FLOAT_MAT3x4 = M34F
227 | t == GL_FLOAT_MAT4x2 = M42F
228 | t == GL_FLOAT_MAT4x3 = M43F
229 | t == GL_FLOAT_MAT4 = M44F
230 | t == GL_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray
231 | t == GL_SAMPLER_1D_SHADOW = STexture1D
232 | t == GL_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray
233 | t == GL_SAMPLER_2D_RECT_SHADOW = STexture2DRect
234 | t == GL_SAMPLER_2D_SHADOW = STexture2D
235 | t == GL_SAMPLER_CUBE_SHADOW = STextureCube
236 | t == GL_INT_SAMPLER_1D = ITexture1D
237 | t == GL_INT_SAMPLER_1D_ARRAY = ITexture1DArray
238 | t == GL_INT_SAMPLER_2D = ITexture2D
239 | t == GL_INT_SAMPLER_2D_ARRAY = ITexture2DArray
240 | t == GL_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS
241 | t == GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray
242 | t == GL_INT_SAMPLER_2D_RECT = ITexture2DRect
243 | t == GL_INT_SAMPLER_3D = ITexture3D
244 | t == GL_INT_SAMPLER_BUFFER = ITextureBuffer
245 | t == GL_INT_SAMPLER_CUBE = ITextureCube
246 | t == GL_SAMPLER_1D = FTexture1D
247 | t == GL_SAMPLER_1D_ARRAY = FTexture1DArray
248 | t == GL_SAMPLER_2D = FTexture2D
249 | t == GL_SAMPLER_2D_ARRAY = FTexture2DArray
250 | t == GL_SAMPLER_2D_MULTISAMPLE = FTexture2DMS
251 | t == GL_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray
252 | t == GL_SAMPLER_2D_RECT = FTexture2DRect
253 | t == GL_SAMPLER_3D = FTexture3D
254 | t == GL_SAMPLER_BUFFER = FTextureBuffer
255 | t == GL_SAMPLER_CUBE = FTextureCube
256 | t == GL_UNSIGNED_INT_SAMPLER_1D = UTexture1D
257 | t == GL_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray
258 | t == GL_UNSIGNED_INT_SAMPLER_2D = UTexture2D
259 | t == GL_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray
260 | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS
261 | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray
262 | t == GL_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect
263 | t == GL_UNSIGNED_INT_SAMPLER_3D = UTexture3D
264 | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer
265 | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube
266 | otherwise = error "Failed fromGLType"
267fromGLUniformType _ = error "Failed fromGLType"
268
269printShaderLog :: GLuint -> IO ()
270printShaderLog o = do
271 i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o
272 when (i > 0) $
273 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
274 glGetShaderInfoLog o (fromIntegral i) sizePtr ps
275 size <- peek sizePtr
276 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
277 SB.putStrLn log
278
279glGetShaderiv1 :: GLenum -> GLuint -> IO GLint
280glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi
281
282glGetProgramiv1 :: GLenum -> GLuint -> IO GLint
283glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi
284
285printProgramLog :: GLuint -> IO ()
286printProgramLog o = do
287 i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o
288 when (i > 0) $
289 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
290 glGetProgramInfoLog o (fromIntegral i) sizePtr ps
291 size <- peek sizePtr
292 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
293 SB.putStrLn log
294
295compileShader :: GLuint -> [ByteString] -> IO ()
296compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do
297 glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
298 glCompileShader o
299 printShaderLog o
300 status <- glGetShaderiv1 GL_COMPILE_STATUS o
301 when (status /= fromIntegral GL_TRUE) $ fail "compileShader failed!"
302
303checkGL :: IO ByteString
304checkGL = do
305 let f e | e == GL_INVALID_ENUM = "INVALID_ENUM"
306 | e == GL_INVALID_VALUE = "INVALID_VALUE"
307 | e == GL_INVALID_OPERATION = "INVALID_OPERATION"
308 | e == GL_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"
309 | e == GL_OUT_OF_MEMORY = "OUT_OF_MEMORY"
310 | e == GL_NO_ERROR = "OK"
311 | otherwise = "Unknown error"
312 e <- glGetError
313 return $ f e
314
315streamToInputType :: Stream Buffer -> InputType
316streamToInputType s = case s of
317 ConstWord _ -> Word
318 ConstV2U _ -> V2U
319 ConstV3U _ -> V3U
320 ConstV4U _ -> V4U
321 ConstInt _ -> Int
322 ConstV2I _ -> V2I
323 ConstV3I _ -> V3I
324 ConstV4I _ -> V4I
325 ConstFloat _ -> Float
326 ConstV2F _ -> V2F
327 ConstV3F _ -> V3F
328 ConstV4F _ -> V4F
329 ConstM22F _ -> M22F
330 ConstM23F _ -> M23F
331 ConstM24F _ -> M24F
332 ConstM32F _ -> M32F
333 ConstM33F _ -> M33F
334 ConstM34F _ -> M34F
335 ConstM42F _ -> M42F
336 ConstM43F _ -> M43F
337 ConstM44F _ -> M44F
338 Stream t (Buffer a _) i _ _
339 | 0 <= i && i < V.length a &&
340 if elem t integralTypes then elem at integralArrTypes else True
341 -> fromStreamType t
342 | otherwise -> throw $ userError "streamToInputType failed"
343 where
344 at = arrType $! (a V.! i)
345 integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I]
346 integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]
347
348comparisonFunctionToGLType :: ComparisonFunction -> GLenum
349comparisonFunctionToGLType a = case a of
350 Always -> GL_ALWAYS
351 Equal -> GL_EQUAL
352 Gequal -> GL_GEQUAL
353 Greater -> GL_GREATER
354 Lequal -> GL_LEQUAL
355 Less -> GL_LESS
356 Never -> GL_NEVER
357 Notequal -> GL_NOTEQUAL
358
359logicOperationToGLType :: LogicOperation -> GLenum
360logicOperationToGLType a = case a of
361 And -> GL_AND
362 AndInverted -> GL_AND_INVERTED
363 AndReverse -> GL_AND_REVERSE
364 Clear -> GL_CLEAR
365 Copy -> GL_COPY
366 CopyInverted -> GL_COPY_INVERTED
367 Equiv -> GL_EQUIV
368 Invert -> GL_INVERT
369 Nand -> GL_NAND
370 Noop -> GL_NOOP
371 Nor -> GL_NOR
372 Or -> GL_OR
373 OrInverted -> GL_OR_INVERTED
374 OrReverse -> GL_OR_REVERSE
375 Set -> GL_SET
376 Xor -> GL_XOR
377
378blendEquationToGLType :: BlendEquation -> GLenum
379blendEquationToGLType a = case a of
380 FuncAdd -> GL_FUNC_ADD
381 FuncReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT
382 FuncSubtract -> GL_FUNC_SUBTRACT
383 Max -> GL_MAX
384 Min -> GL_MIN
385
386blendingFactorToGLType :: BlendingFactor -> GLenum
387blendingFactorToGLType a = case a of
388 ConstantAlpha -> GL_CONSTANT_ALPHA
389 ConstantColor -> GL_CONSTANT_COLOR
390 DstAlpha -> GL_DST_ALPHA
391 DstColor -> GL_DST_COLOR
392 One -> GL_ONE
393 OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA
394 OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR
395 OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA
396 OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR
397 OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA
398 OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR
399 SrcAlpha -> GL_SRC_ALPHA
400 SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE
401 SrcColor -> GL_SRC_COLOR
402 Zero -> GL_ZERO
403
404textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum
405textureDataTypeToGLType Color a = case a of
406 FloatT Red -> GL_R32F
407 IntT Red -> GL_R32I
408 WordT Red -> GL_R32UI
409 FloatT RG -> GL_RG32F
410 IntT RG -> GL_RG32I
411 WordT RG -> GL_RG32UI
412 FloatT RGBA -> GL_RGBA32F
413 IntT RGBA -> GL_RGBA32I
414 WordT RGBA -> GL_RGBA32UI
415 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
416textureDataTypeToGLType Depth a = case a of
417 FloatT Red -> GL_DEPTH_COMPONENT32F
418 WordT Red -> GL_DEPTH_COMPONENT32
419 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
420textureDataTypeToGLType Stencil a = case a of
421 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
422
423textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum
424textureDataTypeToGLArityType Color a = case a of
425 FloatT Red -> GL_RED
426 IntT Red -> GL_RED
427 WordT Red -> GL_RED
428 FloatT RG -> GL_RG
429 IntT RG -> GL_RG
430 WordT RG -> GL_RG
431 FloatT RGBA -> GL_RGBA
432 IntT RGBA -> GL_RGBA
433 WordT RGBA -> GL_RGBA
434 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
435textureDataTypeToGLArityType Depth a = case a of
436 FloatT Red -> GL_DEPTH_COMPONENT
437 WordT Red -> GL_DEPTH_COMPONENT
438 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
439textureDataTypeToGLArityType Stencil a = case a of
440 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
441{-
442Texture and renderbuffer color formats (R):
443 R11F_G11F_B10F
444 R16
445 R16F
446 R16I
447 R16UI
448 R32F
449 R32I
450 R32UI
451 R8
452 R8I
453 R8UI
454 RG16
455 RG16F
456 RG16I
457 RG16UI
458 RG32F
459 RG32I
460 RG32UI
461 RG8
462 RG8I
463 RG8UI
464 RGB10_A2
465 RGB10_A2UI
466 RGBA16
467 RGBA16F
468 RGBA16I
469 RGBA16UI
470 RGBA32F
471 RGBA32I
472 RGBA32UI
473 RGBA8
474 RGBA8I
475 RGBA8UI
476 SRGB8_ALPHA8
477-}
478
479glGetIntegerv1 :: GLenum -> IO GLint
480glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi
481
482checkFBO :: IO ByteString
483checkFBO = do
484 let f e | e == GL_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"
485 | e == GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"
486 | e == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"
487 | e == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"
488 | e == GL_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"
489 | e == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"
490 | e == GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"
491 | e == GL_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"
492 | otherwise = "Unknown error"
493 e <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER
494 return $ f e
495
496filterToGLType :: Filter -> GLenum
497filterToGLType a = case a of
498 Nearest -> GL_NEAREST
499 Linear -> GL_LINEAR
500 NearestMipmapNearest -> GL_NEAREST_MIPMAP_NEAREST
501 NearestMipmapLinear -> GL_NEAREST_MIPMAP_LINEAR
502 LinearMipmapNearest -> GL_LINEAR_MIPMAP_NEAREST
503 LinearMipmapLinear -> GL_LINEAR_MIPMAP_LINEAR
504
505edgeModeToGLType :: EdgeMode -> GLenum
506edgeModeToGLType a = case a of
507 Repeat -> GL_REPEAT
508 MirroredRepeat -> GL_MIRRORED_REPEAT
509 ClampToEdge -> GL_CLAMP_TO_EDGE
510 ClampToBorder -> GL_CLAMP_TO_BORDER
511
512setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()
513setTextureSamplerParameters t s = do
514 glTexParameteri t GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
515 case samplerWrapT s of
516 Nothing -> return ()
517 Just a -> glTexParameteri t GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
518 case samplerWrapR s of
519 Nothing -> return ()
520 Just a -> glTexParameteri t GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
521 glTexParameteri t GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
522 glTexParameteri t GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
523
524 let setBColorV4F a = with a $ \p -> glTexParameterfv t GL_TEXTURE_BORDER_COLOR $ castPtr p
525 setBColorV4I a = with a $ \p -> glTexParameterIiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
526 setBColorV4U a = with a $ \p -> glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
527 case samplerBorderColor s of
528 -- float, word, int, red, rg, rgb, rgba
529 VFloat a -> setBColorV4F $ V4 a 0 0 0
530 VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0
531 VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0
532 VV4F a -> setBColorV4F a
533
534 VInt a -> setBColorV4I $ V4 a 0 0 0
535 VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0
536 VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0
537 VV4I a -> setBColorV4I a
538
539 VWord a -> setBColorV4U $ V4 a 0 0 0
540 VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0
541 VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0
542 VV4U a -> setBColorV4U a
543 _ -> fail "internal error (setTextureSamplerParameters)!"
544
545 case samplerMinLod s of
546 Nothing -> return ()
547 Just a -> glTexParameterf t GL_TEXTURE_MIN_LOD $ realToFrac a
548 case samplerMaxLod s of
549 Nothing -> return ()
550 Just a -> glTexParameterf t GL_TEXTURE_MAX_LOD $ realToFrac a
551 glTexParameterf t GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
552 case samplerCompareFunc s of
553 Nothing -> glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE
554 Just a -> do
555 glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE
556 glTexParameteri t GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
557
558compileTexture :: TextureDescriptor -> IO GLTexture
559compileTexture txDescriptor = do
560 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
561 let TextureDescriptor
562 { textureType = txType
563 , textureSize = txSize
564 , textureSemantic = txSemantic
565 , textureSampler = txSampler
566 , textureBaseLevel = txBaseLevel
567 , textureMaxLevel = txMaxLevel
568 } = txDescriptor
569
570 txSetup txTarget dTy = do
571 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy
572 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy
573 glBindTexture txTarget to
574 glTexParameteri txTarget GL_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel
575 glTexParameteri txTarget GL_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel
576 setTextureSamplerParameters txTarget txSampler
577 return (internalFormat,dataFormat)
578
579 mipSize 0 x = [x]
580 mipSize n x = x : mipSize (n-1) (x `div` 2)
581 mipS = mipSize (txMaxLevel - txBaseLevel)
582 levels = [txBaseLevel..txMaxLevel]
583 target <- case txType of
584 Texture1D dTy layerCnt -> do
585 let VWord txW = txSize
586 txTarget = if layerCnt > 1 then GL_TEXTURE_1D_ARRAY else GL_TEXTURE_1D
587 (internalFormat,dataFormat) <- txSetup txTarget dTy
588 forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of
589 True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
590 False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
591 return txTarget
592 Texture2D dTy layerCnt -> do
593 let VV2U (V2 txW txH) = txSize
594 txTarget = if layerCnt > 1 then GL_TEXTURE_2D_ARRAY else GL_TEXTURE_2D
595 (internalFormat,dataFormat) <- txSetup txTarget dTy
596 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of
597 True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
598 False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
599 return txTarget
600 Texture3D dTy -> do
601 let VV3U (V3 txW txH txD) = txSize
602 txTarget = GL_TEXTURE_3D
603 (internalFormat,dataFormat) <- txSetup txTarget dTy
604 forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) ->
605 glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
606 return txTarget
607 TextureCube dTy -> do
608 let VV2U (V2 txW txH) = txSize
609 txTarget = GL_TEXTURE_CUBE_MAP
610 targets =
611 [ GL_TEXTURE_CUBE_MAP_POSITIVE_X
612 , GL_TEXTURE_CUBE_MAP_NEGATIVE_X
613 , GL_TEXTURE_CUBE_MAP_POSITIVE_Y
614 , GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
615 , GL_TEXTURE_CUBE_MAP_POSITIVE_Z
616 , GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
617 ]
618 (internalFormat,dataFormat) <- txSetup txTarget dTy
619 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
620 forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
621 return txTarget
622 TextureRect dTy -> do
623 let VV2U (V2 txW txH) = txSize
624 txTarget = GL_TEXTURE_RECTANGLE
625 (internalFormat,dataFormat) <- txSetup txTarget dTy
626 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
627 glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
628 return txTarget
629 Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do
630 let VV2U (V2 w h) = txSize
631 txTarget = if layerCnt > 1 then GL_TEXTURE_2D_MULTISAMPLE_ARRAY else GL_TEXTURE_2D_MULTISAMPLE
632 isFixed = fromIntegral $ if isFixedLocations then GL_TRUE else GL_FALSE
633 (internalFormat,dataFormat) <- txSetup txTarget dTy
634 case layerCnt > 1 of
635 True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed
636 False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed
637 return txTarget
638 TextureBuffer dTy -> do
639 fail "internal error: buffer texture is not supported yet"
640 -- TODO
641 let VV2U (V2 w h) = txSize
642 txTarget = GL_TEXTURE_2D
643 (internalFormat,dataFormat) <- txSetup txTarget dTy
644 glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
645 return txTarget
646 return $ GLTexture
647 { glTextureObject = to
648 , glTextureTarget = target
649 }
650
651primitiveToFetchPrimitive :: Primitive -> FetchPrimitive
652primitiveToFetchPrimitive prim = case prim of
653 TriangleStrip -> Triangles
654 TriangleList -> Triangles
655 TriangleFan -> Triangles
656 LineStrip -> Lines
657 LineList -> Lines
658 PointList -> Points
659 TriangleStripAdjacency -> TrianglesAdjacency
660 TriangleListAdjacency -> TrianglesAdjacency
661 LineStripAdjacency -> LinesAdjacency
662 LineListAdjacency -> LinesAdjacency
663
664primitiveToGLType :: Primitive -> GLenum
665primitiveToGLType p = case p of
666 TriangleStrip -> GL_TRIANGLE_STRIP
667 TriangleList -> GL_TRIANGLES
668 TriangleFan -> GL_TRIANGLE_FAN
669 LineStrip -> GL_LINE_STRIP
670 LineList -> GL_LINES
671 PointList -> GL_POINTS
672 TriangleStripAdjacency -> GL_TRIANGLE_STRIP_ADJACENCY
673 TriangleListAdjacency -> GL_TRIANGLES_ADJACENCY
674 LineStripAdjacency -> GL_LINE_STRIP_ADJACENCY
675 LineListAdjacency -> GL_LINES_ADJACENCY
676
677inputTypeToTextureTarget :: InputType -> GLenum
678inputTypeToTextureTarget ty = case ty of
679 STexture1D -> GL_TEXTURE_1D
680 STexture2D -> GL_TEXTURE_2D
681 STextureCube -> GL_TEXTURE_CUBE_MAP
682 STexture1DArray -> GL_TEXTURE_1D_ARRAY
683 STexture2DArray -> GL_TEXTURE_2D_ARRAY
684 STexture2DRect -> GL_TEXTURE_RECTANGLE
685
686 FTexture1D -> GL_TEXTURE_1D
687 FTexture2D -> GL_TEXTURE_2D
688 FTexture3D -> GL_TEXTURE_3D
689 FTextureCube -> GL_TEXTURE_CUBE_MAP
690 FTexture1DArray -> GL_TEXTURE_1D_ARRAY
691 FTexture2DArray -> GL_TEXTURE_2D_ARRAY
692 FTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
693 FTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
694 FTextureBuffer -> GL_TEXTURE_BUFFER
695 FTexture2DRect -> GL_TEXTURE_RECTANGLE
696
697 ITexture1D -> GL_TEXTURE_1D
698 ITexture2D -> GL_TEXTURE_2D
699 ITexture3D -> GL_TEXTURE_3D
700 ITextureCube -> GL_TEXTURE_CUBE_MAP
701 ITexture1DArray -> GL_TEXTURE_1D_ARRAY
702 ITexture2DArray -> GL_TEXTURE_2D_ARRAY
703 ITexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
704 ITexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
705 ITextureBuffer -> GL_TEXTURE_BUFFER
706 ITexture2DRect -> GL_TEXTURE_RECTANGLE
707
708 UTexture1D -> GL_TEXTURE_1D
709 UTexture2D -> GL_TEXTURE_2D
710 UTexture3D -> GL_TEXTURE_3D
711 UTextureCube -> GL_TEXTURE_CUBE_MAP
712 UTexture1DArray -> GL_TEXTURE_1D_ARRAY
713 UTexture2DArray -> GL_TEXTURE_2D_ARRAY
714 UTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
715 UTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
716 UTextureBuffer -> GL_TEXTURE_BUFFER
717 UTexture2DRect -> GL_TEXTURE_RECTANGLE
718
719 _ -> error "internal error (inputTypeToTextureTarget)!"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 01:48:22 +0000