bind textures out of uniform structs and arrays

extra/gpu/render/render-tests.factor

@@ -0,0 +1,117 @@
+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
+

extra/gpu/render/render.factor

@@ -207,8 +207,8 @@ M: multi-index-elements render-vertex-indexes
     bi*
     GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
 
-: (bind-texture-unit) ( texture-unit texture -- )
+: (bind-texture-unit) ( texture texture-unit -- )
-    [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
+    swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
 
 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
     vertex-attribute name>>                 :> name
@@ -286,22 +286,46 @@ M: uniform-tuple bind-uniforms
 : 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 )
+: all-uniform-tuple-slots ( class -- slots )
-    uniform name>> reader-word :> value>>-word
+    dup "uniform-tuple-slots" word-prop 
-    { index swap value>>-word (bind-texture-unit) } >quotation ;
+    [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
 
-:: [bind-uniform-textures] ( superclass uniforms -- quot )
+DEFER: uniform-texture-accessors
-    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
 
-    {
+: uniform-type-texture-accessors ( uniform-type -- accessors )
-        2dup next-method
+    texture-uniform = [ { [ ] } ] [ { } ] if ;
-        nip texture-uniforms-cleave cleave
+
-    } >quotation ;
+: 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]
 
@@ -342,7 +366,7 @@ 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 +
@@ -391,10 +415,6 @@ DEFER: [bind-uniform-tuple]
     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
     [
@@ -444,8 +464,9 @@ TR: hyphens>underscores "-" "_" ;
 
 : define-uniform-tuple-methods ( class superclass uniforms -- )
     [
-        [ \ bind-uniform-textures create-method-in ] 2dip
+        2drop
-        [bind-uniform-textures] define
+        [ \ bind-uniform-textures create-method-in ]
+        [ [bind-uniform-textures] ] bi define
     ] [
         [ \ bind-uniforms create-method-in ] 2dip
         [bind-uniforms] define
@@ -498,22 +519,21 @@ padding-no [ 0 ] initialize
 : (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 -- )
@@ -540,8 +560,7 @@ SYNTAX: VERTEX-STRUCT:
     scan scan-word define-vertex-struct ;
 
 : define-uniform-tuple ( class superclass uniforms -- )
-    [ (define-uniform-tuple) ]
+    (define-uniform-tuple) ; inline
-    [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ;
 
 SYNTAX: UNIFORM-TUPLE:
     parse-uniform-tuple-definition define-uniform-tuple ;