extra/gpu/render/render.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data arrays
   3 assocs classes classes.mixin classes.parser classes.singleton classes.struct
   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 math.floats.half 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
  11 vocabs.parser words math.vectors.simd ;
  12 FROM: math => float ;
  13 QUALIFIED-WITH: alien.c-types c
  14 SPECIALIZED-ARRAYS: c:float c:int c:uchar c:ushort c:uint c:void* ;
  15 IN: gpu.render
  16
  17 UNION: ?integer integer POSTPONE: f ;
  18
  19 VARIANT: uniform-type
  20     bool-uniform
  21     bvec2-uniform
  22     bvec3-uniform
  23     bvec4-uniform
  24     uint-uniform
  25     uvec2-uniform
  26     uvec3-uniform
  27     uvec4-uniform
  28     int-uniform
  29     ivec2-uniform
  30     ivec3-uniform
  31     ivec4-uniform
  32     float-uniform
  33     vec2-uniform
  34     vec3-uniform
  35     vec4-uniform
  36
  37     mat2-uniform
  38     mat2x3-uniform
  39     mat2x4-uniform
  40
  41     mat3x2-uniform
  42     mat3-uniform
  43     mat3x4-uniform
  44
  45     mat4x2-uniform
  46     mat4x3-uniform
  47     mat4-uniform
  48
  49     texture-uniform ;
  50
  51 ALIAS: mat2x2-uniform mat2-uniform
  52 ALIAS: mat3x3-uniform mat3-uniform
  53 ALIAS: mat4x4-uniform mat4-uniform
  54
  55 TUPLE: uniform
  56     { name         string   read-only initial: "" }
  57     { uniform-type class    read-only initial: float-uniform }
  58     { dim          ?integer read-only initial: f } ;
  59
  60 VARIANT: index-type
  61     ubyte-indexes
  62     ushort-indexes
  63     uint-indexes ;
  64
  65 TUPLE: index-range
  66     { start integer read-only }
  67     { count integer read-only } ;
  68
  69 C: <index-range> index-range
  70
  71 TUPLE: multi-index-range
  72     { starts uint-array read-only }
  73     { counts uint-array read-only } ;
  74
  75 C: <multi-index-range> multi-index-range
  76
  77 TUPLE: index-elements
  78     { ptr read-only }
  79     { count integer read-only }
  80     { index-type index-type read-only } ;
  81
  82 C: <index-elements> index-elements
  83
  84 UNION: ?buffer buffer POSTPONE: f ;
  85
  86 TUPLE: multi-index-elements
  87     { buffer ?buffer read-only }
  88     { ptrs   read-only }
  89     { counts uint-array read-only }
  90     { index-type index-type read-only } ;
  91
  92 C: <multi-index-elements> multi-index-elements
  93
  94 UNION: vertex-indexes
  95     index-range
  96     multi-index-range
  97     index-elements
  98     multi-index-elements
  99     uchar-array
 100     ushort-array
 101     uint-array ;
 102
 103 VARIANT: primitive-mode
 104     points-mode
 105     lines-mode
 106     line-strip-mode
 107     lines-with-adjacency-mode
 108     line-strip-with-adjacency-mode
 109     line-loop-mode
 110     triangles-mode
 111     triangle-strip-mode
 112     triangles-with-adjacency-mode
 113     triangle-strip-with-adjacency-mode
 114     triangle-fan-mode ;
 115
 116 TUPLE: uniform-tuple ;
 117
 118 ERROR: invalid-uniform-type uniform ;
 119
 120 <PRIVATE
 121
 122 : gl-index-type ( index-type -- gl-index-type )
 123     {
 124         { ubyte-indexes  [ GL_UNSIGNED_BYTE  ] }
 125         { ushort-indexes [ GL_UNSIGNED_SHORT ] }
 126         { uint-indexes   [ GL_UNSIGNED_INT   ] }
 127     } case ; inline
 128
 129 : gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
 130     {
 131         { points-mode         [ GL_POINTS         ] }
 132         { lines-mode          [ GL_LINES          ] }
 133         { line-strip-mode     [ GL_LINE_STRIP     ] }
 134         { line-loop-mode      [ GL_LINE_LOOP      ] }
 135         { triangles-mode      [ GL_TRIANGLES      ] }
 136         { triangle-strip-mode [ GL_TRIANGLE_STRIP ] }
 137         { triangle-fan-mode   [ GL_TRIANGLE_FAN   ] }
 138         { lines-with-adjacency-mode          [ GL_LINES_ADJACENCY          ] }
 139         { line-strip-with-adjacency-mode     [ GL_LINE_STRIP_ADJACENCY     ] }
 140         { triangles-with-adjacency-mode      [ GL_TRIANGLES_ADJACENCY      ] }
 141         { triangle-strip-with-adjacency-mode [ GL_TRIANGLE_STRIP_ADJACENCY ] }
 142     } case ; inline
 143
 144 GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
 145
 146 GENERIC# render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
 147
 148 GENERIC: gl-array-element-type ( array -- type )
 149 M: uchar-array  gl-array-element-type drop GL_UNSIGNED_BYTE  ; inline
 150 M: ushort-array gl-array-element-type drop GL_UNSIGNED_SHORT ; inline
 151 M: uint-array   gl-array-element-type drop GL_UNSIGNED_INT   ; inline
 152
 153 M: index-range render-vertex-indexes
 154     [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] bi* glDrawArrays ;
 155
 156 M: index-range render-vertex-indexes-instanced
 157     [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] [ ] tri*
 158     glDrawArraysInstanced ;
 159
 160 M: multi-index-range render-vertex-indexes
 161     [ gl-primitive-mode ] [ [ starts>> ] [ counts>> dup length ] bi ] bi*
 162     glMultiDrawArrays ;
 163
 164 M: index-elements render-vertex-indexes
 165     [ gl-primitive-mode ]
 166     [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ] bi*
 167     index-buffer [ glDrawElements ] with-gpu-data-ptr ;
 168
 169 M: index-elements render-vertex-indexes-instanced
 170     [ gl-primitive-mode ]
 171     [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ]
 172     [ ] tri*
 173     swap index-buffer [ swap glDrawElementsInstanced ] with-gpu-data-ptr ;
 174
 175 M: specialized-array render-vertex-indexes
 176     GL_ELEMENT_ARRAY_BUFFER 0 glBindBuffer
 177     [ gl-primitive-mode ]
 178     [ [ length ] [ gl-array-element-type ] [ >c-ptr ] tri ] bi*
 179     glDrawElements ;
 180
 181 M: specialized-array render-vertex-indexes-instanced
 182     GL_ELEMENT_ARRAY_BUFFER 0 glBindBuffer
 183     [ gl-primitive-mode ]
 184     [ [ length ] [ gl-array-element-type ] [ >c-ptr ] tri ]
 185     [ ] tri* glDrawElementsInstanced ;
 186
 187 M: multi-index-elements render-vertex-indexes
 188     [ gl-primitive-mode ]
 189     [ { [ counts>> ] [ index-type>> gl-index-type ] [ ptrs>> dup length ] [ buffer>> ] } cleave ]
 190     bi*
 191     GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
 192
 193 : (bind-texture-unit) ( texture texture-unit -- )
 194     swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
 195
 196 GENERIC: (bind-uniform-textures) ( program-instance uniform-tuple -- )
 197 GENERIC: (bind-uniforms) ( program-instance uniform-tuple -- )
 198
 199 M: uniform-tuple (bind-uniform-textures)
 200     2drop ;
 201 M: uniform-tuple (bind-uniforms)
 202     2drop ;
 203
 204 : uniform-slot-type ( uniform -- type )
 205     dup dim>> [ drop sequence ] [
 206         uniform-type>> {
 207             { bool-uniform    [ boolean ] }
 208             { uint-uniform    [ integer ] }
 209             { int-uniform     [ integer ] }
 210             { float-uniform   [ float   ] }
 211             { texture-uniform [ texture ] }
 212             [ drop sequence ]
 213         } case
 214     ] if ;
 215
 216 : uniform>slot ( uniform -- slot )
 217     [ name>> ] [ uniform-slot-type ] bi 2array ;
 218
 219 : uniform-type-texture-units ( uniform-type -- units )
 220     dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
 221
 222 : all-uniform-tuple-slots ( class -- slots )
 223     dup "uniform-tuple-slots" word-prop
 224     [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
 225
 226 DEFER: uniform-texture-accessors
 227
 228 : uniform-type-texture-accessors ( uniform-type -- accessors )
 229     texture-uniform = [ { [ ] } ] [ { } ] if ;
 230
 231 : uniform-slot-texture-accessor ( uniform -- accessor )
 232     [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi
 233     dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ;
 234
 235 : uniform-tuple-texture-accessors ( uniform-type -- accessors )
 236     all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter
 237     [ uniform-slot-texture-accessor ] map ;
 238
 239 : uniform-texture-accessors ( uniform-type dim -- accessors )
 240     [
 241         dup uniform-type?
 242         [ uniform-type-texture-accessors ]
 243         [ uniform-tuple-texture-accessors ] if
 244     ] [
 245         2dup swap empty? not and [
 246             iota [
 247                 [ swap nth ] swap prefix
 248                 over length 1 = [ swap first append ] [ swap suffix ] if
 249             ] with map
 250         ] [ drop ] if
 251     ] bi* ;
 252
 253 : texture-accessor>cleave ( unit accessors -- unit' cleaves )
 254     dup last sequence?
 255     [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
 256     [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
 257
 258 : [bind-uniform-textures] ( class -- quot )
 259     f uniform-texture-accessors
 260     0 swap [ texture-accessor>cleave ] map nip
 261     \ nip swap \ cleave [ ] 3sequence ;
 262
 263 UNION: binary-data
 264     c-ptr specialized-array struct simd-128 ;
 265
 266 GENERIC: >uniform-bool-array ( sequence -- c-array )
 267 GENERIC: >uniform-int-array ( sequence -- c-array )
 268 GENERIC: >uniform-uint-array ( sequence -- c-array )
 269 GENERIC: >uniform-float-array  ( sequence -- c-array )
 270
 271 GENERIC# >uniform-bvec-array 1 ( sequence dim -- c-array )
 272 GENERIC# >uniform-ivec-array 1 ( sequence dim -- c-array )
 273 GENERIC# >uniform-uvec-array 1 ( sequence dim -- c-array )
 274 GENERIC# >uniform-vec-array  1 ( sequence dim -- c-array )
 275
 276 GENERIC# >uniform-matrix 2 ( sequence cols rows -- c-array )
 277
 278 GENERIC# >uniform-matrix-array 2 ( sequence cols rows -- c-array )
 279
 280 GENERIC: bind-uniform-bvec2 ( index sequence -- )
 281 GENERIC: bind-uniform-bvec3 ( index sequence -- )
 282 GENERIC: bind-uniform-bvec4 ( index sequence -- )
 283 GENERIC: bind-uniform-ivec2 ( index sequence -- )
 284 GENERIC: bind-uniform-ivec3 ( index sequence -- )
 285 GENERIC: bind-uniform-ivec4 ( index sequence -- )
 286 GENERIC: bind-uniform-uvec2 ( index sequence -- )
 287 GENERIC: bind-uniform-uvec3 ( index sequence -- )
 288 GENERIC: bind-uniform-uvec4 ( index sequence -- )
 289 GENERIC: bind-uniform-vec2  ( index sequence -- )
 290 GENERIC: bind-uniform-vec3  ( index sequence -- )
 291 GENERIC: bind-uniform-vec4  ( index sequence -- )
 292
 293 M: object >uniform-bool-array [ >c-bool ] int-array{ } map-as ; inline
 294 M: binary-data >uniform-bool-array ; inline
 295
 296 M: object >uniform-int-array c:int >c-array ; inline
 297 M: binary-data >uniform-int-array ; inline
 298
 299 M: object >uniform-uint-array c:uint >c-array ; inline
 300 M: binary-data >uniform-uint-array ; inline
 301
 302 M: object >uniform-float-array c:float >c-array ; inline
 303 M: binary-data >uniform-float-array ; inline
 304
 305 M: object >uniform-bvec-array '[ _ head-slice [ >c-bool ] int-array{ } map-as ] map concat ; inline
 306 M: binary-data >uniform-bvec-array drop ; inline
 307
 308 M: object >uniform-ivec-array '[ _ head ] map int-array{ } concat-as ; inline
 309 M: binary-data >uniform-ivec-array drop ; inline
 310
 311 M: object >uniform-uvec-array '[ _ head ] map uint-array{ } concat-as ; inline
 312 M: binary-data >uniform-uvec-array drop ; inline
 313
 314 M: object >uniform-vec-array '[ _ head ] map float-array{ } concat-as ; inline
 315 M: binary-data >uniform-vec-array drop ; inline
 316
 317 M:: object >uniform-matrix ( sequence cols rows -- c-array )
 318      sequence flip cols head-slice
 319      [ rows head-slice c:float >c-array ] { } map-as concat ; inline
 320 M: binary-data >uniform-matrix 2drop ; inline
 321
 322 M: object >uniform-matrix-array
 323      '[ _ _ >uniform-matrix ] map concat ; inline
 324 M: binary-data >uniform-matrix-array 2drop ; inline
 325
 326 M: object bind-uniform-bvec2 ( index sequence -- )
 327     1 swap 2 head-slice [ >c-bool ] int-array{ } map-as glUniform2iv ; inline
 328 M: binary-data bind-uniform-bvec2 ( index sequence -- )
 329     1 swap glUniform2iv ; inline
 330 M: object bind-uniform-bvec3 ( index sequence -- )
 331     1 swap 3 head-slice [ >c-bool ] int-array{ } map-as glUniform3iv ; inline
 332 M: binary-data bind-uniform-bvec3 ( index sequence -- )
 333     1 swap glUniform3iv ; inline
 334 M: object bind-uniform-bvec4 ( index sequence -- )
 335     1 swap 4 head-slice [ >c-bool ] int-array{ } map-as glUniform4iv ; inline
 336 M: binary-data bind-uniform-bvec4 ( index sequence -- )
 337     1 swap glUniform4iv ; inline
 338
 339 M: object bind-uniform-ivec2 ( index sequence -- ) first2 glUniform2i ; inline
 340 M: binary-data bind-uniform-ivec2 ( index sequence -- ) 1 swap glUniform2iv ; inline
 341
 342 M: object bind-uniform-ivec3 ( index sequence -- ) first3 glUniform3i ; inline
 343 M: binary-data bind-uniform-ivec3 ( index sequence -- ) 1 swap glUniform3iv ; inline
 344
 345 M: object bind-uniform-ivec4 ( index sequence -- ) first4 glUniform4i ; inline
 346 M: binary-data bind-uniform-ivec4 ( index sequence -- ) 1 swap glUniform4iv ; inline
 347
 348 M: object bind-uniform-uvec2 ( index sequence -- ) first2 glUniform2ui ; inline
 349 M: binary-data bind-uniform-uvec2 ( index sequence -- ) 1 swap glUniform2uiv ; inline
 350
 351 M: object bind-uniform-uvec3 ( index sequence -- ) first3 glUniform3ui ; inline
 352 M: binary-data bind-uniform-uvec3 ( index sequence -- ) 1 swap glUniform3uiv ; inline
 353
 354 M: object bind-uniform-uvec4 ( index sequence -- ) first4 glUniform4ui ; inline
 355 M: binary-data bind-uniform-uvec4 ( index sequence -- ) 1 swap glUniform4uiv ; inline
 356
 357 M: object bind-uniform-vec2 ( index sequence -- ) first2 glUniform2f ; inline
 358 M: binary-data bind-uniform-vec2 ( index sequence -- ) 1 swap glUniform2fv ; inline
 359
 360 M: object bind-uniform-vec3 ( index sequence -- ) first3 glUniform3f ; inline
 361 M: binary-data bind-uniform-vec3 ( index sequence -- ) 1 swap glUniform3fv ; inline
 362
 363 M: object bind-uniform-vec4 ( index sequence -- ) first4 glUniform4f ; inline
 364 M: binary-data bind-uniform-vec4 ( index sequence -- ) 1 swap glUniform4fv ; inline
 365
 366 DEFER: [bind-uniform-tuple]
 367
 368 :: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
 369     { name uniform-index } >quotation :> index-quot
 370     { index-quot value>>-quot bi* } >quotation :> pre-quot
 371
 372     type H{
 373         { bool-uniform  { dim swap >uniform-bool-array  glUniform1iv  } }
 374         { int-uniform   { dim swap >uniform-int-array   glUniform1iv  } }
 375         { uint-uniform  { dim swap >uniform-uint-array  glUniform1uiv } }
 376         { float-uniform { dim swap >uniform-float-array glUniform1fv  } }
 377
 378         { bvec2-uniform { dim swap 2 >uniform-bvec-array glUniform2iv  } }
 379         { ivec2-uniform { dim swap 2 >uniform-ivec-array glUniform2i  } }
 380         { uvec2-uniform { dim swap 2 >uniform-uvec-array glUniform2ui } }
 381         { vec2-uniform  { dim swap 2 >uniform-vec-array  glUniform2f  } }
 382
 383         { bvec3-uniform { dim swap 3 >uniform-bvec-array glUniform3iv  } }
 384         { ivec3-uniform { dim swap 3 >uniform-ivec-array glUniform3i  } }
 385         { uvec3-uniform { dim swap 3 >uniform-uvec-array glUniform3ui } }
 386         { vec3-uniform  { dim swap 3 >uniform-vec-array  glUniform3f  } }
 387
 388         { bvec4-uniform { dim swap 4 >uniform-bvec-array glUniform4iv  } }
 389         { ivec4-uniform { dim swap 4 >uniform-ivec-array glUniform4iv  } }
 390         { uvec4-uniform { dim swap 4 >uniform-uvec-array glUniform4uiv } }
 391         { vec4-uniform  { dim swap 4 >uniform-vec-array  glUniform4fv  } }
 392
 393         { mat2-uniform   { [ dim 0 ] dip 2 2 >uniform-matrix-array glUniformMatrix2fv   } }
 394         { mat2x3-uniform { [ dim 0 ] dip 2 3 >uniform-matrix-array glUniformMatrix2x3fv } }
 395         { mat2x4-uniform { [ dim 0 ] dip 2 4 >uniform-matrix-array glUniformMatrix2x4fv } }
 396
 397         { mat3x2-uniform { [ dim 0 ] dip 3 2 >uniform-matrix-array glUniformMatrix3x2fv } }
 398         { mat3-uniform   { [ dim 0 ] dip 3 3 >uniform-matrix-array glUniformMatrix3fv   } }
 399         { mat3x4-uniform { [ dim 0 ] dip 3 4 >uniform-matrix-array glUniformMatrix3x4fv } }
 400
 401         { mat4x2-uniform { [ dim 0 ] dip 4 2 >uniform-matrix-array glUniformMatrix4x2fv } }
 402         { mat4x3-uniform { [ dim 0 ] dip 4 3 >uniform-matrix-array glUniformMatrix4x3fv } }
 403         { mat4-uniform   { [ dim 0 ] dip 4 4 >uniform-matrix-array glUniformMatrix4fv   } }
 404
 405         { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
 406     } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
 407
 408     type uniform-type-texture-units dim * texture-unit +
 409     pre-quot value-quot append ;
 410
 411 :: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot )
 412     { name uniform-index } >quotation :> index-quot
 413     { index-quot value>>-quot bi* } >quotation :> pre-quot
 414
 415     type H{
 416         { bool-uniform  [ >c-bool glUniform1i  ] }
 417         { int-uniform   [ glUniform1i  ] }
 418         { uint-uniform  [ glUniform1ui ] }
 419         { float-uniform [ glUniform1f  ] }
 420
 421         { bvec2-uniform [ bind-uniform-bvec2 ] }
 422         { ivec2-uniform [ bind-uniform-ivec2 ] }
 423         { uvec2-uniform [ bind-uniform-uvec2 ] }
 424         { vec2-uniform  [ bind-uniform-vec2  ] }
 425
 426         { bvec3-uniform [ bind-uniform-bvec3 ] }
 427         { ivec3-uniform [ bind-uniform-ivec3 ] }
 428         { uvec3-uniform [ bind-uniform-uvec3 ] }
 429         { vec3-uniform  [ bind-uniform-vec3  ] }
 430
 431         { bvec4-uniform [ bind-uniform-bvec4 ] }
 432         { ivec4-uniform [ bind-uniform-ivec4 ] }
 433         { uvec4-uniform [ bind-uniform-uvec4 ] }
 434         { vec4-uniform  [ bind-uniform-vec4  ] }
 435
 436         { mat2-uniform   [ [ 1 0 ] dip 2 2 >uniform-matrix glUniformMatrix2fv   ] }
 437         { mat2x3-uniform [ [ 1 0 ] dip 2 3 >uniform-matrix glUniformMatrix2x3fv ] }
 438         { mat2x4-uniform [ [ 1 0 ] dip 2 4 >uniform-matrix glUniformMatrix2x4fv ] }
 439
 440         { mat3x2-uniform [ [ 1 0 ] dip 3 2 >uniform-matrix glUniformMatrix3x2fv ] }
 441         { mat3-uniform   [ [ 1 0 ] dip 3 3 >uniform-matrix glUniformMatrix3fv   ] }
 442         { mat3x4-uniform [ [ 1 0 ] dip 3 4 >uniform-matrix glUniformMatrix3x4fv ] }
 443
 444         { mat4x2-uniform [ [ 1 0 ] dip 4 2 >uniform-matrix glUniformMatrix4x2fv ] }
 445         { mat4x3-uniform [ [ 1 0 ] dip 4 3 >uniform-matrix glUniformMatrix4x3fv ] }
 446         { mat4-uniform   [ [ 1 0 ] dip 4 4 >uniform-matrix glUniformMatrix4fv   ] }
 447
 448         { texture-uniform { drop texture-unit glUniform1i } }
 449     } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
 450
 451     type uniform-type-texture-units texture-unit +
 452     pre-quot value-quot append ;
 453
 454 :: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
 455     dim
 456     [
 457         iota
 458         [ [ [ swap nth ] swap prefix ] map ]
 459         [ [ number>string name "[" append "]." surround ] map ] bi
 460     ] [
 461         { [ ] }
 462         name "." append 1array
 463     ] if* :> ( quot-prefixes name-prefixes )
 464     type all-uniform-tuple-slots :> uniforms
 465
 466     texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
 467         uniforms name-prefix [bind-uniform-tuple]
 468         quot-prefix prepend
 469     ] 2map :> ( texture-unit' value-cleave )
 470
 471     texture-unit'
 472     value>>-quot { value-cleave 2cleave } append ;
 473
 474 :: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
 475     prefix uniform name>> append hyphens>underscores :> name
 476     uniform uniform-type>> :> type
 477     uniform dim>> :> dim
 478     uniform name>> reader-word 1quotation :> value>>-quot
 479
 480     value>>-quot type texture-unit name {
 481         { [ type uniform-type? dim     and ] [ dim [bind-uniform-array] ] }
 482         { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] }
 483         [ dim [bind-uniform-struct] ]
 484     } cond ;
 485
 486 :: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
 487     texture-unit uniforms [ prefix [bind-uniform] ] map :> ( texture-unit' uniforms-cleave )
 488
 489     texture-unit'
 490     { uniforms-cleave 2cleave } >quotation ;
 491
 492 :: [bind-uniforms] ( superclass uniforms -- quot )
 493     superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
 494     superclass \ (bind-uniforms) method :> next-method
 495     first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
 496
 497     { 2dup next-method } bind-quot [ ] append-as ;
 498
 499 : define-uniform-tuple-methods ( class superclass uniforms -- )
 500     [
 501         2drop
 502         [ \ (bind-uniform-textures) create-method-in ]
 503         [ [bind-uniform-textures] ] bi define
 504     ] [
 505         [ \ (bind-uniforms) create-method-in ] 2dip
 506         [bind-uniforms] define
 507     ] 3bi ;
 508
 509 : parse-uniform-tuple-definition ( -- class superclass uniforms )
 510     CREATE-CLASS scan {
 511         { ";" [ uniform-tuple f ] }
 512         { "<" [ scan-word parse-definition [ first3 uniform boa ] map ] }
 513         { "{" [
 514             uniform-tuple
 515             \ } parse-until parse-definition swap prefix
 516             [ first3 uniform boa ] map
 517         ] }
 518     } case ;
 519
 520 : (define-uniform-tuple) ( class superclass uniforms -- )
 521     {
 522         [ [ uniform>slot ] map define-tuple-class ]
 523         [
 524             [ uniform-type-texture-units ]
 525             [
 526                 [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ]
 527                 [ + ] map-reduce
 528             ] bi* +
 529             "uniform-tuple-texture-units" set-word-prop
 530         ]
 531         [ nip "uniform-tuple-slots" set-word-prop ]
 532         [ define-uniform-tuple-methods ]
 533     } 3cleave ;
 534
 535 : true-subclasses ( class -- seq )
 536     [ subclasses ] keep [ = not ] curry filter ;
 537
 538 PRIVATE>
 539
 540 : define-uniform-tuple ( class superclass uniforms -- )
 541     (define-uniform-tuple) ; inline
 542
 543 SYNTAX: UNIFORM-TUPLE:
 544     parse-uniform-tuple-definition define-uniform-tuple ;
 545
 546 <PRIVATE
 547
 548 : bind-unnamed-output-attachments ( framebuffer attachments -- )
 549     [ gl-attachment ] with map
 550     dup length 1 =
 551     [ first glDrawBuffer ]
 552     [ [ length ] [ c:int >c-array ] bi glDrawBuffers ] if ;
 553
 554 : bind-named-output-attachments ( program-instance framebuffer attachments -- )
 555     rot '[ first _ swap output-index ] sort-with values
 556     bind-unnamed-output-attachments ;
 557
 558 : bind-output-attachments ( program-instance framebuffer attachments -- )
 559     dup first sequence?
 560     [ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ;
 561
 562 GENERIC: bind-transform-feedback-output ( output -- )
 563
 564 M: buffer bind-transform-feedback-output
 565     [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip handle>> glBindBufferBase ; inline
 566
 567 M: buffer-range bind-transform-feedback-output
 568     [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip
 569     [ handle>> ] [ offset>> ] [ size>> ] tri glBindBufferRange ; inline
 570
 571 M: buffer-ptr bind-transform-feedback-output
 572     buffer-ptr>range bind-transform-feedback-output ; inline
 573
 574 : gl-feedback-primitive-mode ( primitive-mode -- gl-mode )
 575     {
 576         { points-mode         [ GL_POINTS    ] }
 577         { lines-mode          [ GL_LINES     ] }
 578         { line-strip-mode     [ GL_LINES     ] }
 579         { line-loop-mode      [ GL_LINES     ] }
 580         { triangles-mode      [ GL_TRIANGLES ] }
 581         { triangle-strip-mode [ GL_TRIANGLES ] }
 582         { triangle-fan-mode   [ GL_TRIANGLES ] }
 583     } case ;
 584
 585 PRIVATE>
 586
 587 UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
 588 UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
 589
 590 TUPLE: render-set
 591     { primitive-mode primitive-mode read-only }
 592     { vertex-array vertex-array initial: T{ vertex-array-collection } read-only }
 593     { uniforms uniform-tuple read-only }
 594     { indexes vertex-indexes initial: T{ index-range } read-only }
 595     { instances ?integer initial: f read-only }
 596     { framebuffer ?any-framebuffer initial: system-framebuffer read-only }
 597     { output-attachments sequence initial: { default-attachment } read-only }
 598     { transform-feedback-output transform-feedback-output initial: f read-only } ;
 599
 600 : <render-set> ( x quot-assoc -- render-set )
 601     render-set swap make-tuple ; inline
 602
 603 : 2<render-set> ( x y quot-assoc -- render-set )
 604     render-set swap 2make-tuple ; inline
 605
 606 : 3<render-set> ( x y z quot-assoc -- render-set )
 607     render-set swap 3make-tuple ; inline
 608
 609 : bind-uniforms ( program-instance uniforms -- )
 610     [ (bind-uniform-textures) ] [ (bind-uniforms) ] 2bi ; inline
 611
 612 : render ( render-set -- )
 613     {
 614         [ vertex-array>> program-instance>> handle>> glUseProgram ]
 615         [
 616             [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
 617             bind-uniforms
 618         ]
 619         [
 620             framebuffer>>
 621             [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
 622             [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
 623         ]
 624         [
 625             [ vertex-array>> program-instance>> ]
 626             [ framebuffer>> ]
 627             [ output-attachments>> ] tri
 628             bind-output-attachments
 629         ]
 630         [ vertex-array>> bind-vertex-array ]
 631         [
 632             dup transform-feedback-output>> [
 633                 [ primitive-mode>> gl-feedback-primitive-mode glBeginTransformFeedback ]
 634                 [ bind-transform-feedback-output ] bi*
 635             ] [ drop ] if*
 636         ]
 637
 638         [
 639             [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
 640             [ render-vertex-indexes-instanced ]
 641             [ render-vertex-indexes ] if*
 642         ]
 643
 644         [ transform-feedback-output>> [ glEndTransformFeedback ] when ]
 645         [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]
 646     } cleave ; inline
 647