extra/gpu/render/render.factor

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