1 ! (c)2009 Joe Groff bsd license
2 USING: accessors alien alien.c-types arrays
3 assocs classes classes.mixin classes.parser classes.singleton
4 classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
5 generic generic.parser gpu gpu.buffers gpu.framebuffers
6 gpu.framebuffers.private gpu.shaders gpu.shaders.private gpu.state
7 gpu.textures gpu.textures.private half-floats images kernel
8 lexer locals math math.order math.parser namespaces opengl
9 opengl.gl parser quotations sequences slots sorting
10 specialized-arrays strings ui.gadgets.worlds variants
13 QUALIFIED-WITH: alien.c-types c
14 SPECIALIZED-ARRAY: c:float
15 SPECIALIZED-ARRAY: int
16 SPECIALIZED-ARRAY: uint
17 SPECIALIZED-ARRAY: void*
20 UNION: ?integer integer POSTPONE: f ;
54 ALIAS: mat2x2-uniform mat2-uniform
55 ALIAS: mat3x3-uniform mat3-uniform
56 ALIAS: mat4x4-uniform mat4-uniform
59 { name string read-only initial: "" }
60 { uniform-type class read-only initial: float-uniform }
61 { dim ?integer read-only initial: f } ;
69 { start integer read-only }
70 { count integer read-only } ;
72 C: <index-range> index-range
74 TUPLE: multi-index-range
75 { starts uint-array read-only }
76 { counts uint-array read-only } ;
78 C: <multi-index-range> multi-index-range
82 { count integer read-only }
83 { index-type index-type read-only } ;
85 C: <index-elements> index-elements
87 UNION: ?buffer buffer POSTPONE: f ;
89 TUPLE: multi-index-elements
90 { buffer ?buffer read-only }
92 { counts uint-array read-only }
93 { index-type index-type read-only } ;
95 C: <multi-index-elements> multi-index-elements
101 multi-index-elements ;
103 VARIANT: primitive-mode
112 TUPLE: uniform-tuple ;
114 ERROR: invalid-uniform-type uniform ;
118 : gl-index-type ( index-type -- gl-index-type )
120 { ubyte-indexes [ GL_UNSIGNED_BYTE ] }
121 { ushort-indexes [ GL_UNSIGNED_SHORT ] }
122 { uint-indexes [ GL_UNSIGNED_INT ] }
125 : gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
127 { points-mode [ GL_POINTS ] }
128 { lines-mode [ GL_LINES ] }
129 { line-strip-mode [ GL_LINE_STRIP ] }
130 { line-loop-mode [ GL_LINE_LOOP ] }
131 { triangles-mode [ GL_TRIANGLES ] }
132 { triangle-strip-mode [ GL_TRIANGLE_STRIP ] }
133 { triangle-fan-mode [ GL_TRIANGLE_FAN ] }
136 GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
138 GENERIC# render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
140 M: index-range render-vertex-indexes
141 [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] bi* glDrawArrays ;
143 M: index-range render-vertex-indexes-instanced
144 [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] [ ] tri*
145 glDrawArraysInstanced ;
147 M: multi-index-range render-vertex-indexes
148 [ gl-primitive-mode ] [ [ starts>> ] [ counts>> dup length ] bi ] bi*
151 M: index-elements render-vertex-indexes
152 [ gl-primitive-mode ]
153 [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ] bi*
154 index-buffer [ glDrawElements ] with-gpu-data-ptr ;
156 M: index-elements render-vertex-indexes-instanced
157 [ gl-primitive-mode ]
158 [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ]
160 swap index-buffer [ swap glDrawElementsInstanced ] with-gpu-data-ptr ;
162 M: multi-index-elements render-vertex-indexes
163 [ gl-primitive-mode ]
164 [ { [ counts>> ] [ index-type>> gl-index-type ] [ ptrs>> dup length ] [ buffer>> ] } cleave ]
166 GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
168 : (bind-texture-unit) ( texture texture-unit -- )
169 swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
171 GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
172 GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
174 M: uniform-tuple bind-uniform-textures
176 M: uniform-tuple bind-uniforms
179 : uniform-slot-type ( uniform -- type )
180 dup dim>> [ drop sequence ] [
182 { bool-uniform [ boolean ] }
183 { uint-uniform [ integer ] }
184 { int-uniform [ integer ] }
185 { float-uniform [ float ] }
186 { texture-uniform [ texture ] }
191 : uniform>slot ( uniform -- slot )
192 [ name>> ] [ uniform-slot-type ] bi 2array ;
194 : uniform-type-texture-units ( uniform-type -- units )
195 dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
197 : all-uniform-tuple-slots ( class -- slots )
198 dup "uniform-tuple-slots" word-prop
199 [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
201 DEFER: uniform-texture-accessors
203 : uniform-type-texture-accessors ( uniform-type -- accessors )
204 texture-uniform = [ { [ ] } ] [ { } ] if ;
206 : uniform-slot-texture-accessor ( uniform -- accessor )
207 [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi
208 dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ;
210 : uniform-tuple-texture-accessors ( uniform-type -- accessors )
211 all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter
212 [ uniform-slot-texture-accessor ] map ;
214 : uniform-texture-accessors ( uniform-type dim -- accessors )
217 [ uniform-type-texture-accessors ]
218 [ uniform-tuple-texture-accessors ] if
220 2dup swap empty? not and [
222 [ swap nth ] swap prefix
223 over length 1 = [ swap first append ] [ swap suffix ] if
228 : texture-accessor>cleave ( unit accessors -- unit' cleaves )
230 [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
231 [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
233 : [bind-uniform-textures] ( class -- quot )
234 f uniform-texture-accessors
235 0 swap [ texture-accessor>cleave ] map nip
236 \ nip swap \ cleave [ ] 3sequence ;
238 DEFER: [bind-uniform-tuple]
240 :: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
241 { name uniform-index } >quotation :> index-quot
242 { index-quot value>>-quot bi* } >quotation :> pre-quot
245 { bool-uniform { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv } }
246 { int-uniform { dim swap >int-array glUniform1iv } }
247 { uint-uniform { dim swap >uint-array glUniform1uiv } }
248 { float-uniform { dim swap >float-array glUniform1fv } }
250 { bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv } }
251 { ivec2-uniform { dim swap int-array{ } concat-as glUniform2i } }
252 { uvec2-uniform { dim swap uint-array{ } concat-as glUniform2ui } }
253 { vec2-uniform { dim swap float-array{ } concat-as glUniform2f } }
255 { bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv } }
256 { ivec3-uniform { dim swap int-array{ } concat-as glUniform3i } }
257 { uvec3-uniform { dim swap uint-array{ } concat-as glUniform3ui } }
258 { vec3-uniform { dim swap float-array{ } concat-as glUniform3f } }
260 { bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv } }
261 { ivec4-uniform { dim swap int-array{ } concat-as glUniform4iv } }
262 { uvec4-uniform { dim swap uint-array{ } concat-as glUniform4uiv } }
263 { vec4-uniform { dim swap float-array{ } concat-as glUniform4fv } }
265 { mat2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv } }
266 { mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } }
267 { mat2x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x4fv } }
269 { mat3x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x2fv } }
270 { mat3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3fv } }
271 { mat3x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x4fv } }
273 { mat4x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x2fv } }
274 { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } }
275 { mat4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv } }
277 { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
278 } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
280 type uniform-type-texture-units dim * texture-unit +
281 pre-quot value-quot append ;
283 :: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot )
284 { name uniform-index } >quotation :> index-quot
285 { index-quot value>>-quot bi* } >quotation :> pre-quot
288 { bool-uniform [ >c-bool glUniform1i ] }
289 { int-uniform [ glUniform1i ] }
290 { uint-uniform [ glUniform1ui ] }
291 { float-uniform [ glUniform1f ] }
293 { bvec2-uniform [ [ >c-bool ] map first2 glUniform2i ] }
294 { ivec2-uniform [ first2 glUniform2i ] }
295 { uvec2-uniform [ first2 glUniform2ui ] }
296 { vec2-uniform [ first2 glUniform2f ] }
298 { bvec3-uniform [ [ >c-bool ] map first3 glUniform3i ] }
299 { ivec3-uniform [ first3 glUniform3i ] }
300 { uvec3-uniform [ first3 glUniform3ui ] }
301 { vec3-uniform [ first3 glUniform3f ] }
303 { bvec4-uniform [ [ >c-bool ] map first4 glUniform4i ] }
304 { ivec4-uniform [ first4 glUniform4i ] }
305 { uvec4-uniform [ first4 glUniform4ui ] }
306 { vec4-uniform [ first4 glUniform4f ] }
308 { mat2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2fv ] }
309 { mat2x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x3fv ] }
310 { mat2x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x4fv ] }
312 { mat3x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x2fv ] }
313 { mat3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3fv ] }
314 { mat3x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x4fv ] }
316 { mat4x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x2fv ] }
317 { mat4x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x3fv ] }
318 { mat4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4fv ] }
320 { texture-uniform { drop texture-unit glUniform1i } }
321 } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
323 type uniform-type-texture-units texture-unit +
324 pre-quot value-quot append ;
326 :: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
330 [ [ [ swap nth ] swap prefix ] map ]
331 [ [ number>string name "[" append "]." surround ] map ] bi
334 name "." append 1array
335 ] if* :> name-prefixes :> quot-prefixes
336 type all-uniform-tuple-slots :> uniforms
338 texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
339 uniforms name-prefix [bind-uniform-tuple]
341 ] 2map :> value-cleave :> texture-unit'
344 value>>-quot { value-cleave 2cleave } append ;
346 :: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
347 prefix uniform name>> append hyphens>underscores :> name
348 uniform uniform-type>> :> type
350 uniform name>> reader-word 1quotation :> value>>-quot
352 value>>-quot type texture-unit name {
353 { [ type uniform-type? dim and ] [ dim [bind-uniform-array] ] }
354 { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] }
355 [ dim [bind-uniform-struct] ]
358 :: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
359 texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
362 { uniforms-cleave 2cleave } >quotation ;
364 :: [bind-uniforms] ( superclass uniforms -- quot )
365 superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
366 superclass \ bind-uniforms method :> next-method
367 first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
369 { 2dup next-method } bind-quot [ ] append-as ;
371 : define-uniform-tuple-methods ( class superclass uniforms -- )
374 [ \ bind-uniform-textures create-method-in ]
375 [ [bind-uniform-textures] ] bi define
377 [ \ bind-uniforms create-method-in ] 2dip
378 [bind-uniforms] define
381 : parse-uniform-tuple-definition ( -- class superclass uniforms )
383 { ";" [ uniform-tuple f ] }
384 { "<" [ scan-word parse-definition [ first3 uniform boa ] map ] }
387 \ } parse-until parse-definition swap prefix
388 [ first3 uniform boa ] map
392 : (define-uniform-tuple) ( class superclass uniforms -- )
394 [ [ uniform>slot ] map define-tuple-class ]
396 [ uniform-type-texture-units ]
398 [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ]
401 "uniform-tuple-texture-units" set-word-prop
403 [ nip "uniform-tuple-slots" set-word-prop ]
404 [ define-uniform-tuple-methods ]
407 : true-subclasses ( class -- seq )
408 [ subclasses ] keep [ = not ] curry filter ;
412 : define-uniform-tuple ( class superclass uniforms -- )
413 (define-uniform-tuple) ; inline
415 SYNTAX: UNIFORM-TUPLE:
416 parse-uniform-tuple-definition define-uniform-tuple ;
420 : bind-vertex-array ( vertex-array -- )
421 handle>> glBindVertexArray ;
423 : bind-unnamed-output-attachments ( framebuffer attachments -- )
424 [ gl-attachment ] with map
426 [ first glDrawBuffer ]
427 [ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
429 : bind-named-output-attachments ( program-instance framebuffer attachments -- )
430 rot '[ first _ swap output-index ] sort-with [ second ] map
431 bind-unnamed-output-attachments ;
433 : bind-output-attachments ( program-instance framebuffer attachments -- )
435 [ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ;
437 GENERIC: bind-transform-feedback-output ( output -- )
439 M: buffer bind-transform-feedback-output
440 [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip handle>> glBindBufferBase ; inline
442 M: buffer-range bind-transform-feedback-output
443 [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip
444 [ handle>> ] [ offset>> ] [ size>> ] tri glBindBufferRange ; inline
446 M: buffer-ptr bind-transform-feedback-output
447 buffer-ptr>range bind-transform-feedback-output ; inline
449 : gl-feedback-primitive-mode ( primitive-mode -- gl-mode )
451 { points-mode [ GL_POINTS ] }
452 { lines-mode [ GL_LINES ] }
453 { line-strip-mode [ GL_LINES ] }
454 { line-loop-mode [ GL_LINES ] }
455 { triangles-mode [ GL_TRIANGLES ] }
456 { triangle-strip-mode [ GL_TRIANGLES ] }
457 { triangle-fan-mode [ GL_TRIANGLES ] }
462 UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
463 UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
466 { primitive-mode primitive-mode read-only }
467 { vertex-array vertex-array read-only }
468 { uniforms uniform-tuple read-only }
469 { indexes vertex-indexes initial: T{ index-range } read-only }
470 { instances ?integer initial: f read-only }
471 { framebuffer ?any-framebuffer initial: system-framebuffer read-only }
472 { output-attachments sequence initial: { default-attachment } read-only }
473 { transform-feedback-output transform-feedback-output initial: f read-only } ;
475 : <render-set> ( x quot-assoc -- render-set )
476 render-set swap make-tuple ; inline
478 : 2<render-set> ( x y quot-assoc -- render-set )
479 render-set swap 2make-tuple ; inline
481 : 3<render-set> ( x y z quot-assoc -- render-set )
482 render-set swap 3make-tuple ; inline
484 : render ( render-set -- )
486 [ vertex-array>> program-instance>> handle>> glUseProgram ]
488 [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
489 [ bind-uniform-textures ] [ bind-uniforms ] 2bi
493 [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
494 [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
497 [ vertex-array>> program-instance>> ]
499 [ output-attachments>> ] tri
500 bind-output-attachments
502 [ vertex-array>> bind-vertex-array ]
504 dup transform-feedback-output>> [
505 [ primitive-mode>> gl-feedback-primitive-mode glBeginTransformFeedback ]
506 [ bind-transform-feedback-output ] bi*
511 [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
512 [ render-vertex-indexes-instanced ]
513 [ render-vertex-indexes ] if*
516 [ transform-feedback-output>> [ glEndTransformFeedback ] when ]
517 [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]