summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Backend/GL.hs86
-rw-r--r--Backend/GL/Backend.hs665
-rw-r--r--Backend/GL/Data.hs95
-rw-r--r--Backend/GL/Input.hs381
-rw-r--r--Backend/GL/Mesh.hs232
-rw-r--r--Backend/GL/Type.hs530
-rw-r--r--Backend/GL/Util.hs717
-rw-r--r--LICENSE40
-rw-r--r--Monkey.lcmeshbin0 -> 371791 bytes
-rw-r--r--SampleIR.hs241
-rw-r--r--lambdacube-gl-ir.cabal86
-rw-r--r--tests/sampleIR.hs3
12 files changed, 3057 insertions, 19 deletions
diff --git a/Backend/GL.hs b/Backend/GL.hs
new file mode 100644
index 0000000..04d5dde
--- /dev/null
+++ b/Backend/GL.hs
@@ -0,0 +1,86 @@
1module Backend.GL (
2 -- IR
3 V2(..),V3(..),V4(..),
4 -- Array, Buffer, Texture
5 Array(..),
6 ArrayType(..),
7 Buffer,
8 BufferSetter,
9 IndexStream(..),
10 Stream(..),
11 StreamSetter,
12 StreamType(..),
13 Primitive(..),
14 SetterFun,
15 TextureData,
16 InputSetter(..),
17 fromStreamType,
18 sizeOfArrayType,
19 toStreamType,
20 compileBuffer,
21 updateBuffer,
22 bufferSize,
23 arraySize,
24 arrayType,
25 compileTexture2DRGBAF,
26
27 -- GL Pipeline Input, Object
28 GLPipeline,
29 GLPipelineInput,
30 Object,
31 PipelineSchema(..),
32 SlotSchema(..),
33 schema,
34 schemaFromPipeline,
35 allocPipeline,
36 disposePipeline,
37 setPipelineInput,
38 renderPipeline,
39 mkGLPipelineInput,
40 uniformSetter,
41 addObject,
42 removeObject,
43 enableObject,
44 setObjectOrder,
45 objectUniformSetter,
46 setScreenSize,
47 sortSlotObjects,
48
49 uniformBool,
50 uniformV2B,
51 uniformV3B,
52 uniformV4B,
53
54 uniformWord,
55 uniformV2U,
56 uniformV3U,
57 uniformV4U,
58
59 uniformInt,
60 uniformV2I,
61 uniformV3I,
62 uniformV4I,
63
64 uniformFloat,
65 uniformV2F,
66 uniformV3F,
67 uniformV4F,
68
69 uniformM22F,
70 uniformM23F,
71 uniformM24F,
72 uniformM32F,
73 uniformM33F,
74 uniformM34F,
75 uniformM42F,
76 uniformM43F,
77 uniformM44F,
78
79 uniformFTexture2D
80) where
81
82import Backend.GL.Type
83import Backend.GL.Backend
84import Backend.GL.Data
85import Backend.GL.Input
86import IR \ No newline at end of file
diff --git a/Backend/GL/Backend.hs b/Backend/GL/Backend.hs
new file mode 100644
index 0000000..7e6a9d4
--- /dev/null
+++ b/Backend/GL/Backend.hs
@@ -0,0 +1,665 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns #-}
2module Backend.GL.Backend where
3
4import Control.Applicative
5import Control.Monad
6import Control.Monad.State
7import Data.Bits
8import Data.ByteString.Char8 (ByteString,pack)
9import Data.IORef
10import Data.IntMap (IntMap)
11import Data.Maybe (isNothing)
12import Data.Set (Set)
13import Data.Trie as T
14import Data.Vector (Vector,(!),(//))
15import qualified Data.ByteString.Char8 as SB
16import qualified Data.Foldable as F
17import qualified Data.IntMap as IM
18import qualified Data.Map as Map
19import qualified Data.List as L
20import qualified Data.Set as S
21import qualified Data.Vector as V
22import qualified Data.Vector.Mutable as MV
23
24import Graphics.Rendering.OpenGL.Raw.Core33
25import Foreign
26
27-- LC IR imports
28import IR as IR
29
30import Backend.GL.Type
31import Backend.GL.Util
32
33import Backend.GL.Input
34
35setupRasterContext :: RasterContext -> IO ()
36setupRasterContext = cvt
37 where
38 cff :: FrontFace -> GLenum
39 cff CCW = gl_CCW
40 cff CW = gl_CW
41
42 setProvokingVertex :: ProvokingVertex -> IO ()
43 setProvokingVertex pv = glProvokingVertex $ case pv of
44 FirstVertex -> gl_FIRST_VERTEX_CONVENTION
45 LastVertex -> gl_LAST_VERTEX_CONVENTION
46
47 setPointSize :: PointSize -> IO ()
48 setPointSize ps = case ps of
49 ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE
50 PointSize s -> do
51 glDisable gl_PROGRAM_POINT_SIZE
52 glPointSize $ realToFrac s
53
54 cvt :: RasterContext -> IO ()
55 cvt (PointCtx ps fts sc) = do
56 setPointSize ps
57 glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
58 glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
59 LowerLeft -> gl_LOWER_LEFT
60 UpperLeft -> gl_UPPER_LEFT
61
62 cvt (LineCtx lw pv) = do
63 glLineWidth (realToFrac lw)
64 setProvokingVertex pv
65
66 cvt (TriangleCtx cm pm po pv) = do
67 -- cull mode
68 case cm of
69 CullNone -> glDisable gl_CULL_FACE
70 CullFront f -> do
71 glEnable gl_CULL_FACE
72 glCullFace gl_FRONT
73 glFrontFace $ cff f
74 CullBack f -> do
75 glEnable gl_CULL_FACE
76 glCullFace gl_BACK
77 glFrontFace $ cff f
78
79 -- polygon mode
80 case pm of
81 PolygonPoint ps -> do
82 setPointSize ps
83 glPolygonMode gl_FRONT_AND_BACK gl_POINT
84 PolygonLine lw -> do
85 glLineWidth (realToFrac lw)
86 glPolygonMode gl_FRONT_AND_BACK gl_LINE
87 PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL
88
89 -- polygon offset
90 glDisable gl_POLYGON_OFFSET_POINT
91 glDisable gl_POLYGON_OFFSET_LINE
92 glDisable gl_POLYGON_OFFSET_FILL
93 case po of
94 NoOffset -> return ()
95 Offset f u -> do
96 glPolygonOffset (realToFrac f) (realToFrac u)
97 glEnable $ case pm of
98 PolygonPoint _ -> gl_POLYGON_OFFSET_POINT
99 PolygonLine _ -> gl_POLYGON_OFFSET_LINE
100 PolygonFill -> gl_POLYGON_OFFSET_FILL
101
102 -- provoking vertex
103 setProvokingVertex pv
104
105setupAccumulationContext :: AccumulationContext -> IO ()
106setupAccumulationContext (AccumulationContext n ops) = cvt ops
107 where
108 cvt :: [FragmentOperation] -> IO ()
109 cvt (StencilOp a b c : DepthOp f m : xs) = do
110 -- TODO
111 cvtC 0 xs
112 cvt (StencilOp a b c : xs) = do
113 -- TODO
114 cvtC 0 xs
115 cvt (DepthOp df dm : xs) = do
116 -- TODO
117 glDisable gl_STENCIL_TEST
118 case df == Always && dm == False of
119 True -> glDisable gl_DEPTH_TEST
120 False -> do
121 glEnable gl_DEPTH_TEST
122 glDepthFunc $! comparisonFunctionToGLType df
123 glDepthMask (cvtBool dm)
124 cvtC 0 xs
125 cvt xs = do
126 glDisable gl_DEPTH_TEST
127 glDisable gl_STENCIL_TEST
128 cvtC 0 xs
129
130 cvtC :: Int -> [FragmentOperation] -> IO ()
131 cvtC i (ColorOp b m : xs) = do
132 -- TODO
133 case b of
134 NoBlending -> do
135 -- FIXME: requires GL 3.1
136 --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
137 glDisable gl_BLEND -- workaround
138 glDisable gl_COLOR_LOGIC_OP
139 BlendLogicOp op -> do
140 glDisable gl_BLEND
141 glEnable gl_COLOR_LOGIC_OP
142 glLogicOp $ logicOperationToGLType op
143 Blend (cEq,aEq) ((scF,dcF),(saF,daF)) (V4 r g b a) -> do
144 glDisable gl_COLOR_LOGIC_OP
145 -- FIXME: requires GL 3.1
146 --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
147 glEnable gl_BLEND -- workaround
148 glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)
149 glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)
150 (blendingFactorToGLType saF) (blendingFactorToGLType daF)
151 glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
152 let cvt True = 1
153 cvt False = 0
154 (mr,mg,mb,ma) = case m of
155 VBool r -> (cvt r, 1, 1, 1)
156 VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)
157 VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)
158 VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)
159 _ -> (1,1,1,1)
160 glColorMask mr mg mb ma
161 cvtC (i + 1) xs
162 cvtC _ [] = return ()
163
164 cvtBool :: Bool -> GLboolean
165 cvtBool True = 1
166 cvtBool False = 0
167
168clearRenderTarget :: [(ImageSemantic,Value)] -> IO ()
169clearRenderTarget values = do
170 let setClearValue (m,i) value = case value of
171 (Depth, VFloat v) -> do
172 glDepthMask 1
173 glClearDepth $ realToFrac v
174 return (m .|. gl_DEPTH_BUFFER_BIT, i)
175 (Stencil, VWord v) -> do
176 glClearStencil $ fromIntegral v
177 return (m .|. gl_STENCIL_BUFFER_BIT, i)
178 (Color, c) -> do
179 let (r,g,b,a) = case c of
180 VFloat r -> (realToFrac r, 0, 0, 1)
181 VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)
182 VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)
183 VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
184 _ -> (0,0,0,1)
185 glColorMask 1 1 1 1
186 glClearColor r g b a
187 return (m .|. gl_COLOR_BUFFER_BIT, i+1)
188 _ -> error "internal error (clearRenderTarget)"
189 (mask,_) <- foldM setClearValue (0,0) values
190 glClear $ fromIntegral mask
191
192
193printGLStatus = checkGL >>= print
194printFBOStatus = checkFBO >>= print
195
196compileProgram :: Trie InputType -> Program -> IO GLProgram
197compileProgram uniTrie p = do
198 po <- glCreateProgram
199 putStrLn $ "compile program: " ++ show po
200 let createAndAttach src t = do
201 o <- glCreateShader t
202 compileShader o $ map pack [src]
203 glAttachShader po o
204 putStr " + compile shader source: " >> printGLStatus
205 return o
206
207 objs <- sequence $ createAndAttach (vertexShader p) gl_VERTEX_SHADER : createAndAttach (fragmentShader p) gl_FRAGMENT_SHADER : case geometryShader p of
208 Nothing -> []
209 Just s -> [createAndAttach s gl_GEOMETRY_SHADER]
210
211 forM_ (zip (programOutput p) [0..]) $ \((pack -> n,t),i) -> SB.useAsCString n $ \pn -> do
212 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
213 glBindFragDataLocation po i $ castPtr pn
214 putStr " + setup shader output mapping: " >> printGLStatus
215
216 glLinkProgram po
217 printProgramLog po
218
219 -- check link status
220 status <- glGetProgramiv1 gl_LINK_STATUS po
221 when (status /= fromIntegral gl_TRUE) $ fail "link program failed!"
222
223 -- check program input
224 (uniforms,uniformsType) <- queryUniforms po
225 (attributes,attributesType) <- queryStreams po
226 print uniforms
227 print attributes
228 when (uniformsType /= (toTrie $ programUniforms p) `unionL` (toTrie $ programInTextures p)) $ fail "shader program uniform input mismatch!"
229 when (attributesType /= fmap snd (toTrie $ programStreams p)) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,fmap snd (toTrie $ programStreams p))
230 -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input
231 let inUniNames = toTrie $ programUniforms p
232 (inUniforms,inTextures) = L.partition (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms
233 texUnis = [n | (n,_) <- inTextures, T.member n uniTrie]
234 return $ GLProgram
235 { shaderObjects = objs
236 , programObject = po
237 , inputUniforms = T.fromList inUniforms
238 , inputTextures = T.fromList inTextures
239 , inputTextureUniforms = S.fromList $ texUnis
240 , inputStreams = T.fromList [(n,(idx,pack attrName)) | ((n,idx),(_,(attrName,_))) <- zip (T.toList $ attributes) (T.toList $ toTrie $ programStreams p)]
241 }
242
243compileSampler :: SamplerDescriptor -> IO GLSampler
244compileSampler s = return $ GLSampler {}
245
246{-
247data ImageIndex
248 = TextureImage TextureName Int (Maybe Int) -- Texture name, mip index, array index
249 | Framebuffer ImageSemantic
250
251data ImageSemantic
252 = Depth
253 | Stencil
254 | Color
255-}
256{-
257 = RenderTarget
258 { renderTargets :: [(ImageSemantic,Maybe ImageIndex)] -- render texture or default framebuffer (semantic, render texture for the program output)
259 }
260-}
261{-
262 glDrawBuffers
263 GL_NONE
264 --GL_FRONT_LEFT
265 --GL_FRONT_RIGHT
266 GL_BACK_LEFT
267 --GL_BACK_RIGHT
268 GL_COLOR_ATTACHMENTn
269-}
270compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
271compileRenderTarget texs glTexs (RenderTarget targets) = do
272 let isFB (Framebuffer _) = True
273 isFB _ = False
274 images = [img | (_,Just img) <- targets]
275 case all isFB images of
276 True -> do
277 let bufs = [cvt img | (Color,img) <- targets]
278 cvt a = case a of
279 Nothing -> gl_NONE
280 Just (Framebuffer Color) -> gl_BACK_LEFT
281 _ -> error "internal error (compileRenderTarget)!"
282 return $ GLRenderTarget
283 { framebufferObject = 0
284 , framebufferDrawbuffers = Just bufs
285 }
286 False -> do
287 when (any isFB images) $ fail "internal error (compileRenderTarget)!"
288 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
289 glBindFramebuffer gl_DRAW_FRAMEBUFFER fbo
290 {-
291 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
292 GL_TEXTURE_1D
293 void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
294 GL_TEXTURE_2D
295 GL_TEXTURE_RECTANGLE
296 GL_TEXTURE_CUBE_MAP_POSITIVE_X
297 GL_TEXTURE_CUBE_MAP_POSITIVE_Y
298 GL_TEXTURE_CUBE_MAP_POSITIVE_Z
299 GL_TEXTURE_CUBE_MAP_NEGATIVE_X
300 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
301 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
302 GL_TEXTURE_2D_MULTISAMPLE
303 void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer);
304 void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer);
305 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);
306 -}
307 let attach attachment (TextureImage texIdx level (Just layer)) =
308 glFramebufferTextureLayer gl_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
309 attach attachment (TextureImage texIdx level Nothing) = do
310 let glTex = glTexs ! texIdx
311 tex = texs ! texIdx
312 txLevel = fromIntegral level
313 txTarget = glTextureTarget glTex
314 txObj = glTextureObject glTex
315 attachArray = glFramebufferTexture gl_DRAW_FRAMEBUFFER attachment txObj txLevel
316 attach2D = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
317 case textureType tex of
318 Texture1D _ n
319 | n > 1 -> attachArray
320 | otherwise -> glFramebufferTexture1D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
321 Texture2D _ n
322 | n > 1 -> attachArray
323 | otherwise -> attach2D
324 Texture3D _ -> attachArray
325 TextureCube _ -> attachArray
326 TextureRect _ -> attach2D
327 Texture2DMS _ n _ _
328 | n > 1 -> attachArray
329 | otherwise -> attach2D
330 TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"
331
332 go a (Stencil,Just img) = do
333 fail "Stencil support is not implemented yet!"
334 return a
335 go a (Depth,Just img) = do
336 attach gl_DEPTH_ATTACHMENT img
337 return a
338 go (bufs,colorIdx) (Color,Just img) = do
339 let attachment = gl_COLOR_ATTACHMENT0 + fromIntegral colorIdx
340 attach attachment img
341 return (attachment : bufs, colorIdx + 1)
342 go (bufs,colorIdx) (Color,Nothing) = return (gl_NONE : bufs, colorIdx + 1)
343 go a _ = return a
344 (bufs,_) <- foldM go ([],0) targets
345 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
346 return $ GLRenderTarget
347 { framebufferObject = fbo
348 , framebufferDrawbuffers = Nothing
349 }
350
351allocPipeline :: Pipeline -> IO GLPipeline
352allocPipeline p = do
353 let uniTrie = uniforms $ schemaFromPipeline p
354 smps <- V.mapM compileSampler $ samplers p
355 texs <- V.mapM compileTexture $ textures p
356 trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
357 prgs <- V.mapM (compileProgram uniTrie) $ programs p
358 -- texture unit mapping ioref trie
359 texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p)
360 let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ commands p) initCGState
361 input <- newIORef Nothing
362 -- default Vertex Array Object
363 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
364 return $ GLPipeline
365 { glPrograms = prgs
366 , glTextures = texs
367 , glSamplers = smps
368 , glTargets = trgs
369 , glCommands = cmds
370 , glSlotPrograms = V.map slotPrograms $ IR.slots p
371 , glInput = input
372 , glSlotNames = V.map (pack . slotName) $ IR.slots p
373 , glVAO = vao
374 , glTexUnitMapping = texUnitMapRefs
375 }
376
377disposePipeline :: GLPipeline -> IO ()
378disposePipeline p = do
379 setPipelineInput p Nothing
380 V.forM_ (glPrograms p) $ \prg -> do
381 glDeleteProgram $ programObject prg
382 mapM_ glDeleteShader $ shaderObjects prg
383 let targets = glTargets p
384 withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
385 let textures = glTextures p
386 withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
387 with (glVAO p) $ (glDeleteVertexArrays 1)
388
389{-
390data SlotSchema
391 = SlotSchema
392 { primitive :: FetchPrimitive
393 , attributes :: Trie StreamType
394 }
395 deriving Show
396
397data PipelineSchema
398 = PipelineSchema
399 { slots :: Trie SlotSchema
400 , uniforms :: Trie InputType
401 }
402 deriving Show
403-}
404isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool
405isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset]
406 where
407 isMember a Nothing = False
408 isMember a (Just b) = eqFun a b
409
410-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms
411{-
412 let sch = schema input
413 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
414 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
415 _ -> return ()
416 case T.lookup slotName (slots sch) of
417 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
418 Just (SlotSchema sPrim sAttrs) -> do
419 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
420 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
421 let sType = fmap streamToStreamType attribs
422 when (sType /= sAttrs) $ throw $ userError $ unlines $
423 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
424 , show sAttrs
425 , " but got "
426 , show sType
427 ]
428-}
429setPipelineInput :: GLPipeline -> Maybe GLPipelineInput -> IO ()
430setPipelineInput p input' = do
431 -- TODO: check matching input schema
432 {-
433 case input' of
434 Nothing -> return ()
435 Just input -> schemaFromPipeline p
436 -}
437 {-
438 deletion:
439 - remove pipeline's object commands from used slots
440 - remove pipeline from attached pipelines vector
441 -}
442 ic' <- readIORef $ glInput p
443 case ic' of
444 Nothing -> return ()
445 Just ic -> do
446 let idx = icId ic
447 oldInput = icInput ic
448 slotMask = icSlotMapPipelineToInput ic
449 slotRefs = slotVector oldInput
450 modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)]
451 V.forM_ slotMask $ \slotIdx -> do
452 slot <- readIORef (slotRefs ! slotIdx)
453 forM_ (IM.elems $ objectMap slot) $ \obj -> do
454 modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)]
455 {-
456 addition:
457 - get an id from pipeline input
458 - add to attached pipelines
459 - generate slot mappings
460 - update used slots, and generate object commands for objects in the related slots
461 -}
462 case input' of
463 Nothing -> writeIORef (glInput p) Nothing
464 Just input -> do
465 let pipelinesRef = pipelines input
466 oldPipelineV <- readIORef pipelinesRef
467 (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
468 Nothing -> do
469 -- we don't have empty space, hence we double the vector size
470 let len = V.length oldPipelineV
471 modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]
472 return (len,Just len)
473 Just i -> do
474 modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]
475 return (i,Nothing)
476 -- create input connection
477 let sm = slotMap input
478 pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm]
479 iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
480 writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP
481
482 -- generate object commands for related slots
483 {-
484 for each slot in pipeline:
485 map slot name to input slot name
486 for each object:
487 generate command program vector => for each dependent program:
488 generate object commands
489 -}
490 let slotV = slotVector input
491 progV = glPrograms p
492 texUnitMap = glTexUnitMapping p
493 topUnis = uniformSetup input
494 emptyV = V.replicate (V.length progV) []
495 extend v = case shouldExtend of
496 Nothing -> v
497 Just l -> V.concat [v,V.replicate l V.empty]
498 V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do
499 slot <- readIORef $ slotV ! slotIdx
500 forM_ (IM.elems $ objectMap slot) $ \obj -> do
501 let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
502 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
503{-
504 track state:
505 - render target
506 - binded textures
507-}
508
509{-
510 render steps:
511 - update uniforms
512 - per uniform setup
513 - buffer setup (one buffer per object, which has per at least one object uniform)
514 - new command: set uniform buffer (binds uniform buffer to program's buffer slot)
515 - render slot steps:
516 - set uniform buffer or set uniforms separately
517 - set vertex and index array
518 - call draw command
519-}
520{-
521 storage alternatives:
522 - interleaved / separated
523 - VAO or VBOs
524-}
525 {-
526 strategy:
527 step 1: generate commands for an object
528 step 2: sort object merge and do optimization by filtering redundant commands
529 -}
530{-
531 design:
532 runtime eleminiation of redundant buffer bind commands and redundant texture bind commands
533-}
534{-
535 track:
536 buffer binding on various targets: gl_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER
537 glEnable/DisableVertexAttribArray
538-}
539renderSlot :: [GLObjectCommand] -> IO ()
540renderSlot cmds = forM_ cmds $ \cmd -> do
541 case cmd of
542 GLSetVertexAttribArray idx buf size typ ptr -> do
543 glBindBuffer gl_ARRAY_BUFFER buf
544 glEnableVertexAttribArray idx
545 glVertexAttribPointer idx size typ (fromIntegral gl_FALSE) 0 ptr
546 GLSetVertexAttribIArray idx buf size typ ptr -> do
547 glBindBuffer gl_ARRAY_BUFFER buf
548 glEnableVertexAttribArray idx
549 glVertexAttribIPointer idx size typ 0 ptr
550 GLDrawArrays mode first count -> glDrawArrays mode first count
551 GLDrawElements mode count typ buf indicesPtr -> do
552 glBindBuffer gl_ELEMENT_ARRAY_BUFFER buf
553 glDrawElements mode count typ indicesPtr
554 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
555 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
556 txObjVal <- readIORef ref
557 -- HINT: ugly and hacky
558 with txObjVal $ \txObjPtr -> do
559 txObj <- peek $ castPtr txObjPtr :: IO GLuint
560 texUnit <- readIORef tuRef
561 glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit
562 glBindTexture txTarget txObj
563 GLSetVertexAttrib idx val -> do
564 glDisableVertexAttribArray idx
565 setVertexAttrib idx val
566 --isOk <- checkGL
567 --putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
568
569renderPipeline :: GLPipeline -> IO ()
570renderPipeline glp = do
571 glBindVertexArray (glVAO glp)
572 forM_ (glCommands glp) $ \cmd -> do
573 case cmd of
574 GLSetRasterContext rCtx -> setupRasterContext rCtx
575 GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx
576 GLSetRenderTarget rt bufs -> do
577 -- set target viewport
578 when (rt == 0) $ do -- screen out
579 ic' <- readIORef $ glInput glp
580 case ic' of
581 Nothing -> return ()
582 Just ic -> do
583 let input = icInput ic
584 (w,h) <- readIORef $ screenSize input
585 glViewport 0 0 (fromIntegral w) (fromIntegral h)
586 -- TODO: set FBO target viewport
587 glBindFramebuffer gl_DRAW_FRAMEBUFFER rt
588 case bufs of
589 Nothing -> return ()
590 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
591 GLSetProgram p -> glUseProgram p
592 GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu
593 GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx
594 GLClearRenderTarget vals -> clearRenderTarget vals
595 GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target
596 GLRenderSlot slotIdx progIdx -> do
597 input <- readIORef (glInput glp)
598 case input of
599 Nothing -> putStrLn "Warning: No pipeline input!" >> return ()
600 Just ic -> do
601 GLSlot _ objs _ <- readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx))
602 --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects"
603 V.forM_ objs $ \(_,obj) -> do
604 enabled <- readIORef $ objEnabled obj
605 when enabled $ do
606 cmd <- readIORef $ objCommands obj
607 --putStrLn "Render object"
608 renderSlot ((cmd ! icId ic) ! progIdx)
609 {-
610 GLSetSampler
611 GLSaveImage
612 GLLoadImage
613 -}
614 --isOk <- checkGL
615 --putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
616
617data CGState
618 = CGState
619 { currentProgram :: ProgramName
620 , textureBinding :: IntMap GLTexture
621 }
622
623initCGState = CGState
624 { currentProgram = error "CGState: empty currentProgram"
625 , textureBinding = IM.empty
626 }
627
628type CG a = State CGState a
629
630compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand
631compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
632 SetRasterContext rCtx -> return $ GLSetRasterContext rCtx
633 SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx
634 SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs
635 SetProgram p -> do
636 modify (\s -> s {currentProgram = p})
637 return $ GLSetProgram $ programObject $ programs ! p
638 SetSamplerUniform n tu -> do
639 p <- currentProgram <$> get
640 case T.lookup (pack n) (inputTextures $ programs ! p) of
641 Nothing -> fail "internal error (SetSamplerUniform)!"
642 Just i -> case T.lookup (pack n) texUnitMap of
643 Nothing -> fail "internal error (SetSamplerUniform - IORef)!"
644 Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r
645 SetTexture tu t -> do
646 let tex = textures ! t
647 modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
648 return $ GLSetTexture (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
649{-
650 SetSampler tu s -> liftIO $ do
651 glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
652-}
653 RenderSlot slot -> do
654 p <- currentProgram <$> get
655 return $ GLRenderSlot slot p
656 ClearRenderTarget vals -> return $ GLClearRenderTarget vals
657 GenerateMipMap tu -> do
658 tb <- textureBinding <$> get
659 case IM.lookup tu tb of
660 Nothing -> fail "internal error (GenerateMipMap)!"
661 Just tex -> return $ GLGenerateMipMap (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
662{-
663 SaveImage _ _ -> undefined
664 LoadImage _ _ -> undefined
665-}
diff --git a/Backend/GL/Data.hs b/Backend/GL/Data.hs
new file mode 100644
index 0000000..4eb3fa0
--- /dev/null
+++ b/Backend/GL/Data.hs
@@ -0,0 +1,95 @@
1module Backend.GL.Data where
2
3import Control.Applicative
4import Control.Monad
5import Data.ByteString.Char8 (ByteString)
6import Data.IORef
7import Data.List as L
8import Data.Maybe
9import Data.Trie as T
10import Foreign
11--import qualified Data.IntMap as IM
12import qualified Data.Map as Map
13import qualified Data.Set as Set
14import qualified Data.Vector as V
15import qualified Data.Vector.Storable as SV
16
17--import Control.DeepSeq
18
19import Graphics.Rendering.OpenGL.Raw.Core33
20import Data.Word
21import Codec.Picture
22import Codec.Picture.RGBA8
23
24import Backend.GL.Type
25import Backend.GL.Util
26
27-- Buffer
28compileBuffer :: [Array] -> IO Buffer
29compileBuffer arrs = do
30 let calcDesc (offset,setters,descs) (Array arrType cnt setter) =
31 let size = cnt * sizeOfArrayType arrType
32 in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)
33 (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs
34 bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
35 glBindBuffer gl_ARRAY_BUFFER bo
36 glBufferData gl_ARRAY_BUFFER (fromIntegral bufSize) nullPtr gl_STATIC_DRAW
37 forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
38 glBindBuffer gl_ARRAY_BUFFER 0
39 return $! Buffer (V.fromList $! reverse arrDescs) bo
40
41updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
42updateBuffer (Buffer arrDescs bo) arrs = do
43 glBindBuffer gl_ARRAY_BUFFER bo
44 forM arrs $ \(i,Array arrType cnt setter) -> do
45 let ArrayDesc ty len offset size = arrDescs V.! i
46 when (ty == arrType && cnt == len) $
47 setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
48 glBindBuffer gl_ARRAY_BUFFER 0
49
50bufferSize :: Buffer -> Int
51bufferSize = V.length . bufArrays
52
53arraySize :: Buffer -> Int -> Int
54arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx
55
56arrayType :: Buffer -> Int -> ArrayType
57arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
58
59-- Texture
60
61-- FIXME: Temporary implemenation
62compileTexture2DRGBAF :: Bool -> Bool -> DynamicImage -> IO TextureData
63compileTexture2DRGBAF isMip isClamped bitmap' = do
64 let bitmap = ImageRGBA8 $ fromDynamicImage bitmap'
65 glPixelStorei gl_UNPACK_ALIGNMENT 1
66 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
67 glBindTexture gl_TEXTURE_2D to
68 let (width,height) = bitmapSize bitmap
69 bitmapSize (ImageRGB8 (Image w h _)) = (w,h)
70 bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)
71 bitmapSize _ = error "unsupported image type :("
72 withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0
73 withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0
74 withBitmap _ _ = error "unsupported image type :("
75 wrapMode = case isClamped of
76 True -> gl_CLAMP_TO_EDGE
77 False -> gl_REPEAT
78 (minFilter,maxLevel) = case isMip of
79 False -> (gl_LINEAR,0)
80 True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
81 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode
82 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode
83 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter
84 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR
85 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0
86 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
87 withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
88 let internalFormat = fromIntegral gl_RGBA8
89 dataFormat = fromIntegral $ case nchn of
90 3 -> gl_RGB
91 4 -> gl_RGBA
92 _ -> error "unsupported texture format!"
93 glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr
94 when isMip $ glGenerateMipmap gl_TEXTURE_2D
95 return $ TextureData to
diff --git a/Backend/GL/Input.hs b/Backend/GL/Input.hs
new file mode 100644
index 0000000..6d4f40f
--- /dev/null
+++ b/Backend/GL/Input.hs
@@ -0,0 +1,381 @@
1module Backend.GL.Input where
2
3import Control.Applicative
4import Control.Exception
5import Control.Monad
6import Data.ByteString.Char8 (ByteString,pack)
7import Data.IORef
8import Data.IntMap (IntMap)
9import Data.Trie (Trie)
10import Data.Trie.Convenience as T
11import Data.Vector (Vector,(//),(!))
12import Data.Word
13import Foreign
14import qualified Data.ByteString.Char8 as SB
15import qualified Data.IntMap as IM
16import qualified Data.Set as S
17import qualified Data.Map as Map
18import qualified Data.Trie as T
19import qualified Data.Vector as V
20import qualified Data.Vector.Algorithms.Intro as I
21
22import Graphics.Rendering.OpenGL.Raw.Core33
23
24import IR as IR
25import Backend.GL.Type as T
26import Backend.GL.Util
27
28import qualified IR as IR
29
30schemaFromPipeline :: IR.Pipeline -> PipelineSchema
31schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul)
32 where
33 (sl,ul) = unzip [((pack n,SlotSchema p (fmap cvt (toTrie s))),toTrie u) | IR.Slot n u s p _ <- V.toList $ IR.slots a]
34 cvt a = case toStreamType a of
35 Just v -> v
36 Nothing -> error "internal error (schemaFromPipeline)"
37
38mkUniform :: [(ByteString,InputType)] -> IO (Trie InputSetter, Trie GLUniform)
39mkUniform l = do
40 unisAndSetters <- forM l $ \(n,t) -> do
41 (uni, setter) <- mkUniformSetter t
42 return ((n,uni),(n,setter))
43 let (unis,setters) = unzip unisAndSetters
44 return (T.fromList setters, T.fromList unis)
45
46mkGLPipelineInput :: PipelineSchema -> IO GLPipelineInput
47mkGLPipelineInput sch = do
48 let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..]
49 len = T.size sm
50 (setters,unis) <- mkUniform $ T.toList $ uniforms sch
51 seed <- newIORef 0
52 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered)
53 size <- newIORef (0,0)
54 ppls <- newIORef $ V.singleton Nothing
55 return $ GLPipelineInput
56 { schema = sch
57 , slotMap = sm
58 , slotVector = slotV
59 , objSeed = seed
60 , uniformSetter = setters
61 , uniformSetup = unis
62 , screenSize = size
63 , pipelines = ppls
64 }
65
66-- object
67addObject :: GLPipelineInput -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
68addObject input slotName prim indices attribs uniformNames = do
69 let sch = schema input
70 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
71 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
72 _ -> return ()
73 case T.lookup slotName (T.slots sch) of
74 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
75 Just (SlotSchema sPrim sAttrs) -> do
76 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
77 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
78 let sType = fmap streamToStreamType attribs
79 when (sType /= sAttrs) $ throw $ userError $ unlines $
80 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
81 , show sAttrs
82 , " but got "
83 , show sType
84 ]
85
86 let slotIdx = case slotName `T.lookup` slotMap input of
87 Nothing -> error "internal error (slot index)"
88 Just i -> i
89 seed = objSeed input
90 order <- newIORef 0
91 enabled <- newIORef True
92 index <- readIORef seed
93 modifyIORef seed (1+)
94 (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = T.lookup n (uniforms sch)]
95 cmdsRef <- newIORef (V.singleton V.empty)
96 let obj = Object
97 { objSlot = slotIdx
98 , objPrimitive = prim
99 , objIndices = indices
100 , objAttributes = attribs
101 , objUniSetter = setters
102 , objUniSetup = unis
103 , objOrder = order
104 , objEnabled = enabled
105 , objId = index
106 , objCommands = cmdsRef
107 }
108
109 modifyIORef (slotVector input ! slotIdx) $ \(GLSlot objs _ _) -> GLSlot (IM.insert index obj objs) V.empty Generate
110
111 -- generate GLObjectCommands for the new object
112 {-
113 foreach pipeline:
114 foreach realted program:
115 generate commands
116 -}
117 ppls <- readIORef $ pipelines input
118 let topUnis = uniformSetup input
119 cmds <- V.forM ppls $ \mp -> case mp of
120 Nothing -> return V.empty
121 Just p -> do
122 Just ic <- readIORef $ glInput p
123 case icSlotMapInputToPipeline ic ! slotIdx of
124 Nothing -> do
125 putStrLn $ " ** slot is not used!"
126 return V.empty -- this slot is not used in that pipeline
127 Just pSlotIdx -> do
128 putStrLn "slot is used!"
129 --where
130 let emptyV = V.replicate (V.length $ glPrograms p) []
131 return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx]
132 writeIORef cmdsRef cmds
133 return obj
134
135removeObject :: GLPipelineInput -> Object -> IO ()
136removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate
137
138enableObject :: Object -> Bool -> IO ()
139enableObject obj b = writeIORef (objEnabled obj) b
140
141setObjectOrder :: GLPipelineInput -> Object -> Int -> IO ()
142setObjectOrder p obj i = do
143 writeIORef (objOrder obj) i
144 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
145
146objectUniformSetter :: Object -> Trie InputSetter
147objectUniformSetter = objUniSetter
148
149setScreenSize :: GLPipelineInput -> Word -> Word -> IO ()
150setScreenSize p w h = writeIORef (screenSize p) (w,h)
151
152sortSlotObjects :: GLPipelineInput -> IO ()
153sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do
154 GLSlot objMap sortedV ord <- readIORef slotRef
155 let cmpFun (a,_) (b,_) = a `compare` b
156 doSort objs = do
157 ordObjsM <- V.thaw objs
158 I.sortBy cmpFun ordObjsM
159 ordObjs <- V.freeze ordObjsM
160 writeIORef slotRef (GLSlot objMap ordObjs Ordered)
161 case ord of
162 Ordered -> return ()
163 Generate -> do
164 objs <- V.forM (V.fromList $ IM.elems objMap) $ \obj -> do
165 ord <- readIORef $ objOrder obj
166 return (ord,obj)
167 doSort objs
168 Reorder -> do
169 objs <- V.forM sortedV $ \(_,obj) -> do
170 ord <- readIORef $ objOrder obj
171 return (ord,obj)
172 doSort objs
173
174createObjectCommands :: Trie (IORef GLint) -> Trie GLUniform -> Object -> GLProgram -> [GLObjectCommand]
175createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd]
176 where
177 -- object draw command
178 objDrawCmd = case objIndices obj of
179 Nothing -> GLDrawArrays prim 0 (fromIntegral count)
180 Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
181 where
182 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
183 idxType = arrayTypeToGLType arrType
184 ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
185 where
186 objAttrs = objAttributes obj
187 prim = primitiveToGLType $ objPrimitive obj
188 count = head [c | Stream _ _ _ _ c <- T.elems objAttrs]
189
190 -- object uniform commands
191 -- texture slot setup commands
192 objUniCmds = uniCmds ++ texCmds
193 where
194 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis]
195 uniMap = T.toList $ inputUniforms prg
196 topUni n = T.lookupWithDefault (error "internal error (createObjectCommands)!") n topUnis
197 objUnis = objUniSetup obj
198 texUnis = S.toList $ inputTextureUniforms prg
199 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
200 | n <- texUnis
201 , let u = T.lookupWithDefault (topUni n) n objUnis
202 , let texUnit = T.lookupWithDefault (error "internal error (createObjectCommands - Texture Unit)") n texUnitMap
203 ]
204 uniInputType (GLUniform ty _) = ty
205
206 -- object attribute stream commands
207 objStreamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name objAttrs]
208 where
209 attrMap = inputStreams prg
210 objAttrs = objAttributes obj
211 attrCmd i s = case s of
212 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
213 TWord -> setIntAttrib 1
214 TV2U -> setIntAttrib 2
215 TV3U -> setIntAttrib 3
216 TV4U -> setIntAttrib 4
217 TInt -> setIntAttrib 1
218 TV2I -> setIntAttrib 2
219 TV3I -> setIntAttrib 3
220 TV4I -> setIntAttrib 4
221 TFloat -> setFloatAttrib 1
222 TV2F -> setFloatAttrib 2
223 TV3F -> setFloatAttrib 3
224 TV4F -> setFloatAttrib 4
225 TM22F -> setFloatAttrib 4
226 TM23F -> setFloatAttrib 6
227 TM24F -> setFloatAttrib 8
228 TM32F -> setFloatAttrib 6
229 TM33F -> setFloatAttrib 9
230 TM34F -> setFloatAttrib 12
231 TM42F -> setFloatAttrib 8
232 TM43F -> setFloatAttrib 12
233 TM44F -> setFloatAttrib 16
234 where
235 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
236 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
237 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
238 glType = arrayTypeToGLType arrType
239 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
240
241 -- constant generic attribute
242 constAttr -> GLSetVertexAttrib i constAttr
243
244nullSetter :: ByteString -> String -> a -> IO ()
245nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
246
247uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool
248uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B
249uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B
250uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B
251
252uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32
253uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U
254uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U
255uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U
256
257uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32
258uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I
259uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I
260uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I
261
262uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float
263uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F
264uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F
265uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F
266
267uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F
268uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F
269uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F
270uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F
271uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F
272uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F
273uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F
274uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F
275uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F
276
277uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData
278
279uniformBool n is = case T.lookup n is of
280 Just (SBool fun) -> fun
281 _ -> nullSetter n "Bool"
282
283uniformV2B n is = case T.lookup n is of
284 Just (SV2B fun) -> fun
285 _ -> nullSetter n "V2B"
286
287uniformV3B n is = case T.lookup n is of
288 Just (SV3B fun) -> fun
289 _ -> nullSetter n "V3B"
290
291uniformV4B n is = case T.lookup n is of
292 Just (SV4B fun) -> fun
293 _ -> nullSetter n "V4B"
294
295uniformWord n is = case T.lookup n is of
296 Just (SWord fun) -> fun
297 _ -> nullSetter n "Word"
298
299uniformV2U n is = case T.lookup n is of
300 Just (SV2U fun) -> fun
301 _ -> nullSetter n "V2U"
302
303uniformV3U n is = case T.lookup n is of
304 Just (SV3U fun) -> fun
305 _ -> nullSetter n "V3U"
306
307uniformV4U n is = case T.lookup n is of
308 Just (SV4U fun) -> fun
309 _ -> nullSetter n "V4U"
310
311uniformInt n is = case T.lookup n is of
312 Just (SInt fun) -> fun
313 _ -> nullSetter n "Int"
314
315uniformV2I n is = case T.lookup n is of
316 Just (SV2I fun) -> fun
317 _ -> nullSetter n "V2I"
318
319uniformV3I n is = case T.lookup n is of
320 Just (SV3I fun) -> fun
321 _ -> nullSetter n "V3I"
322
323uniformV4I n is = case T.lookup n is of
324 Just (SV4I fun) -> fun
325 _ -> nullSetter n "V4I"
326
327uniformFloat n is = case T.lookup n is of
328 Just (SFloat fun) -> fun
329 _ -> nullSetter n "Float"
330
331uniformV2F n is = case T.lookup n is of
332 Just (SV2F fun) -> fun
333 _ -> nullSetter n "V2F"
334
335uniformV3F n is = case T.lookup n is of
336 Just (SV3F fun) -> fun
337 _ -> nullSetter n "V3F"
338
339uniformV4F n is = case T.lookup n is of
340 Just (SV4F fun) -> fun
341 _ -> nullSetter n "V4F"
342
343uniformM22F n is = case T.lookup n is of
344 Just (SM22F fun) -> fun
345 _ -> nullSetter n "M22F"
346
347uniformM23F n is = case T.lookup n is of
348 Just (SM23F fun) -> fun
349 _ -> nullSetter n "M23F"
350
351uniformM24F n is = case T.lookup n is of
352 Just (SM24F fun) -> fun
353 _ -> nullSetter n "M24F"
354
355uniformM32F n is = case T.lookup n is of
356 Just (SM32F fun) -> fun
357 _ -> nullSetter n "M32F"
358
359uniformM33F n is = case T.lookup n is of
360 Just (SM33F fun) -> fun
361 _ -> nullSetter n "M33F"
362
363uniformM34F n is = case T.lookup n is of
364 Just (SM34F fun) -> fun
365 _ -> nullSetter n "M34F"
366
367uniformM42F n is = case T.lookup n is of
368 Just (SM42F fun) -> fun
369 _ -> nullSetter n "M42F"
370
371uniformM43F n is = case T.lookup n is of
372 Just (SM43F fun) -> fun
373 _ -> nullSetter n "M43F"
374
375uniformM44F n is = case T.lookup n is of
376 Just (SM44F fun) -> fun
377 _ -> nullSetter n "M44F"
378
379uniformFTexture2D n is = case T.lookup n is of
380 Just (SFTexture2D fun) -> fun
381 _ -> nullSetter n "FTexture2D"
diff --git a/Backend/GL/Mesh.hs b/Backend/GL/Mesh.hs
new file mode 100644
index 0000000..261e6cc
--- /dev/null
+++ b/Backend/GL/Mesh.hs
@@ -0,0 +1,232 @@
1{-# LANGUAGE TupleSections #-}
2module Backend.GL.Mesh (
3 loadMesh,
4 saveMesh,
5 addMesh,
6 compileMesh,
7 updateMesh,
8 Mesh(..),
9 MeshPrimitive(..),
10 MeshAttribute(..)
11) where
12
13import Control.Applicative
14import Control.Monad
15import Data.Binary
16import Data.ByteString.Char8 (ByteString)
17import Foreign.Ptr
18import Data.Int
19import Foreign.Storable
20import Foreign.Marshal.Utils
21import System.IO.Unsafe
22import qualified Data.ByteString.Char8 as SB
23import qualified Data.ByteString.Lazy as LB
24import qualified Data.Trie as T
25import qualified Data.Vector.Storable as V
26import qualified Data.Vector.Storable.Mutable as MV
27
28import Backend.GL
29import Backend.GL.Type as T
30import IR as IR
31
32fileVersion :: Int32
33fileVersion = 1
34
35data MeshAttribute
36 = A_Float (V.Vector Float)
37 | A_V2F (V.Vector V2F)
38 | A_V3F (V.Vector V3F)
39 | A_V4F (V.Vector V4F)
40 | A_M22F (V.Vector M22F)
41 | A_M33F (V.Vector M33F)
42 | A_M44F (V.Vector M44F)
43 | A_Int (V.Vector Int32)
44 | A_Word (V.Vector Word32)
45
46data MeshPrimitive
47 = P_Points
48 | P_TriangleStrip
49 | P_Triangles
50 | P_TriangleStripI (V.Vector Int32)
51 | P_TrianglesI (V.Vector Int32)
52
53data Mesh
54 = Mesh
55 { mAttributes :: T.Trie MeshAttribute
56 , mPrimitive :: MeshPrimitive
57 , mGPUData :: Maybe GPUData
58 }
59
60data GPUData
61 = GPUData
62 { dPrimitive :: Primitive
63 , dStreams :: T.Trie (Stream Buffer)
64 , dIndices :: Maybe (IndexStream Buffer)
65 }
66
67loadMesh :: String -> IO Mesh
68loadMesh n = compileMesh =<< decode <$> LB.readFile n
69
70saveMesh :: String -> Mesh -> IO ()
71saveMesh n m = LB.writeFile n (encode m)
72
73addMesh :: GLPipelineInput -> ByteString -> Mesh -> [ByteString] -> IO Object
74addMesh input slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = do
75 -- select proper attributes
76 let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input
77 filterStream n s
78 | T.member n slotStreams = Just s
79 | otherwise = Nothing
80 addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames
81addMesh _ _ _ _ = fail "addMesh: only compiled mesh with GPUData is supported"
82
83withV w a f = w a (\p -> f $ castPtr p)
84
85meshAttrToArray :: MeshAttribute -> Array
86meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v
87meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v
88meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v
89meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v
90meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v
91meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v
92meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v
93meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v
94meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v
95
96meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
97meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v)
98meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v)
99meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v)
100meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v)
101meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v)
102meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v)
103meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v)
104meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v)
105meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v)
106
107{-
108updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
109
110 | Stream
111 { streamType :: StreamType
112 , streamBuffer :: b
113 , streamArrIdx :: Int
114 , streamStart :: Int
115 , streamLength :: Int
116 }
117
118-- stream of index values (for index buffer)
119data IndexStream b
120 = IndexStream
121 { indexBuffer :: b
122 , indexArrIdx :: Int
123 , indexStart :: Int
124 , indexLength :: Int
125 }
126-}
127updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()
128updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
129 -- check type match
130 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
131 ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA]
132 if not ok then putStrLn "updateMesh: attribute mismatch!"
133 else do
134 forM_ al $ \(n,a) -> do
135 case T.lookup n dS of
136 Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]
137 _ -> return ()
138{-
139 case mp of
140 Nothing -> return ()
141 Just p -> do
142 let ok2 = case (dMP,p) of
143 (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2
144 (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2
145 (a,b) -> a == b
146-}
147
148compileMesh :: Mesh -> IO Mesh
149compileMesh (Mesh attrs mPrim Nothing) = do
150 let mkIndexBuf v = do
151 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]
152 return $! Just $! IndexStream iBuf 0 0 (V.length v)
153 vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs]
154 (indices,prim) <- case mPrim of
155 P_Points -> return (Nothing,PointList)
156 P_TriangleStrip -> return (Nothing,TriangleStrip)
157 P_Triangles -> return (Nothing,TriangleList)
158 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v
159 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v
160 let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs)
161 gpuData = GPUData prim streams indices
162 return $! Mesh attrs mPrim (Just gpuData)
163
164compileMesh mesh = return mesh
165
166sblToV :: Storable a => [SB.ByteString] -> V.Vector a
167sblToV ls = v
168 where
169 offs o (s:xs) = (o,s):offs (o + SB.length s) xs
170 offs _ [] = []
171 cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v)
172 v = unsafePerformIO $ do
173 mv <- MV.new cnt
174 MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) ->
175 SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len
176 V.unsafeFreeze mv
177
178vToSB :: Storable a => V.Vector a -> SB.ByteString
179vToSB v = unsafePerformIO $ do
180 let len = V.length v * sizeOf (V.head v)
181 V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len)
182
183instance Storable a => Binary (V.Vector a) where
184 put v = put $ vToSB v
185 get = do s <- get ; return $ sblToV [s]
186
187instance Binary MeshAttribute where
188 put (A_Float a) = putWord8 0 >> put a
189 put (A_V2F a) = putWord8 1 >> put a
190 put (A_V3F a) = putWord8 2 >> put a
191 put (A_V4F a) = putWord8 3 >> put a
192 put (A_M22F a) = putWord8 4 >> put a
193 put (A_M33F a) = putWord8 5 >> put a
194 put (A_M44F a) = putWord8 6 >> put a
195 put (A_Int a) = putWord8 7 >> put a
196 put (A_Word a) = putWord8 8 >> put a
197 get = do
198 tag_ <- getWord8
199 case tag_ of
200 0 -> A_Float <$> get
201 1 -> A_V2F <$> get
202 2 -> A_V3F <$> get
203 3 -> A_V4F <$> get
204 4 -> A_M22F <$> get
205 5 -> A_M33F <$> get
206 6 -> A_M44F <$> get
207 7 -> A_Int <$> get
208 8 -> A_Word <$> get
209 _ -> fail "no parse"
210
211instance Binary MeshPrimitive where
212 put P_Points = putWord8 0
213 put P_TriangleStrip = putWord8 1
214 put P_Triangles = putWord8 2
215 put (P_TriangleStripI a) = putWord8 3 >> put a
216 put (P_TrianglesI a) = putWord8 4 >> put a
217 get = do
218 tag_ <- getWord8
219 case tag_ of
220 0 -> return P_Points
221 1 -> return P_TriangleStrip
222 2 -> return P_Triangles
223 3 -> P_TriangleStripI <$> get
224 4 -> P_TrianglesI <$> get
225 _ -> fail "no parse"
226
227instance Binary Mesh where
228 put (Mesh a b _) = put (T.toList a) >> put b
229 get = do
230 a <- get
231 b <- get
232 return $! Mesh (T.fromList a) b Nothing
diff --git a/Backend/GL/Type.hs b/Backend/GL/Type.hs
new file mode 100644
index 0000000..80cba6d
--- /dev/null
+++ b/Backend/GL/Type.hs
@@ -0,0 +1,530 @@
1{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2module Backend.GL.Type where
3
4import Data.ByteString.Char8 (ByteString)
5import Data.IORef
6import Data.Int
7import Data.IntMap (IntMap)
8import Data.Set (Set)
9import Data.Trie (Trie)
10import Data.Vector (Vector)
11import Data.Word
12import Foreign.Ptr
13import Foreign.Storable
14
15import Graphics.Rendering.OpenGL.Raw.Core33
16
17import IR
18
19---------------
20-- Input API --
21---------------
22{-
23-- Buffer
24 compileBuffer :: [Array] -> IO Buffer
25 bufferSize :: Buffer -> Int
26 arraySize :: Buffer -> Int -> Int
27 arrayType :: Buffer -> Int -> ArrayType
28
29-- Object
30 addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
31 removeObject :: Renderer -> Object -> IO ()
32 objectUniformSetter :: Object -> Trie InputSetter
33-}
34
35data Buffer -- internal type
36 = Buffer
37 { bufArrays :: Vector ArrayDesc
38 , bufGLObj :: GLuint
39 }
40 deriving (Show,Eq)
41
42data ArrayDesc
43 = ArrayDesc
44 { arrType :: ArrayType
45 , arrLength :: Int -- item count
46 , arrOffset :: Int -- byte position in buffer
47 , arrSize :: Int -- size in bytes
48 }
49 deriving (Show,Eq)
50
51{-
52 handles:
53 uniforms
54 textures
55 buffers
56 objects
57
58 GLPipelineInput can be attached to GLPipeline
59-}
60
61{-
62 pipeline input:
63 - independent from pipeline
64 - per object features: enable/disable visibility, set render ordering
65-}
66
67data SlotSchema
68 = SlotSchema
69 { primitive :: FetchPrimitive
70 , attributes :: Trie StreamType
71 }
72 deriving Show
73
74data PipelineSchema
75 = PipelineSchema
76 { slots :: Trie SlotSchema
77 , uniforms :: Trie InputType
78 }
79 deriving Show
80
81data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a)
82
83instance Show GLUniform where
84 show (GLUniform t _) = "GLUniform " ++ show t
85
86data OrderJob
87 = Generate
88 | Reorder
89 | Ordered
90
91data GLSlot
92 = GLSlot
93 { objectMap :: IntMap Object
94 , sortedObjects :: Vector (Int,Object)
95 , orderJob :: OrderJob
96 }
97
98data GLPipelineInput
99 = GLPipelineInput
100 { schema :: PipelineSchema
101 , slotMap :: Trie SlotName
102 , slotVector :: Vector (IORef GLSlot)
103 , objSeed :: IORef Int
104 , uniformSetter :: Trie InputSetter
105 , uniformSetup :: Trie GLUniform
106 , screenSize :: IORef (Word,Word)
107 , pipelines :: IORef (Vector (Maybe GLPipeline)) -- attached pipelines
108 }
109
110data Object -- internal type
111 = Object
112 { objSlot :: SlotName
113 , objPrimitive :: Primitive
114 , objIndices :: Maybe (IndexStream Buffer)
115 , objAttributes :: Trie (Stream Buffer)
116 , objUniSetter :: Trie InputSetter
117 , objUniSetup :: Trie GLUniform
118 , objOrder :: IORef Int
119 , objEnabled :: IORef Bool
120 , objId :: Int
121 , objCommands :: IORef (Vector (Vector [GLObjectCommand])) -- pipeline id, program name, commands
122 }
123
124--------------
125-- Pipeline --
126--------------
127
128data GLProgram
129 = GLProgram
130 { shaderObjects :: [GLuint]
131 , programObject :: GLuint
132 , inputUniforms :: Trie GLint
133 , inputTextures :: Trie GLint -- all input textures (render texture + uniform texture)
134 , inputTextureUniforms :: Set ByteString
135 , inputStreams :: Trie (GLuint,ByteString)
136 }
137
138data GLTexture
139 = GLTexture
140 { glTextureObject :: GLuint
141 , glTextureTarget :: GLenum
142 }
143
144data InputConnection
145 = InputConnection
146 { icId :: Int -- identifier (vector index) for attached pipeline
147 , icInput :: GLPipelineInput
148 , icSlotMapPipelineToInput :: Vector SlotName -- GLPipeline to GLPipelineInput slot name mapping
149 , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLPipelineInput to GLPipeline slot name mapping
150 }
151
152data GLPipeline
153 = GLPipeline
154 { glPrograms :: Vector GLProgram
155 , glTextures :: Vector GLTexture
156 , glSamplers :: Vector GLSampler
157 , glTargets :: Vector GLRenderTarget
158 , glCommands :: [GLCommand]
159 , glSlotPrograms :: Vector [ProgramName] -- programs depend on a slot
160 , glInput :: IORef (Maybe InputConnection)
161 , glSlotNames :: Vector ByteString
162 , glVAO :: GLuint
163 , glTexUnitMapping :: Trie (IORef GLint) -- maps texture uniforms to texture units
164 }
165
166data GLSampler
167 = GLSampler
168 { samplerObject :: GLuint
169 }
170
171data GLRenderTarget
172 = GLRenderTarget
173 { framebufferObject :: GLuint
174 , framebufferDrawbuffers :: Maybe [GLenum]
175 }
176
177data GLCommand
178 = GLSetRasterContext !RasterContext
179 | GLSetAccumulationContext !AccumulationContext
180 | GLSetRenderTarget !GLuint !(Maybe [GLenum])
181 | GLSetProgram !GLuint
182 | GLSetSamplerUniform !GLint !GLint (IORef GLint) -- sampler index, texture unit, IORef stores the actual texture unit mapping
183 | GLSetTexture !GLenum !GLuint !GLuint
184 | GLSetSampler !GLuint !GLuint
185 | GLRenderSlot !SlotName !ProgramName
186 | GLClearRenderTarget [(ImageSemantic,Value)]
187 | GLGenerateMipMap !GLenum !GLenum
188 | GLSaveImage FrameBufferComponent ImageRef -- from framebuffer component to texture (image)
189 | GLLoadImage ImageRef FrameBufferComponent -- from texture (image) to framebuffer component
190 deriving Show
191
192instance Show (IORef GLint) where
193 show _ = "(IORef GLint)"
194
195data GLObjectCommand
196 = GLSetUniform !GLint !GLUniform
197 | GLBindTexture !GLenum !(IORef GLint) !GLUniform -- binds the texture from the gluniform to the specified texture unit and target
198 | GLSetVertexAttribArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer
199 | GLSetVertexAttribIArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer
200 | GLSetVertexAttrib !GLuint !(Stream Buffer) -- index value
201 | GLDrawArrays !GLenum !GLint !GLsizei -- mode first count
202 | GLDrawElements !GLenum !GLsizei !GLenum !GLuint !(Ptr ()) -- mode count type buffer indicesPtr
203 deriving Show
204
205type SetterFun a = a -> IO ()
206
207-- user will provide scalar input data via this type
208data InputSetter
209 = SBool (SetterFun Bool)
210 | SV2B (SetterFun V2B)
211 | SV3B (SetterFun V3B)
212 | SV4B (SetterFun V4B)
213 | SWord (SetterFun Word32)
214 | SV2U (SetterFun V2U)
215 | SV3U (SetterFun V3U)
216 | SV4U (SetterFun V4U)
217 | SInt (SetterFun Int32)
218 | SV2I (SetterFun V2I)
219 | SV3I (SetterFun V3I)
220 | SV4I (SetterFun V4I)
221 | SFloat (SetterFun Float)
222 | SV2F (SetterFun V2F)
223 | SV3F (SetterFun V3F)
224 | SV4F (SetterFun V4F)
225 | SM22F (SetterFun M22F)
226 | SM23F (SetterFun M23F)
227 | SM24F (SetterFun M24F)
228 | SM32F (SetterFun M32F)
229 | SM33F (SetterFun M33F)
230 | SM34F (SetterFun M34F)
231 | SM42F (SetterFun M42F)
232 | SM43F (SetterFun M43F)
233 | SM44F (SetterFun M44F)
234 -- shadow textures
235 | SSTexture1D
236 | SSTexture2D
237 | SSTextureCube
238 | SSTexture1DArray
239 | SSTexture2DArray
240 | SSTexture2DRect
241 -- float textures
242 | SFTexture1D
243 | SFTexture2D (SetterFun TextureData)
244 | SFTexture3D
245 | SFTextureCube
246 | SFTexture1DArray
247 | SFTexture2DArray
248 | SFTexture2DMS
249 | SFTexture2DMSArray
250 | SFTextureBuffer
251 | SFTexture2DRect
252 -- int textures
253 | SITexture1D
254 | SITexture2D
255 | SITexture3D
256 | SITextureCube
257 | SITexture1DArray
258 | SITexture2DArray
259 | SITexture2DMS
260 | SITexture2DMSArray
261 | SITextureBuffer
262 | SITexture2DRect
263 -- uint textures
264 | SUTexture1D
265 | SUTexture2D
266 | SUTexture3D
267 | SUTextureCube
268 | SUTexture1DArray
269 | SUTexture2DArray
270 | SUTexture2DMS
271 | SUTexture2DMSArray
272 | SUTextureBuffer
273 | SUTexture2DRect
274
275-- buffer handling
276{-
277 user can fills a buffer (continuous memory region)
278 each buffer have a data descriptor, what describes the
279 buffer content. e.g. a buffer can contain more arrays of stream types
280-}
281
282-- user will provide stream data using this setup function
283type BufferSetter = (Ptr () -> IO ()) -> IO ()
284
285-- specifies array component type (stream type in storage side)
286-- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also
287data ArrayType
288 = ArrWord8
289 | ArrWord16
290 | ArrWord32
291 | ArrInt8
292 | ArrInt16
293 | ArrInt32
294 | ArrFloat
295 | ArrHalf -- Hint: half float is not supported in haskell
296 deriving (Show,Eq,Ord)
297
298sizeOfArrayType :: ArrayType -> Int
299sizeOfArrayType ArrWord8 = 1
300sizeOfArrayType ArrWord16 = 2
301sizeOfArrayType ArrWord32 = 4
302sizeOfArrayType ArrInt8 = 1
303sizeOfArrayType ArrInt16 = 2
304sizeOfArrayType ArrInt32 = 4
305sizeOfArrayType ArrFloat = 4
306sizeOfArrayType ArrHalf = 2
307
308-- describes an array in a buffer
309data Array -- array type, element count (NOT byte size!), setter
310 = Array ArrayType Int BufferSetter
311
312-- dev hint: this should be InputType
313-- we restrict StreamType using type class
314-- subset of InputType, describes a stream type (in GPU side)
315data StreamType
316 = TWord
317 | TV2U
318 | TV3U
319 | TV4U
320 | TInt
321 | TV2I
322 | TV3I
323 | TV4I
324 | TFloat
325 | TV2F
326 | TV3F
327 | TV4F
328 | TM22F
329 | TM23F
330 | TM24F
331 | TM32F
332 | TM33F
333 | TM34F
334 | TM42F
335 | TM43F
336 | TM44F
337 deriving (Show,Eq,Ord)
338
339toStreamType :: InputType -> Maybe StreamType
340toStreamType Word = Just TWord
341toStreamType V2U = Just TV2U
342toStreamType V3U = Just TV3U
343toStreamType V4U = Just TV4U
344toStreamType Int = Just TInt
345toStreamType V2I = Just TV2I
346toStreamType V3I = Just TV3I
347toStreamType V4I = Just TV4I
348toStreamType Float = Just TFloat
349toStreamType V2F = Just TV2F
350toStreamType V3F = Just TV3F
351toStreamType V4F = Just TV4F
352toStreamType M22F = Just TM22F
353toStreamType M23F = Just TM23F
354toStreamType M24F = Just TM24F
355toStreamType M32F = Just TM32F
356toStreamType M33F = Just TM33F
357toStreamType M34F = Just TM34F
358toStreamType M42F = Just TM42F
359toStreamType M43F = Just TM43F
360toStreamType M44F = Just TM44F
361toStreamType _ = Nothing
362
363fromStreamType :: StreamType -> InputType
364fromStreamType TWord = Word
365fromStreamType TV2U = V2U
366fromStreamType TV3U = V3U
367fromStreamType TV4U = V4U
368fromStreamType TInt = Int
369fromStreamType TV2I = V2I
370fromStreamType TV3I = V3I
371fromStreamType TV4I = V4I
372fromStreamType TFloat = Float
373fromStreamType TV2F = V2F
374fromStreamType TV3F = V3F
375fromStreamType TV4F = V4F
376fromStreamType TM22F = M22F
377fromStreamType TM23F = M23F
378fromStreamType TM24F = M24F
379fromStreamType TM32F = M32F
380fromStreamType TM33F = M33F
381fromStreamType TM34F = M34F
382fromStreamType TM42F = M42F
383fromStreamType TM43F = M43F
384fromStreamType TM44F = M44F
385
386-- user can specify streams using Stream type
387-- a stream can be constant (ConstXXX) or can came from a buffer
388data Stream b
389 = ConstWord Word32
390 | ConstV2U V2U
391 | ConstV3U V3U
392 | ConstV4U V4U
393 | ConstInt Int32
394 | ConstV2I V2I
395 | ConstV3I V3I
396 | ConstV4I V4I
397 | ConstFloat Float
398 | ConstV2F V2F
399 | ConstV3F V3F
400 | ConstV4F V4F
401 | ConstM22F M22F
402 | ConstM23F M23F
403 | ConstM24F M24F
404 | ConstM32F M32F
405 | ConstM33F M33F
406 | ConstM34F M34F
407 | ConstM42F M42F
408 | ConstM43F M43F
409 | ConstM44F M44F
410 | Stream
411 { streamType :: StreamType
412 , streamBuffer :: b
413 , streamArrIdx :: Int
414 , streamStart :: Int
415 , streamLength :: Int
416 }
417 deriving Show
418
419streamToStreamType :: Stream a -> StreamType
420streamToStreamType s = case s of
421 ConstWord _ -> TWord
422 ConstV2U _ -> TV2U
423 ConstV3U _ -> TV3U
424 ConstV4U _ -> TV4U
425 ConstInt _ -> TInt
426 ConstV2I _ -> TV2I
427 ConstV3I _ -> TV3I
428 ConstV4I _ -> TV4I
429 ConstFloat _ -> TFloat
430 ConstV2F _ -> TV2F
431 ConstV3F _ -> TV3F
432 ConstV4F _ -> TV4F
433 ConstM22F _ -> TM22F
434 ConstM23F _ -> TM23F
435 ConstM24F _ -> TM24F
436 ConstM32F _ -> TM32F
437 ConstM33F _ -> TM33F
438 ConstM34F _ -> TM34F
439 ConstM42F _ -> TM42F
440 ConstM43F _ -> TM43F
441 ConstM44F _ -> TM44F
442 Stream t _ _ _ _ -> t
443
444-- stream of index values (for index buffer)
445data IndexStream b
446 = IndexStream
447 { indexBuffer :: b
448 , indexArrIdx :: Int
449 , indexStart :: Int
450 , indexLength :: Int
451 }
452
453newtype TextureData
454 = TextureData
455 { textureObject :: GLuint
456 }
457 deriving Storable
458
459data Primitive
460 = TriangleStrip
461 | TriangleList
462 | TriangleFan
463 | LineStrip
464 | LineList
465 | PointList
466 | TriangleStripAdjacency
467 | TriangleListAdjacency
468 | LineStripAdjacency
469 | LineListAdjacency
470 deriving (Eq,Ord,Bounded,Enum,Show)
471
472type StreamSetter = Stream Buffer -> IO ()
473
474-- storable instances
475instance Storable a => Storable (V2 a) where
476 sizeOf _ = 2 * sizeOf (undefined :: a)
477 alignment _ = sizeOf (undefined :: a)
478
479 peek q = do
480 let p = castPtr q :: Ptr a
481 k = sizeOf (undefined :: a)
482 x <- peek p
483 y <- peekByteOff p k
484 return $! (V2 x y)
485
486 poke q (V2 x y) = do
487 let p = castPtr q :: Ptr a
488 k = sizeOf (undefined :: a)
489 poke p x
490 pokeByteOff p k y
491
492instance Storable a => Storable (V3 a) where
493 sizeOf _ = 3 * sizeOf (undefined :: a)
494 alignment _ = sizeOf (undefined :: a)
495
496 peek q = do
497 let p = castPtr q :: Ptr a
498 k = sizeOf (undefined :: a)
499 x <- peek p
500 y <- peekByteOff p k
501 z <- peekByteOff p (k*2)
502 return $! (V3 x y z)
503
504 poke q (V3 x y z) = do
505 let p = castPtr q :: Ptr a
506 k = sizeOf (undefined :: a)
507 poke p x
508 pokeByteOff p k y
509 pokeByteOff p (k*2) z
510
511instance Storable a => Storable (V4 a) where
512 sizeOf _ = 4 * sizeOf (undefined :: a)
513 alignment _ = sizeOf (undefined :: a)
514
515 peek q = do
516 let p = castPtr q :: Ptr a
517 k = sizeOf (undefined :: a)
518 x <- peek p
519 y <- peekByteOff p k
520 z <- peekByteOff p (k*2)
521 w <- peekByteOff p (k*3)
522 return $! (V4 x y z w)
523
524 poke q (V4 x y z w) = do
525 let p = castPtr q :: Ptr a
526 k = sizeOf (undefined :: a)
527 poke p x
528 pokeByteOff p k y
529 pokeByteOff p (k*2) z
530 pokeByteOff p (k*3) w
diff --git a/Backend/GL/Util.hs b/Backend/GL/Util.hs
new file mode 100644
index 0000000..7a36290
--- /dev/null
+++ b/Backend/GL/Util.hs
@@ -0,0 +1,717 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Backend.GL.Util (
3 queryUniforms,
4 queryStreams,
5 mkUniformSetter,
6 setUniform,
7 setVertexAttrib,
8 compileShader,
9 printProgramLog,
10 glGetShaderiv1,
11 glGetProgramiv1,
12 Buffer(..),
13 ArrayDesc(..),
14 StreamSetter,
15 streamToInputType,
16 arrayTypeToGLType,
17 comparisonFunctionToGLType,
18 logicOperationToGLType,
19 blendEquationToGLType,
20 blendingFactorToGLType,
21 checkGL,
22 textureDataTypeToGLType,
23 textureDataTypeToGLArityType,
24 glGetIntegerv1,
25 setSampler,
26 checkFBO,
27 compileTexture,
28 primitiveToFetchPrimitive,
29 primitiveToGLType,
30 inputTypeToTextureTarget,
31 toTrie
32) where
33
34import Control.Applicative
35import Control.Exception
36import Control.Monad
37import Data.ByteString.Char8 (ByteString,pack,unpack)
38import Data.IORef
39import Data.List as L
40import Data.Trie as T
41import Foreign
42import qualified Data.ByteString.Char8 as SB
43import qualified Data.Vector as V
44import Data.Vector.Unboxed.Mutable (IOVector)
45import qualified Data.Vector.Unboxed.Mutable as MV
46import Data.Map (Map)
47import qualified Data.Map as Map
48
49import Graphics.Rendering.OpenGL.Raw.Core33
50import IR
51import Backend.GL.Type
52
53toTrie :: Map String a -> Trie a
54toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m]
55
56setSampler :: GLint -> Int32 -> IO ()
57setSampler i v = glUniform1i i $ fromIntegral v
58
59z2 = V2 0 0 :: V2F
60z3 = V3 0 0 0 :: V3F
61z4 = V4 0 0 0 0 :: V4F
62
63-- uniform functions
64queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)
65queryUniforms po = do
66 ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation gl_ACTIVE_UNIFORMS gl_ACTIVE_UNIFORM_MAX_LENGTH
67 let uNames = [n | (n,_,_,_) <- ul]
68 uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]
69 uLocation = [i | (_,i,_,_) <- ul]
70 return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes)
71
72b2w :: Bool -> GLuint
73b2w True = 1
74b2w False = 0
75
76mkUniformSetter :: InputType -> IO (GLUniform, InputSetter)
77mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)}
78mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)}
79mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)}
80mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)}
81mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)}
82mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)}
83mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)}
84mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)}
85mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)}
86mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)}
87mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)}
88mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)}
89mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)}
90mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)}
91mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)}
92mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)}
93mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)}
94mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)}
95mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)}
96mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)}
97mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)}
98mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)}
99mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)}
100mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)}
101mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)}
102mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)}
103
104-- sets value based uniforms only (does not handle textures)
105setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()
106setUniform i ty ref = do
107 v <- readIORef ref
108 let false = fromIntegral gl_FALSE
109 with v $ \p -> case ty of
110 Bool -> glUniform1uiv i 1 (castPtr p)
111 V2B -> glUniform2uiv i 1 (castPtr p)
112 V3B -> glUniform3uiv i 1 (castPtr p)
113 V4B -> glUniform4uiv i 1 (castPtr p)
114 Word -> glUniform1uiv i 1 (castPtr p)
115 V2U -> glUniform2uiv i 1 (castPtr p)
116 V3U -> glUniform3uiv i 1 (castPtr p)
117 V4U -> glUniform4uiv i 1 (castPtr p)
118 Int -> glUniform1iv i 1 (castPtr p)
119 V2I -> glUniform2iv i 1 (castPtr p)
120 V3I -> glUniform3iv i 1 (castPtr p)
121 V4I -> glUniform4iv i 1 (castPtr p)
122 Float -> glUniform1fv i 1 (castPtr p)
123 V2F -> glUniform2fv i 1 (castPtr p)
124 V3F -> glUniform3fv i 1 (castPtr p)
125 V4F -> glUniform4fv i 1 (castPtr p)
126 M22F -> glUniformMatrix2fv i 1 false (castPtr p)
127 M23F -> glUniformMatrix2x3fv i 1 false (castPtr p)
128 M24F -> glUniformMatrix2x4fv i 1 false (castPtr p)
129 M32F -> glUniformMatrix3x2fv i 1 false (castPtr p)
130 M33F -> glUniformMatrix3fv i 1 false (castPtr p)
131 M34F -> glUniformMatrix3x4fv i 1 false (castPtr p)
132 M42F -> glUniformMatrix4x2fv i 1 false (castPtr p)
133 M43F -> glUniformMatrix4x3fv i 1 false (castPtr p)
134 M44F -> glUniformMatrix4fv i 1 false (castPtr p)
135 _ -> fail "internal error (setUniform)!"
136
137-- attribute functions
138queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)
139queryStreams po = do
140 al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation gl_ACTIVE_ATTRIBUTES gl_ACTIVE_ATTRIBUTE_MAX_LENGTH
141 let aNames = [n | (n,_,_,_) <- al]
142 aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]
143 aLocation = [fromIntegral i | (_,i,_,_) <- al]
144 return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes)
145
146arrayTypeToGLType :: ArrayType -> GLenum
147arrayTypeToGLType a = case a of
148 ArrWord8 -> gl_UNSIGNED_BYTE
149 ArrWord16 -> gl_UNSIGNED_SHORT
150 ArrWord32 -> gl_UNSIGNED_INT
151 ArrInt8 -> gl_BYTE
152 ArrInt16 -> gl_SHORT
153 ArrInt32 -> gl_INT
154 ArrFloat -> gl_FLOAT
155 ArrHalf -> gl_HALF_FLOAT
156
157setVertexAttrib :: GLuint -> Stream Buffer -> IO ()
158setVertexAttrib i val = case val of
159 ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p
160 ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p
161 ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p
162 ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p
163 ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p
164 ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p
165 ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p
166 ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p
167 ConstFloat v -> setAFloat i v
168 ConstV2F v -> setAV2F i v
169 ConstV3F v -> setAV3F i v
170 ConstV4F v -> setAV4F i v
171 ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y
172 ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z
173 ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w
174 ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y
175 ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z
176 ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w
177 ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y
178 ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z
179 ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w
180 _ -> fail "internal error (setVertexAttrib)!"
181
182setAFloat :: GLuint -> Float -> IO ()
183setAV2F :: GLuint -> V2F -> IO ()
184setAV3F :: GLuint -> V3F -> IO ()
185setAV4F :: GLuint -> V4F -> IO ()
186setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p
187setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p
188setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p
189setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p
190
191-- result list: [(name string,location,gl type,component count)]
192getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())
193 -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)]
194getNameTypeSize o f g enum enumLen = do
195 nameLen <- glGetProgramiv1 enumLen o
196 allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do
197 n <- glGetProgramiv1 enum o
198 forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>
199 (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep
200
201fromGLType :: (GLenum,GLint) -> InputType
202fromGLType (t,1)
203 | t == gl_BOOL = Bool
204 | t == gl_BOOL_VEC2 = V2B
205 | t == gl_BOOL_VEC3 = V3B
206 | t == gl_BOOL_VEC4 = V4B
207 | t == gl_UNSIGNED_INT = Word
208 | t == gl_UNSIGNED_INT_VEC2 = V2U
209 | t == gl_UNSIGNED_INT_VEC3 = V3U
210 | t == gl_UNSIGNED_INT_VEC4 = V4U
211 | t == gl_INT = Int
212 | t == gl_INT_VEC2 = V2I
213 | t == gl_INT_VEC3 = V3I
214 | t == gl_INT_VEC4 = V4I
215 | t == gl_FLOAT = Float
216 | t == gl_FLOAT_VEC2 = V2F
217 | t == gl_FLOAT_VEC3 = V3F
218 | t == gl_FLOAT_VEC4 = V4F
219 | t == gl_FLOAT_MAT2 = M22F
220 | t == gl_FLOAT_MAT2x3 = M23F
221 | t == gl_FLOAT_MAT2x4 = M24F
222 | t == gl_FLOAT_MAT3x2 = M32F
223 | t == gl_FLOAT_MAT3 = M33F
224 | t == gl_FLOAT_MAT3x4 = M34F
225 | t == gl_FLOAT_MAT4x2 = M42F
226 | t == gl_FLOAT_MAT4x3 = M43F
227 | t == gl_FLOAT_MAT4 = M44F
228 | t == gl_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray
229 | t == gl_SAMPLER_1D_SHADOW = STexture1D
230 | t == gl_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray
231 | t == gl_SAMPLER_2D_RECT_SHADOW = STexture2DRect
232 | t == gl_SAMPLER_2D_SHADOW = STexture2D
233 | t == gl_SAMPLER_CUBE_SHADOW = STextureCube
234 | t == gl_INT_SAMPLER_1D = ITexture1D
235 | t == gl_INT_SAMPLER_1D_ARRAY = ITexture1DArray
236 | t == gl_INT_SAMPLER_2D = ITexture2D
237 | t == gl_INT_SAMPLER_2D_ARRAY = ITexture2DArray
238 | t == gl_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS
239 | t == gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray
240 | t == gl_INT_SAMPLER_2D_RECT = ITexture2DRect
241 | t == gl_INT_SAMPLER_3D = ITexture3D
242 | t == gl_INT_SAMPLER_BUFFER = ITextureBuffer
243 | t == gl_INT_SAMPLER_CUBE = ITextureCube
244 | t == gl_SAMPLER_1D = FTexture1D
245 | t == gl_SAMPLER_1D_ARRAY = FTexture1DArray
246 | t == gl_SAMPLER_2D = FTexture2D
247 | t == gl_SAMPLER_2D_ARRAY = FTexture2DArray
248 | t == gl_SAMPLER_2D_MULTISAMPLE = FTexture2DMS
249 | t == gl_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray
250 | t == gl_SAMPLER_2D_RECT = FTexture2DRect
251 | t == gl_SAMPLER_3D = FTexture3D
252 | t == gl_SAMPLER_BUFFER = FTextureBuffer
253 | t == gl_SAMPLER_CUBE = FTextureCube
254 | t == gl_UNSIGNED_INT_SAMPLER_1D = UTexture1D
255 | t == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray
256 | t == gl_UNSIGNED_INT_SAMPLER_2D = UTexture2D
257 | t == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray
258 | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS
259 | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray
260 | t == gl_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect
261 | t == gl_UNSIGNED_INT_SAMPLER_3D = UTexture3D
262 | t == gl_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer
263 | t == gl_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube
264 | otherwise = error "Failed fromGLType"
265fromGLUniformType _ = error "Failed fromGLType"
266
267printShaderLog :: GLuint -> IO ()
268printShaderLog o = do
269 i <- glGetShaderiv1 gl_INFO_LOG_LENGTH o
270 when (i > 0) $
271 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
272 glGetShaderInfoLog o (fromIntegral i) sizePtr ps
273 size <- peek sizePtr
274 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
275 SB.putStrLn log
276
277glGetShaderiv1 :: GLenum -> GLuint -> IO GLint
278glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi
279
280glGetProgramiv1 :: GLenum -> GLuint -> IO GLint
281glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi
282
283printProgramLog :: GLuint -> IO ()
284printProgramLog o = do
285 i <- glGetProgramiv1 gl_INFO_LOG_LENGTH o
286 when (i > 0) $
287 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
288 glGetProgramInfoLog o (fromIntegral i) sizePtr ps
289 size <- peek sizePtr
290 log <- SB.packCStringLen (castPtr ps, fromIntegral size)
291 SB.putStrLn log
292
293compileShader :: GLuint -> [ByteString] -> IO ()
294compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do
295 glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
296 glCompileShader o
297 printShaderLog o
298 status <- glGetShaderiv1 gl_COMPILE_STATUS o
299 when (status /= fromIntegral gl_TRUE) $ fail "compileShader failed!"
300
301checkGL :: IO ByteString
302checkGL = do
303 let f e | e == gl_INVALID_ENUM = "INVALID_ENUM"
304 | e == gl_INVALID_VALUE = "INVALID_VALUE"
305 | e == gl_INVALID_OPERATION = "INVALID_OPERATION"
306 | e == gl_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"
307 | e == gl_OUT_OF_MEMORY = "OUT_OF_MEMORY"
308 | e == gl_NO_ERROR = "OK"
309 | otherwise = "Unknown error"
310 e <- glGetError
311 return $ f e
312
313streamToInputType :: Stream Buffer -> InputType
314streamToInputType s = case s of
315 ConstWord _ -> Word
316 ConstV2U _ -> V2U
317 ConstV3U _ -> V3U
318 ConstV4U _ -> V4U
319 ConstInt _ -> Int
320 ConstV2I _ -> V2I
321 ConstV3I _ -> V3I
322 ConstV4I _ -> V4I
323 ConstFloat _ -> Float
324 ConstV2F _ -> V2F
325 ConstV3F _ -> V3F
326 ConstV4F _ -> V4F
327 ConstM22F _ -> M22F
328 ConstM23F _ -> M23F
329 ConstM24F _ -> M24F
330 ConstM32F _ -> M32F
331 ConstM33F _ -> M33F
332 ConstM34F _ -> M34F
333 ConstM42F _ -> M42F
334 ConstM43F _ -> M43F
335 ConstM44F _ -> M44F
336 Stream t (Buffer a _) i _ _
337 | 0 <= i && i < V.length a &&
338 if elem t integralTypes then elem at integralArrTypes else True
339 -> fromStreamType t
340 | otherwise -> throw $ userError "streamToInputType failed"
341 where
342 at = arrType $! (a V.! i)
343 integralTypes = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I]
344 integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]
345
346comparisonFunctionToGLType :: ComparisonFunction -> GLenum
347comparisonFunctionToGLType a = case a of
348 Always -> gl_ALWAYS
349 Equal -> gl_EQUAL
350 Gequal -> gl_GEQUAL
351 Greater -> gl_GREATER
352 Lequal -> gl_LEQUAL
353 Less -> gl_LESS
354 Never -> gl_NEVER
355 Notequal -> gl_NOTEQUAL
356
357logicOperationToGLType :: LogicOperation -> GLenum
358logicOperationToGLType a = case a of
359 And -> gl_AND
360 AndInverted -> gl_AND_INVERTED
361 AndReverse -> gl_AND_REVERSE
362 Clear -> gl_CLEAR
363 Copy -> gl_COPY
364 CopyInverted -> gl_COPY_INVERTED
365 Equiv -> gl_EQUIV
366 Invert -> gl_INVERT
367 Nand -> gl_NAND
368 Noop -> gl_NOOP
369 Nor -> gl_NOR
370 Or -> gl_OR
371 OrInverted -> gl_OR_INVERTED
372 OrReverse -> gl_OR_REVERSE
373 Set -> gl_SET
374 Xor -> gl_XOR
375
376blendEquationToGLType :: BlendEquation -> GLenum
377blendEquationToGLType a = case a of
378 FuncAdd -> gl_FUNC_ADD
379 FuncReverseSubtract -> gl_FUNC_REVERSE_SUBTRACT
380 FuncSubtract -> gl_FUNC_SUBTRACT
381 Max -> gl_MAX
382 Min -> gl_MIN
383
384blendingFactorToGLType :: BlendingFactor -> GLenum
385blendingFactorToGLType a = case a of
386 ConstantAlpha -> gl_CONSTANT_ALPHA
387 ConstantColor -> gl_CONSTANT_COLOR
388 DstAlpha -> gl_DST_ALPHA
389 DstColor -> gl_DST_COLOR
390 One -> gl_ONE
391 OneMinusConstantAlpha -> gl_ONE_MINUS_CONSTANT_ALPHA
392 OneMinusConstantColor -> gl_ONE_MINUS_CONSTANT_COLOR
393 OneMinusDstAlpha -> gl_ONE_MINUS_DST_ALPHA
394 OneMinusDstColor -> gl_ONE_MINUS_DST_COLOR
395 OneMinusSrcAlpha -> gl_ONE_MINUS_SRC_ALPHA
396 OneMinusSrcColor -> gl_ONE_MINUS_SRC_COLOR
397 SrcAlpha -> gl_SRC_ALPHA
398 SrcAlphaSaturate -> gl_SRC_ALPHA_SATURATE
399 SrcColor -> gl_SRC_COLOR
400 Zero -> gl_ZERO
401
402textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum
403textureDataTypeToGLType Color a = case a of
404 FloatT Red -> gl_R32F
405 IntT Red -> gl_R32I
406 WordT Red -> gl_R32UI
407 FloatT RG -> gl_RG32F
408 IntT RG -> gl_RG32I
409 WordT RG -> gl_RG32UI
410 FloatT RGBA -> gl_RGBA32F
411 IntT RGBA -> gl_RGBA32I
412 WordT RGBA -> gl_RGBA32UI
413 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
414textureDataTypeToGLType Depth a = case a of
415 FloatT Red -> gl_DEPTH_COMPONENT32F
416 WordT Red -> gl_DEPTH_COMPONENT32
417 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
418textureDataTypeToGLType Stencil a = case a of
419 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
420
421textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum
422textureDataTypeToGLArityType Color a = case a of
423 FloatT Red -> gl_RED
424 IntT Red -> gl_RED
425 WordT Red -> gl_RED
426 FloatT RG -> gl_RG
427 IntT RG -> gl_RG
428 WordT RG -> gl_RG
429 FloatT RGBA -> gl_RGBA
430 IntT RGBA -> gl_RGBA
431 WordT RGBA -> gl_RGBA
432 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
433textureDataTypeToGLArityType Depth a = case a of
434 FloatT Red -> gl_DEPTH_COMPONENT
435 WordT Red -> gl_DEPTH_COMPONENT
436 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
437textureDataTypeToGLArityType Stencil a = case a of
438 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
439{-
440Texture and renderbuffer color formats (R):
441 R11F_G11F_B10F
442 R16
443 R16F
444 R16I
445 R16UI
446 R32F
447 R32I
448 R32UI
449 R8
450 R8I
451 R8UI
452 RG16
453 RG16F
454 RG16I
455 RG16UI
456 RG32F
457 RG32I
458 RG32UI
459 RG8
460 RG8I
461 RG8UI
462 RGB10_A2
463 RGB10_A2UI
464 RGBA16
465 RGBA16F
466 RGBA16I
467 RGBA16UI
468 RGBA32F
469 RGBA32I
470 RGBA32UI
471 RGBA8
472 RGBA8I
473 RGBA8UI
474 SRGB8_ALPHA8
475-}
476
477glGetIntegerv1 :: GLenum -> IO GLint
478glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi
479
480checkFBO :: IO ByteString
481checkFBO = do
482 let f e | e == gl_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"
483 | e == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"
484 | e == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"
485 | e == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"
486 | e == gl_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"
487 | e == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"
488 | e == gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"
489 | e == gl_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"
490 | otherwise = "Unknown error"
491 e <- glCheckFramebufferStatus gl_DRAW_FRAMEBUFFER
492 return $ f e
493
494filterToGLType :: Filter -> GLenum
495filterToGLType a = case a of
496 Nearest -> gl_NEAREST
497 Linear -> gl_LINEAR
498 NearestMipmapNearest -> gl_NEAREST_MIPMAP_NEAREST
499 NearestMipmapLinear -> gl_NEAREST_MIPMAP_LINEAR
500 LinearMipmapNearest -> gl_LINEAR_MIPMAP_NEAREST
501 LinearMipmapLinear -> gl_LINEAR_MIPMAP_LINEAR
502
503edgeModeToGLType :: EdgeMode -> GLenum
504edgeModeToGLType a = case a of
505 Repeat -> gl_REPEAT
506 MirroredRepeat -> gl_MIRRORED_REPEAT
507 ClampToEdge -> gl_CLAMP_TO_EDGE
508 ClampToBorder -> gl_CLAMP_TO_BORDER
509
510setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()
511setTextureSamplerParameters t s = do
512 glTexParameteri t gl_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
513 case samplerWrapT s of
514 Nothing -> return ()
515 Just a -> glTexParameteri t gl_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
516 case samplerWrapR s of
517 Nothing -> return ()
518 Just a -> glTexParameteri t gl_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
519 glTexParameteri t gl_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
520 glTexParameteri t gl_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
521
522 let setBColorV4F a = with a $ \p -> glTexParameterfv t gl_TEXTURE_BORDER_COLOR $ castPtr p
523 setBColorV4I a = with a $ \p -> glTexParameterIiv t gl_TEXTURE_BORDER_COLOR $ castPtr p
524 setBColorV4U a = with a $ \p -> glTexParameterIuiv t gl_TEXTURE_BORDER_COLOR $ castPtr p
525 case samplerBorderColor s of
526 -- float, word, int, red, rg, rgb, rgba
527 VFloat a -> setBColorV4F $ V4 a 0 0 0
528 VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0
529 VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0
530 VV4F a -> setBColorV4F a
531
532 VInt a -> setBColorV4I $ V4 a 0 0 0
533 VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0
534 VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0
535 VV4I a -> setBColorV4I a
536
537 VWord a -> setBColorV4U $ V4 a 0 0 0
538 VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0
539 VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0
540 VV4U a -> setBColorV4U a
541 _ -> fail "internal error (setTextureSamplerParameters)!"
542
543 case samplerMinLod s of
544 Nothing -> return ()
545 Just a -> glTexParameterf t gl_TEXTURE_MIN_LOD $ realToFrac a
546 case samplerMaxLod s of
547 Nothing -> return ()
548 Just a -> glTexParameterf t gl_TEXTURE_MAX_LOD $ realToFrac a
549 glTexParameterf t gl_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
550 case samplerCompareFunc s of
551 Nothing -> glTexParameteri t gl_TEXTURE_COMPARE_MODE $ fromIntegral gl_NONE
552 Just a -> do
553 glTexParameteri t gl_TEXTURE_COMPARE_MODE $ fromIntegral gl_COMPARE_REF_TO_TEXTURE
554 glTexParameteri t gl_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
555
556compileTexture :: TextureDescriptor -> IO GLTexture
557compileTexture txDescriptor = do
558 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
559 let TextureDescriptor
560 { textureType = txType
561 , textureSize = txSize
562 , textureSemantic = txSemantic
563 , textureSampler = txSampler
564 , textureBaseLevel = txBaseLevel
565 , textureMaxLevel = txMaxLevel
566 } = txDescriptor
567
568 txSetup txTarget dTy = do
569 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy
570 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy
571 glBindTexture txTarget to
572 glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel
573 glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel
574 setTextureSamplerParameters txTarget txSampler
575 return (internalFormat,dataFormat)
576
577 mipSize 0 x = [x]
578 mipSize n x = x : mipSize (n-1) (x `div` 2)
579 mipS = mipSize (txMaxLevel - txBaseLevel)
580 levels = [txBaseLevel..txMaxLevel]
581 target <- case txType of
582 Texture1D dTy layerCnt -> do
583 let VWord txW = txSize
584 txTarget = if layerCnt > 1 then gl_TEXTURE_1D_ARRAY else gl_TEXTURE_1D
585 (internalFormat,dataFormat) <- txSetup txTarget dTy
586 forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of
587 True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
588 False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
589 return txTarget
590 Texture2D dTy layerCnt -> do
591 let VV2U (V2 txW txH) = txSize
592 txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D
593 (internalFormat,dataFormat) <- txSetup txTarget dTy
594 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of
595 True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
596 False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
597 return txTarget
598 Texture3D dTy -> do
599 let VV3U (V3 txW txH txD) = txSize
600 txTarget = gl_TEXTURE_3D
601 (internalFormat,dataFormat) <- txSetup txTarget dTy
602 forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) ->
603 glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
604 return txTarget
605 TextureCube dTy -> do
606 let VV2U (V2 txW txH) = txSize
607 txTarget = gl_TEXTURE_CUBE_MAP
608 targets =
609 [ gl_TEXTURE_CUBE_MAP_POSITIVE_X
610 , gl_TEXTURE_CUBE_MAP_NEGATIVE_X
611 , gl_TEXTURE_CUBE_MAP_POSITIVE_Y
612 , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y
613 , gl_TEXTURE_CUBE_MAP_POSITIVE_Z
614 , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z
615 ]
616 (internalFormat,dataFormat) <- txSetup txTarget dTy
617 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
618 forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
619 return txTarget
620 TextureRect dTy -> do
621 let VV2U (V2 txW txH) = txSize
622 txTarget = gl_TEXTURE_RECTANGLE
623 (internalFormat,dataFormat) <- txSetup txTarget dTy
624 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
625 glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
626 return txTarget
627 Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do
628 let VV2U (V2 w h) = txSize
629 txTarget = if layerCnt > 1 then gl_TEXTURE_2D_MULTISAMPLE_ARRAY else gl_TEXTURE_2D_MULTISAMPLE
630 isFixed = fromIntegral $ if isFixedLocations then gl_TRUE else gl_FALSE
631 (internalFormat,dataFormat) <- txSetup txTarget dTy
632 case layerCnt > 1 of
633 True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed
634 False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed
635 return txTarget
636 TextureBuffer dTy -> do
637 fail "internal error: buffer texture is not supported yet"
638 -- TODO
639 let VV2U (V2 w h) = txSize
640 txTarget = gl_TEXTURE_2D
641 (internalFormat,dataFormat) <- txSetup txTarget dTy
642 glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
643 return txTarget
644 return $ GLTexture
645 { glTextureObject = to
646 , glTextureTarget = target
647 }
648
649primitiveToFetchPrimitive :: Primitive -> FetchPrimitive
650primitiveToFetchPrimitive prim = case prim of
651 TriangleStrip -> Triangles
652 TriangleList -> Triangles
653 TriangleFan -> Triangles
654 LineStrip -> Lines
655 LineList -> Lines
656 PointList -> Points
657 TriangleStripAdjacency -> TrianglesAdjacency
658 TriangleListAdjacency -> TrianglesAdjacency
659 LineStripAdjacency -> LinesAdjacency
660 LineListAdjacency -> LinesAdjacency
661
662primitiveToGLType :: Primitive -> GLenum
663primitiveToGLType p = case p of
664 TriangleStrip -> gl_TRIANGLE_STRIP
665 TriangleList -> gl_TRIANGLES
666 TriangleFan -> gl_TRIANGLE_FAN
667 LineStrip -> gl_LINE_STRIP
668 LineList -> gl_LINES
669 PointList -> gl_POINTS
670 TriangleStripAdjacency -> gl_TRIANGLE_STRIP_ADJACENCY
671 TriangleListAdjacency -> gl_TRIANGLES_ADJACENCY
672 LineStripAdjacency -> gl_LINE_STRIP_ADJACENCY
673 LineListAdjacency -> gl_LINES_ADJACENCY
674
675inputTypeToTextureTarget :: InputType -> GLenum
676inputTypeToTextureTarget ty = case ty of
677 STexture1D -> gl_TEXTURE_1D
678 STexture2D -> gl_TEXTURE_2D
679 STextureCube -> gl_TEXTURE_CUBE_MAP
680 STexture1DArray -> gl_TEXTURE_1D_ARRAY
681 STexture2DArray -> gl_TEXTURE_2D_ARRAY
682 STexture2DRect -> gl_TEXTURE_RECTANGLE
683
684 FTexture1D -> gl_TEXTURE_1D
685 FTexture2D -> gl_TEXTURE_2D
686 FTexture3D -> gl_TEXTURE_3D
687 FTextureCube -> gl_TEXTURE_CUBE_MAP
688 FTexture1DArray -> gl_TEXTURE_1D_ARRAY
689 FTexture2DArray -> gl_TEXTURE_2D_ARRAY
690 FTexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE
691 FTexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY
692 FTextureBuffer -> gl_TEXTURE_BUFFER
693 FTexture2DRect -> gl_TEXTURE_RECTANGLE
694
695 ITexture1D -> gl_TEXTURE_1D
696 ITexture2D -> gl_TEXTURE_2D
697 ITexture3D -> gl_TEXTURE_3D
698 ITextureCube -> gl_TEXTURE_CUBE_MAP
699 ITexture1DArray -> gl_TEXTURE_1D_ARRAY
700 ITexture2DArray -> gl_TEXTURE_2D_ARRAY
701 ITexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE
702 ITexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY
703 ITextureBuffer -> gl_TEXTURE_BUFFER
704 ITexture2DRect -> gl_TEXTURE_RECTANGLE
705
706 UTexture1D -> gl_TEXTURE_1D
707 UTexture2D -> gl_TEXTURE_2D
708 UTexture3D -> gl_TEXTURE_3D
709 UTextureCube -> gl_TEXTURE_CUBE_MAP
710 UTexture1DArray -> gl_TEXTURE_1D_ARRAY
711 UTexture2DArray -> gl_TEXTURE_2D_ARRAY
712 UTexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE
713 UTexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY
714 UTextureBuffer -> gl_TEXTURE_BUFFER
715 UTexture2DRect -> gl_TEXTURE_RECTANGLE
716
717 _ -> error "internal error (inputTypeToTextureTarget)!"
diff --git a/LICENSE b/LICENSE
index edd74e8..2f1afdf 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,28 +1,30 @@
1Copyright (c) 2015, LambdaCube 3D 1Copyright (c) 2015, Csaba Hruska, Peter Divianszky
2
2All rights reserved. 3All rights reserved.
3 4
4Redistribution and use in source and binary forms, with or without 5Redistribution and use in source and binary forms, with or without
5modification, are permitted provided that the following conditions are met: 6modification, are permitted provided that the following conditions are met:
6 7
7* Redistributions of source code must retain the above copyright notice, this 8 * Redistributions of source code must retain the above copyright
8 list of conditions and the following disclaimer. 9 notice, this list of conditions and the following disclaimer.
9 10
10* Redistributions in binary form must reproduce the above copyright notice, 11 * Redistributions in binary form must reproduce the above
11 this list of conditions and the following disclaimer in the documentation 12 copyright notice, this list of conditions and the following
12 and/or other materials provided with the distribution. 13 disclaimer in the documentation and/or other materials provided
14 with the distribution.
13 15
14* Neither the name of lambdacube-gl nor the names of its 16 * Neither the name of Csaba Hruska, Peter Divianszky nor the names of other
15 contributors may be used to endorse or promote products derived from 17 contributors may be used to endorse or promote products derived
16 this software without specific prior written permission. 18 from this software without specific prior written permission.
17 19
18THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
24SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
25CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
26OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
27OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
diff --git a/Monkey.lcmesh b/Monkey.lcmesh
new file mode 100644
index 0000000..b651d61
--- /dev/null
+++ b/Monkey.lcmesh
Binary files differ
diff --git a/SampleIR.hs b/SampleIR.hs
new file mode 100644
index 0000000..4766d9e
--- /dev/null
+++ b/SampleIR.hs
@@ -0,0 +1,241 @@
1{-# LANGUAGE OverloadedStrings, PackageImports, MonadComprehensions #-}
2module SampleIR where
3
4import "GLFW-b" Graphics.UI.GLFW as GLFW
5import Data.Monoid
6import Control.Monad
7import Control.Applicative
8import Data.Vect
9import qualified Data.Trie as T
10import qualified Data.Vector.Storable as SV
11import qualified Data.Vector as V
12import Text.Show.Pretty
13
14import Backend.GL as GL
15import Backend.GL.Mesh
16import IR as IR
17
18import System.Environment
19
20import Driver (compileMain)
21
22-- Our vertices. Tree consecutive floats give a 3D vertex; Three consecutive vertices give a triangle.
23-- A cube has 6 faces with 2 triangles each, so this makes 6*2=12 triangles, and 12*3 vertices
24g_vertex_buffer_data =
25 [ ( 1.0, 1.0,-1.0)
26 , ( 1.0,-1.0,-1.0)
27 , (-1.0,-1.0,-1.0)
28 , ( 1.0, 1.0,-1.0)
29 , (-1.0,-1.0,-1.0)
30 , (-1.0, 1.0,-1.0)
31 , ( 1.0, 1.0,-1.0)
32 , ( 1.0, 1.0, 1.0)
33 , ( 1.0,-1.0, 1.0)
34 , ( 1.0, 1.0,-1.0)
35 , ( 1.0,-1.0, 1.0)
36 , ( 1.0,-1.0,-1.0)
37 , ( 1.0, 1.0, 1.0)
38 , (-1.0,-1.0, 1.0)
39 , ( 1.0,-1.0, 1.0)
40 , ( 1.0, 1.0, 1.0)
41 , (-1.0, 1.0, 1.0)
42 , (-1.0,-1.0, 1.0)
43 , (-1.0, 1.0, 1.0)
44 , (-1.0,-1.0,-1.0)
45 , (-1.0,-1.0, 1.0)
46 , (-1.0, 1.0, 1.0)
47 , (-1.0, 1.0,-1.0)
48 , (-1.0,-1.0,-1.0)
49 , ( 1.0, 1.0,-1.0)
50 , (-1.0, 1.0,-1.0)
51 , (-1.0, 1.0, 1.0)
52 , ( 1.0, 1.0,-1.0)
53 , (-1.0, 1.0, 1.0)
54 , ( 1.0, 1.0, 1.0)
55 , ( 1.0, 1.0,-1.0)
56 , ( 1.0, 1.0, 1.0)
57 , (-1.0, 1.0, 1.0)
58 , ( 1.0, 1.0,-1.0)
59 , (-1.0, 1.0, 1.0)
60 , (-1.0, 1.0,-1.0)
61 ]
62
63-- Two UV coordinatesfor each vertex. They were created with Blender.
64g_uv_buffer_data =
65 [ (0.0, 0.0)
66 , (0.0, 1.0)
67 , (1.0, 1.0)
68 , (0.0, 0.0)
69 , (1.0, 1.0)
70 , (1.0, 0.0)
71 , (0.0, 0.0)
72 , (1.0, 0.0)
73 , (1.0, 1.0)
74 , (0.0, 0.0)
75 , (1.0, 1.0)
76 , (0.0, 1.0)
77 , (1.0, 0.0)
78 , (0.0, 1.0)
79 , (1.0, 1.0)
80 , (1.0, 0.0)
81 , (0.0, 0.0)
82 , (0.0, 1.0)
83 , (0.0, 0.0)
84 , (1.0, 1.0)
85 , (0.0, 1.0)
86 , (0.0, 0.0)
87 , (1.0, 0.0)
88 , (1.0, 1.0)
89 , (0.0, 0.0)
90 , (1.0, 0.0)
91 , (1.0, 1.0)
92 , (0.0, 0.0)
93 , (1.0, 1.0)
94 , (0.0, 1.0)
95 , (0.0, 0.0)
96 , (0.0, 1.0)
97 , (1.0, 1.0)
98 , (0.0, 0.0)
99 , (1.0, 1.0)
100 , (1.0, 0.0)
101 ]
102
103myCube :: Mesh
104myCube = Mesh
105 { mAttributes = T.fromList
106 [ ("position4", A_V4F $ SV.fromList [V4 x y z 1 | (x,y,z) <- g_vertex_buffer_data])
107 , ("vertexUV", A_V2F $ SV.fromList [V2 u v | (u,v) <- g_uv_buffer_data])
108 ]
109 , mPrimitive = P_Triangles
110 , mGPUData = Nothing
111 }
112
113main :: IO ()
114main = do
115 win <- initWindow "LambdaCube 3D DSL Sample" 1024 768
116 let keyIsPressed k = fmap (==KeyState'Pressed) $ getKey win k
117
118 n <- getArgs
119 let srcName = case n of
120 [fn] -> fn
121 _ -> "gfx03"
122
123 let inputSchema =
124 PipelineSchema
125 { GL.slots = T.fromList [("stream",SlotSchema Triangles $ T.fromList [("position",TV3F),("normal",TV3F),("UVTex",TV2F)])
126 ,("stream4",SlotSchema Triangles $ T.fromList [("position4",TV4F),("vertexUV",TV2F)])
127 ]
128 , uniforms = T.fromList [("MVP",M44F),("MVP2",M44F)]
129 }
130 pplInput <- mkGLPipelineInput inputSchema
131
132 gpuCube <- compileMesh myCube
133 gpuMonkey <- loadMesh "Monkey.lcmesh"
134
135 addMesh pplInput "stream4" gpuCube []
136 addMesh pplInput "stream" gpuMonkey []
137
138 let setup = do
139 pplRes <- compileMain "../lambdacube-dsl/tests/accept" srcName
140 case pplRes of
141 Left err -> putStrLn ("error: " ++ err) >> return Nothing
142 Right ppl -> do
143 putStrLn $ ppShow ppl
144 renderer <- allocPipeline ppl
145 setPipelineInput renderer (Just pplInput)
146 sortSlotObjects pplInput
147 putStrLn "reloaded"
148 return $ Just renderer
149
150 let cm' = fromProjective (lookat (Vec3 4 0.5 (-0.6)) (Vec3 0 0 0) (Vec3 0 1 0))
151 cm = fromProjective (lookat (Vec3 3 1.3 0.3) (Vec3 0 0 0) (Vec3 0 1 0))
152 loop renderer = do
153 (w,h) <- getWindowSize win
154 let uniformMap = uniformSetter pplInput
155 texture = uniformFTexture2D "myTextureSampler" uniformMap
156 mvp = uniformM44F "MVP" uniformMap
157 mvp' = uniformM44F "MVP2" uniformMap
158 pm = perspective 0.1 100 (pi/4) (fromIntegral w / fromIntegral h)
159
160 setScreenSize pplInput (fromIntegral w) (fromIntegral h)
161 Just t <- getTime
162 let angle = pi / 24 * realToFrac t
163 mm = fromProjective $ rotationEuler $ Vec3 angle 0 0
164 mvp $! mat4ToM44F $! mm .*. cm .*. pm
165 mvp' $! mat4ToM44F $! mm .*. cm' .*. pm
166 renderPipeline renderer
167 swapBuffers win >> pollEvents
168
169 k <- keyIsPressed Key'Escape
170 reload <- keyIsPressed Key'R
171 rend' <- if not reload then return renderer else do
172 r <- setup
173 case r of
174 Nothing -> return renderer
175 Just a -> do
176 disposePipeline renderer
177 return a
178 when k $ disposePipeline rend'
179 unless k $ loop rend'
180
181 r <- setup
182 case r of
183 Just a -> loop a
184 Nothing -> return ()
185
186 destroyWindow win
187 terminate
188
189vec4ToV4F :: Vec4 -> V4F
190vec4ToV4F (Vec4 x y z w) = V4 x y z w
191
192mat4ToM44F :: Mat4 -> M44F
193mat4ToM44F (Mat4 a b c d) = V4 (vec4ToV4F a) (vec4ToV4F b) (vec4ToV4F c) (vec4ToV4F d)
194
195initWindow :: String -> Int -> Int -> IO Window
196initWindow title width height = do
197 GLFW.init
198 defaultWindowHints
199 mapM_ windowHint
200 [ WindowHint'ContextVersionMajor 3
201 , WindowHint'ContextVersionMinor 3
202 , WindowHint'OpenGLProfile OpenGLProfile'Core
203 , WindowHint'OpenGLForwardCompat True
204 ]
205 Just win <- createWindow width height title Nothing Nothing
206 makeContextCurrent $ Just win
207
208 return win
209
210-- | Perspective transformation matrix in row major order.
211perspective :: Float -- ^ Near plane clipping distance (always positive).
212 -> Float -- ^ Far plane clipping distance (always positive).
213 -> Float -- ^ Field of view of the y axis, in radians.
214 -> Float -- ^ Aspect ratio, i.e. screen's width\/height.
215 -> Mat4
216perspective n f fovy aspect = transpose $
217 Mat4 (Vec4 (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0)
218 (Vec4 0 (2*n/(t-b)) ((t+b)/(t-b)) 0)
219 (Vec4 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n)))
220 (Vec4 0 0 (-1) 0)
221 where
222 t = n*tan(fovy/2)
223 b = -t
224 r = aspect*t
225 l = -r
226
227-- | Pure orientation matrix defined by Euler angles.
228rotationEuler :: Vec3 -> Proj4
229rotationEuler (Vec3 a b c) = orthogonal $ toOrthoUnsafe $ rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c
230
231-- | Camera transformation matrix.
232lookat :: Vec3 -- ^ Camera position.
233 -> Vec3 -- ^ Target position.
234 -> Vec3 -- ^ Upward direction.
235 -> Proj4
236lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r)
237 where
238 w = normalize $ pos &- target
239 u = normalize $ up &^ w
240 v = w &^ u
241 r = transpose $ Mat3 u v w
diff --git a/lambdacube-gl-ir.cabal b/lambdacube-gl-ir.cabal
new file mode 100644
index 0000000..515c433
--- /dev/null
+++ b/lambdacube-gl-ir.cabal
@@ -0,0 +1,86 @@
1-- Initial lambdacube-dsl.cabal generated by cabal init. For further
2-- documentation, see http://haskell.org/cabal/users-guide/
3
4name: lambdacube-gl-ir
5version: 0.1.0.0
6-- synopsis:
7-- description:
8homepage: lambdacube3d.com
9license: BSD3
10license-file: LICENSE
11author: Csaba Hruska, Peter Divianszky
12maintainer: csaba.hruska@gmail.com
13-- copyright:
14category: Graphics
15build-type: Simple
16-- extra-source-files:
17cabal-version: >=1.10
18
19library
20 exposed-modules:
21 SampleIR
22 -- Backend
23 Backend.GL
24 Backend.GL.Backend
25 Backend.GL.Data
26 Backend.GL.Input
27 Backend.GL.Mesh
28 Backend.GL.Type
29 Backend.GL.Util
30 -- other-modules:
31 other-extensions:
32 LambdaCase
33 PatternSynonyms
34 ViewPatterns
35 TypeSynonymInstances
36 FlexibleInstances
37 NoMonomorphismRestriction
38 TypeFamilies
39 RecordWildCards
40 DeriveFunctor
41 DeriveFoldable
42 DeriveTraversable
43 GeneralizedNewtypeDeriving
44 OverloadedStrings
45 TupleSections
46 MonadComprehensions
47 ExistentialQuantification
48 ScopedTypeVariables
49 ParallelListComp
50 build-depends:
51 base >=4.7 && <4.9,
52 containers >=0.5 && <0.6,
53 mtl >=2.2 && <2.3,
54 bytestring >=0.10 && <0.11,
55 vector >=0.10 && <0.11,
56 bytestring-trie >=0.2 && <0.3,
57 OpenGLRaw >=2.4 && <2.5,
58 JuicyPixels >=3.2 && <3.3,
59 JuicyPixels-util,
60 vector-algorithms >=0.6 && <0.7,
61 binary >=0.7 && <0.8,
62 GLFW-b >= 1.4.6,
63 vect >= 0.4.7,
64 pretty-show >=1.6 && <1.7,
65 lambdacube-dsl
66 hs-source-dirs: .
67 default-language: Haskell2010
68
69--executable sampleIR
70-- hs-source-dirs: tests
71-- main-is: sampleIR.hs
72-- build-depends:
73-- lambdacube-dsl,
74-- base >=4.7 && <4.9
75-- default-language: Haskell2010
76
77--test-suite runtests
78-- type: exitcode-stdio-1.0
79-- hs-source-dirs: tests
80-- main-is: runTests.hs
81--
82-- build-depends: base < 4.9
83-- , filepath
84-- , directory
85-- , lambdacube-dsl
86-- default-language: Haskell2010
diff --git a/tests/sampleIR.hs b/tests/sampleIR.hs
new file mode 100644
index 0000000..a68d28a
--- /dev/null
+++ b/tests/sampleIR.hs
@@ -0,0 +1,3 @@
1import qualified SampleIR as S
2
3main = S.main
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 12:36:45 +0000