--- /dev/null
+USING: accessors combinators gpu.render gpu.render.private kernel sequences tools.test ;
+IN: gpu.render.tests
+
+UNIFORM-TUPLE: two-textures
+ { "argyle" texture-uniform f }
+ { "thread-count" float-uniform f }
+ { "tweed" texture-uniform f } ;
+
+UNIFORM-TUPLE: inherited-textures < two-textures
+ { "paisley" texture-uniform f } ;
+
+UNIFORM-TUPLE: array-of-textures < two-textures
+ { "plaids" texture-uniform 4 } ;
+
+UNIFORM-TUPLE: struct-containing-texture
+ { "threads" two-textures f } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-texture
+ { "threads" inherited-textures 3 } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-array-of-texture
+ { "threads" array-of-textures 2 } ;
+
+[ 1 ] [ texture-uniform uniform-type-texture-units ] unit-test
+[ 0 ] [ float-uniform uniform-type-texture-units ] unit-test
+[ 2 ] [ two-textures uniform-type-texture-units ] unit-test
+[ 3 ] [ inherited-textures uniform-type-texture-units ] unit-test
+[ 6 ] [ array-of-textures uniform-type-texture-units ] unit-test
+[ 2 ] [ struct-containing-texture uniform-type-texture-units ] unit-test
+[ 9 ] [ array-of-struct-containing-texture uniform-type-texture-units ] unit-test
+[ 12 ] [ array-of-struct-containing-array-of-texture uniform-type-texture-units ] unit-test
+
+[ { [ ] } ] [ texture-uniform f uniform-texture-accessors ] unit-test
+
+[ { } ] [ float-uniform f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] } ] [ two-textures f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] [ paisley>> ] } ]
+[ inherited-textures f uniform-texture-accessors ] unit-test
+
+[ {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+} ] [ array-of-textures f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ argyle>> ]
+ [ tweed>> ]
+ } ]
+} ] [ struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ 0 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ [ 1 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ [ 2 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ } ]
+} ] [ array-of-struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ 0 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+ } ]
+ [ 1 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+ } ]
+ } ]
+} ] [ array-of-struct-containing-array-of-texture f uniform-texture-accessors ] unit-test
+
+[ [
+ nip {
+ [ argyle>> 0 (bind-texture-unit) ]
+ [ tweed>> 1 (bind-texture-unit) ]
+ [ plaids>> {
+ [ 0 swap nth 2 (bind-texture-unit) ]
+ [ 1 swap nth 3 (bind-texture-unit) ]
+ [ 2 swap nth 4 (bind-texture-unit) ]
+ [ 3 swap nth 5 (bind-texture-unit) ]
+ } cleave ]
+ } cleave
+] ] [ array-of-textures [bind-uniform-textures] ] unit-test
+
bi*
GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
-: (bind-texture-unit) ( texture-unit texture -- )
- [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
+: (bind-texture-unit) ( texture texture-unit -- )
+ swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
vertex-attribute name>> :> name
: uniform-type-texture-units ( uniform-type -- units )
dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
-:: [bind-uniform-texture] ( uniform index -- quot )
- uniform name>> reader-word :> value>>-word
- { index swap value>>-word (bind-texture-unit) } >quotation ;
+: all-uniform-tuple-slots ( class -- slots )
+ dup "uniform-tuple-slots" word-prop
+ [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
-:: [bind-uniform-textures] ( superclass uniforms -- quot )
- superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
- superclass \ bind-uniform-textures method :> next-method
- uniforms
- [ uniform-type>> texture-uniform = ] filter
- [ first-texture-unit + [bind-uniform-texture] ] map-index
- :> texture-uniforms-cleave
+DEFER: uniform-texture-accessors
- {
- 2dup next-method
- nip texture-uniforms-cleave cleave
- } >quotation ;
+: uniform-type-texture-accessors ( uniform-type -- accessors )
+ texture-uniform = [ { [ ] } ] [ { } ] if ;
+
+: uniform-slot-texture-accessor ( uniform -- accessor )
+ [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi
+ dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ;
+
+: uniform-tuple-texture-accessors ( uniform-type -- accessors )
+ all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter
+ [ uniform-slot-texture-accessor ] map ;
+
+: uniform-texture-accessors ( uniform-type dim -- accessors )
+ [
+ dup uniform-type?
+ [ uniform-type-texture-accessors ]
+ [ uniform-tuple-texture-accessors ] if
+ ] [
+ 2dup swap empty? not and [
+ iota [
+ [ swap nth ] swap prefix
+ over length 1 = [ swap first append ] [ swap suffix ] if
+ ] with map
+ ] [ drop ] if
+ ] bi* ;
+
+: texture-accessor>cleave ( unit accessors -- unit' cleaves )
+ dup last sequence?
+ [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
+ [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
+
+: [bind-uniform-textures] ( class -- quot )
+ f uniform-texture-accessors
+ 0 swap [ texture-accessor>cleave ] map nip
+ \ nip swap \ cleave [ ] 3sequence ;
DEFER: [bind-uniform-tuple]
{ mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } }
{ mat4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv } }
- { texture-uniform { drop dim iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
+ { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
} at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
type uniform-type-texture-units dim * texture-unit +
type uniform-type-texture-units texture-unit +
pre-quot value-quot append ;
-: all-uniform-tuple-slots ( class -- slots )
- dup "uniform-tuple-slots" word-prop
- [ swap superclass all-uniform-tuple-slots append ] [ drop { } ] if* ;
-
:: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
dim
[
: define-uniform-tuple-methods ( class superclass uniforms -- )
[
- [ \ bind-uniform-textures create-method-in ] 2dip
- [bind-uniform-textures] define
+ 2drop
+ [ \ bind-uniform-textures create-method-in ]
+ [ [bind-uniform-textures] ] bi define
] [
[ \ bind-uniforms create-method-in ] 2dip
[bind-uniforms] define
: (define-uniform-tuple) ( class superclass uniforms -- )
{
[ [ uniform>slot ] map define-tuple-class ]
- [ define-uniform-tuple-methods ]
[
[ uniform-type-texture-units ]
- [ [ uniform-type>> uniform-type-texture-units ] [ + ] map-reduce ] bi* +
+ [
+ [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ]
+ [ + ] map-reduce
+ ] bi* +
"uniform-tuple-texture-units" set-word-prop
]
[ nip "uniform-tuple-slots" set-word-prop ]
+ [ define-uniform-tuple-methods ]
} 3cleave ;
: true-subclasses ( class -- seq )
[ subclasses ] keep [ = not ] curry filter ;
-: redefine-uniform-tuple-subclass-methods ( class -- )
- [ true-subclasses ] keep
- [ over "uniform-tuple-slots" word-prop (define-uniform-tuple) ] curry each ;
-
PRIVATE>
: define-vertex-format ( class vertex-attributes -- )
scan scan-word define-vertex-struct ;
: define-uniform-tuple ( class superclass uniforms -- )
- [ (define-uniform-tuple) ]
- [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ;
+ (define-uniform-tuple) ; inline
SYNTAX: UNIFORM-TUPLE:
parse-uniform-tuple-definition define-uniform-tuple ;