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
   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
  11 vocabs.parser words ;
  12 FROM: math => float ;
  13 QUALIFIED-WITH: alien.c-types c
  14 SPECIALIZED-ARRAY: c:float
  15 SPECIALIZED-ARRAY: int
  16 SPECIALIZED-ARRAY: uint
  17 SPECIALIZED-ARRAY: void*
  18 IN: gpu.render
  19
  20 UNION: ?integer integer POSTPONE: f ;
  21
  22 VARIANT: uniform-type
  23     bool-uniform
  24     bvec2-uniform
  25     bvec3-uniform
  26     bvec4-uniform
  27     uint-uniform
  28     uvec2-uniform
  29     uvec3-uniform
  30     uvec4-uniform
  31     int-uniform
  32     ivec2-uniform
  33     ivec3-uniform
  34     ivec4-uniform
  35     float-uniform
  36     vec2-uniform
  37     vec3-uniform
  38     vec4-uniform
  39
  40     mat2-uniform
  41     mat2x3-uniform
  42     mat2x4-uniform
  43
  44     mat3x2-uniform
  45     mat3-uniform
  46     mat3x4-uniform
  47
  48     mat4x2-uniform
  49     mat4x3-uniform
  50     mat4-uniform
  51
  52     texture-uniform ;
  53
  54 ALIAS: mat2x2-uniform mat2-uniform
  55 ALIAS: mat3x3-uniform mat3-uniform
  56 ALIAS: mat4x4-uniform mat4-uniform
  57
  58 TUPLE: uniform
  59     { name         string   read-only initial: "" }
  60     { uniform-type class    read-only initial: float-uniform }
  61     { dim          ?integer read-only initial: f } ;
  62
  63 VARIANT: index-type
  64     ubyte-indexes
  65     ushort-indexes
  66     uint-indexes ;
  67
  68 TUPLE: index-range
  69     { start integer read-only }
  70     { count integer read-only } ;
  71
  72 C: <index-range> index-range
  73
  74 TUPLE: multi-index-range
  75     { starts uint-array read-only }
  76     { counts uint-array read-only } ;
  77
  78 C: <multi-index-range> multi-index-range
  79
  80 TUPLE: index-elements
  81     { ptr read-only }
  82     { count integer read-only }
  83     { index-type index-type read-only } ;
  84
  85 C: <index-elements> index-elements
  86
  87 UNION: ?buffer buffer POSTPONE: f ;
  88
  89 TUPLE: multi-index-elements
  90     { buffer ?buffer read-only }
  91     { ptrs   read-only }
  92     { counts uint-array read-only }
  93     { index-type index-type read-only } ;
  94
  95 C: <multi-index-elements> multi-index-elements
  96
  97 UNION: vertex-indexes
  98     index-range
  99     multi-index-range
 100     index-elements
 101     multi-index-elements ;
 102
 103 VARIANT: primitive-mode
 104     points-mode
 105     lines-mode
 106     line-strip-mode
 107     line-loop-mode
 108     triangles-mode
 109     triangle-strip-mode
 110     triangle-fan-mode ;
 111
 112 TUPLE: uniform-tuple ;
 113
 114 ERROR: invalid-uniform-type uniform ;
 115
 116 <PRIVATE
 117
 118 : gl-index-type ( index-type -- gl-index-type )
 119     {
 120         { ubyte-indexes  [ GL_UNSIGNED_BYTE  ] }
 121         { ushort-indexes [ GL_UNSIGNED_SHORT ] }
 122         { uint-indexes   [ GL_UNSIGNED_INT   ] }
 123     } case ;
 124
 125 : gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
 126     {
 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   ] }
 134     } case ;
 135
 136 GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
 137
 138 GENERIC# render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
 139
 140 M: index-range render-vertex-indexes
 141     [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] bi* glDrawArrays ;
 142
 143 M: index-range render-vertex-indexes-instanced
 144     [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] [ ] tri*
 145     glDrawArraysInstanced ;
 146
 147 M: multi-index-range render-vertex-indexes
 148     [ gl-primitive-mode ] [ [ starts>> ] [ counts>> dup length ] bi ] bi*
 149     glMultiDrawArrays ;
 150
 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 ;
 155
 156 M: index-elements render-vertex-indexes-instanced
 157     [ gl-primitive-mode ]
 158     [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ]
 159     [ ] tri*
 160     swap index-buffer [ swap glDrawElementsInstanced ] with-gpu-data-ptr ;
 161
 162 M: multi-index-elements render-vertex-indexes
 163     [ gl-primitive-mode ]
 164     [ { [ counts>> ] [ index-type>> gl-index-type ] [ ptrs>> dup length ] [ buffer>> ] } cleave ]
 165     bi*
 166     GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
 167
 168 : (bind-texture-unit) ( texture texture-unit -- )
 169     swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
 170
 171 GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
 172 GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
 173
 174 M: uniform-tuple bind-uniform-textures
 175     2drop ;
 176 M: uniform-tuple bind-uniforms
 177     2drop ;
 178
 179 : uniform-slot-type ( uniform -- type )
 180     dup dim>> [ drop sequence ] [
 181         uniform-type>> {
 182             { bool-uniform    [ boolean ] }
 183             { uint-uniform    [ integer ] }
 184             { int-uniform     [ integer ] }
 185             { float-uniform   [ float   ] }
 186             { texture-uniform [ texture ] }
 187             [ drop sequence ]
 188         } case
 189     ] if ;
 190
 191 : uniform>slot ( uniform -- slot )
 192     [ name>> ] [ uniform-slot-type ] bi 2array ;
 193
 194 : uniform-type-texture-units ( uniform-type -- units )
 195     dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
 196
 197 : all-uniform-tuple-slots ( class -- slots )
 198     dup "uniform-tuple-slots" word-prop
 199     [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
 200
 201 DEFER: uniform-texture-accessors
 202
 203 : uniform-type-texture-accessors ( uniform-type -- accessors )
 204     texture-uniform = [ { [ ] } ] [ { } ] if ;
 205
 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 ;
 209
 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 ;
 213
 214 : uniform-texture-accessors ( uniform-type dim -- accessors )
 215     [
 216         dup uniform-type?
 217         [ uniform-type-texture-accessors ]
 218         [ uniform-tuple-texture-accessors ] if
 219     ] [
 220         2dup swap empty? not and [
 221             iota [
 222                 [ swap nth ] swap prefix
 223                 over length 1 = [ swap first append ] [ swap suffix ] if
 224             ] with map
 225         ] [ drop ] if
 226     ] bi* ;
 227
 228 : texture-accessor>cleave ( unit accessors -- unit' cleaves )
 229     dup last sequence?
 230     [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
 231     [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
 232
 233 : [bind-uniform-textures] ( class -- quot )
 234     f uniform-texture-accessors
 235     0 swap [ texture-accessor>cleave ] map nip
 236     \ nip swap \ cleave [ ] 3sequence ;
 237
 238 DEFER: [bind-uniform-tuple]
 239
 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
 243
 244     type H{
 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  } }
 249
 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  } }
 254
 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  } }
 259
 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  } }
 264
 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 } }
 268
 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 } }
 272
 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   } }
 276
 277         { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
 278     } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
 279
 280     type uniform-type-texture-units dim * texture-unit +
 281     pre-quot value-quot append ;
 282
 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
 286
 287     type H{
 288         { bool-uniform  [ >c-bool glUniform1i  ] }
 289         { int-uniform   [ glUniform1i  ] }
 290         { uint-uniform  [ glUniform1ui ] }
 291         { float-uniform [ glUniform1f  ] }
 292
 293         { bvec2-uniform [ [ >c-bool ] map first2 glUniform2i  ] }
 294         { ivec2-uniform [ first2 glUniform2i  ] }
 295         { uvec2-uniform [ first2 glUniform2ui ] }
 296         { vec2-uniform  [ first2 glUniform2f  ] }
 297
 298         { bvec3-uniform [ [ >c-bool ] map first3 glUniform3i  ] }
 299         { ivec3-uniform [ first3 glUniform3i  ] }
 300         { uvec3-uniform [ first3 glUniform3ui ] }
 301         { vec3-uniform  [ first3 glUniform3f  ] }
 302
 303         { bvec4-uniform [ [ >c-bool ] map first4 glUniform4i  ] }
 304         { ivec4-uniform [ first4 glUniform4i  ] }
 305         { uvec4-uniform [ first4 glUniform4ui ] }
 306         { vec4-uniform  [ first4 glUniform4f  ] }
 307
 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 ] }
 311
 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 ] }
 315
 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   ] }
 319
 320         { texture-uniform { drop texture-unit glUniform1i } }
 321     } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
 322
 323     type uniform-type-texture-units texture-unit +
 324     pre-quot value-quot append ;
 325
 326 :: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
 327     dim
 328     [
 329         iota
 330         [ [ [ swap nth ] swap prefix ] map ]
 331         [ [ number>string name "[" append "]." surround ] map ] bi
 332     ] [
 333         { [ ] }
 334         name "." append 1array
 335     ] if* :> name-prefixes :> quot-prefixes
 336     type all-uniform-tuple-slots :> uniforms
 337
 338     texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
 339         uniforms name-prefix [bind-uniform-tuple]
 340         quot-prefix prepend
 341     ] 2map :> value-cleave :> texture-unit'
 342
 343     texture-unit'
 344     value>>-quot { value-cleave 2cleave } append ;
 345
 346 :: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
 347     prefix uniform name>> append hyphens>underscores :> name
 348     uniform uniform-type>> :> type
 349     uniform dim>> :> dim
 350     uniform name>> reader-word 1quotation :> value>>-quot
 351
 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] ]
 356     } cond ;
 357
 358 :: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
 359     texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
 360
 361     texture-unit'
 362     { uniforms-cleave 2cleave } >quotation ;
 363
 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
 368
 369     { 2dup next-method } bind-quot [ ] append-as ;
 370
 371 : define-uniform-tuple-methods ( class superclass uniforms -- )
 372     [
 373         2drop
 374         [ \ bind-uniform-textures create-method-in ]
 375         [ [bind-uniform-textures] ] bi define
 376     ] [
 377         [ \ bind-uniforms create-method-in ] 2dip
 378         [bind-uniforms] define
 379     ] 3bi ;
 380
 381 : parse-uniform-tuple-definition ( -- class superclass uniforms )
 382     CREATE-CLASS scan {
 383         { ";" [ uniform-tuple f ] }
 384         { "<" [ scan-word parse-definition [ first3 uniform boa ] map ] }
 385         { "{" [
 386             uniform-tuple
 387             \ } parse-until parse-definition swap prefix
 388             [ first3 uniform boa ] map
 389         ] }
 390     } case ;
 391
 392 : (define-uniform-tuple) ( class superclass uniforms -- )
 393     {
 394         [ [ uniform>slot ] map define-tuple-class ]
 395         [
 396             [ uniform-type-texture-units ]
 397             [
 398                 [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ]
 399                 [ + ] map-reduce
 400             ] bi* +
 401             "uniform-tuple-texture-units" set-word-prop
 402         ]
 403         [ nip "uniform-tuple-slots" set-word-prop ]
 404         [ define-uniform-tuple-methods ]
 405     } 3cleave ;
 406
 407 : true-subclasses ( class -- seq )
 408     [ subclasses ] keep [ = not ] curry filter ;
 409
 410 PRIVATE>
 411
 412 : define-uniform-tuple ( class superclass uniforms -- )
 413     (define-uniform-tuple) ; inline
 414
 415 SYNTAX: UNIFORM-TUPLE:
 416     parse-uniform-tuple-definition define-uniform-tuple ;
 417
 418 <PRIVATE
 419
 420 : bind-vertex-array ( vertex-array -- )
 421     handle>> glBindVertexArray ;
 422
 423 : bind-unnamed-output-attachments ( framebuffer attachments -- )
 424     [ gl-attachment ] with map
 425     dup length 1 =
 426     [ first glDrawBuffer ]
 427     [ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
 428
 429 : bind-named-output-attachments ( program-instance framebuffer attachments -- )
 430     rot '[ first _ swap output-index ] sort-with [ second ] map
 431     bind-unnamed-output-attachments ;
 432
 433 : bind-output-attachments ( program-instance framebuffer attachments -- )
 434     dup first sequence?
 435     [ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ;
 436
 437 GENERIC: bind-transform-feedback-output ( output -- )
 438
 439 M: buffer bind-transform-feedback-output
 440     [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip handle>> glBindBufferBase ; inline
 441
 442 M: buffer-range bind-transform-feedback-output
 443     [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip
 444     [ handle>> ] [ offset>> ] [ size>> ] tri glBindBufferRange ; inline
 445
 446 M: buffer-ptr bind-transform-feedback-output
 447     buffer-ptr>range bind-transform-feedback-output ; inline
 448
 449 : gl-feedback-primitive-mode ( primitive-mode -- gl-mode )
 450     {
 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 ] }
 458     } case ;
 459
 460 PRIVATE>
 461
 462 UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
 463 UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
 464
 465 TUPLE: render-set
 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 } ;
 474
 475 : <render-set> ( x quot-assoc -- render-set )
 476     render-set swap make-tuple ; inline
 477
 478 : 2<render-set> ( x y quot-assoc -- render-set )
 479     render-set swap 2make-tuple ; inline
 480
 481 : 3<render-set> ( x y z quot-assoc -- render-set )
 482     render-set swap 3make-tuple ; inline
 483
 484 : render ( render-set -- )
 485     {
 486         [ vertex-array>> program-instance>> handle>> glUseProgram ]
 487         [
 488             [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
 489             [ bind-uniform-textures ] [ bind-uniforms ] 2bi
 490         ]
 491         [
 492             framebuffer>>
 493             [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
 494             [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
 495         ]
 496         [
 497             [ vertex-array>> program-instance>> ]
 498             [ framebuffer>> ]
 499             [ output-attachments>> ] tri
 500             bind-output-attachments
 501         ]
 502         [ vertex-array>> bind-vertex-array ]
 503         [
 504             dup transform-feedback-output>> [
 505                 [ primitive-mode>> gl-feedback-primitive-mode glBeginTransformFeedback ]
 506                 [ bind-transform-feedback-output ] bi*
 507             ] [ drop ] if*
 508         ]
 509
 510         [
 511             [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
 512             [ render-vertex-indexes-instanced ]
 513             [ render-vertex-indexes ] if*
 514         ]
 515
 516         [ transform-feedback-output>> [ glEndTransformFeedback ] when ]
 517         [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]
 518     } cleave ; inline
 519