Merge branch 'master' into dcn

basis/alien/parser/parser.factor

@@ -1,18 +1,30 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces ;
+parser sequences splitting words fry locals lexer namespaces
+summary math ;
 IN: alien.parser
 
+: normalize-c-arg ( type name -- type' name' )
+    [ length ]
+    [
+        [ CHAR: * = ] trim-head
+        [ length - CHAR: * <array> append ] keep
+    ] bi ;
+
 : parse-arglist ( parameters return -- types effect )
-    [ 2 group unzip [ "," ?tail drop ] map ]
+    [
+        2 group [ first2 normalize-c-arg 2array ] map
+        unzip [ "," ?tail drop ] map
+    ]
     [ [ { } ] [ 1array ] if-void ]
     bi* <effect> ;
 
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: make-function ( return library function parameters -- word quot effect )
+:: make-function ( return! library function! parameters -- word quot effect )
+    return function normalize-c-arg function! return!
     function create-in dup reset-generic
     return library function
     parameters return parse-arglist [ function-quot ] dip ;

basis/cairo/ffi/ffi.factor

@@ -896,7 +896,7 @@ FUNCTION: cairo_status_t
 cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
 
 FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
 
 FUNCTION: cairo_status_t
 cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;

basis/math/bitwise/bitwise.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math sequences accessors
+USING: arrays assocs combinators combinators.smart fry kernel
-math.bits sequences.private words namespaces macros
+macros math math.bits sequences sequences.private words ;
-hints combinators fry io.binary combinators.smart ;
 IN: math.bitwise
 
 ! utilities
@@ -104,14 +103,6 @@ PRIVATE>
 : bit-count ( x -- n )
     dup 0 < [ bitnot ] when (bit-count) ; inline
 
-! Signed byte array to integer conversion
-: signed-le> ( bytes -- x )
-    [ le> ] [ length 8 * 1 - on-bits ] bi
-    2dup > [ bitnot bitor ] [ drop ] if ;
-
-: signed-be> ( bytes -- x )
-    <reversed> signed-le> ;
-
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 

basis/opengl/capabilities/capabilities-docs.factor

@@ -40,7 +40,13 @@ HELP: gl-extensions
 
 HELP: has-gl-extensions?
 { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
+{ $examples "Testing for framebuffer object and pixel buffer support:"
+    { $code <" {
+    { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
+    "GL_ARB_pixel_buffer_object"
+} has-gl-extensions? "> }
+} ;
 
 HELP: has-gl-version-or-extensions?
 { $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }

basis/opengl/capabilities/capabilities-tests.factor

@@ -0,0 +1,21 @@
+! (c)2009 Joe Groff bsd license
+USING: opengl.capabilities tools.test ;
+IN: opengl.capabilities.tests
+
+CONSTANT: test-extensions
+    {
+        "GL_ARB_vent_core_frogblast"
+        "GL_EXT_resonance_cascade"
+        "GL_EXT_slipgate"
+    }
+
+[ t ]
+[ "GL_ARB_vent_core_frogblast" test-extensions (has-extension?) ] unit-test
+
+[ f ]
+[ "GL_ARB_wallhack" test-extensions (has-extension?) ] unit-test
+
+[ t ] [
+    { "GL_EXT_dimensional_portal" "GL_EXT_slipgate" }
+    test-extensions (has-extension?)
+] unit-test

basis/opengl/capabilities/capabilities.factor

@@ -1,16 +1,19 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order fry ;
+continuations math.parser math arrays sets strings math.order fry ;
 IN: opengl.capabilities
 
 : (require-gl) ( thing require-quot make-error-quot -- )
     [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
 
+: (has-extension?) ( query-extension(s) available-extensions -- ? )
+    over string?  [ member? ] [ [ member? ] curry any? ] if ;
+
 : gl-extensions ( -- seq )
     GL_EXTENSIONS glGetString " " split ;
 : has-gl-extensions? ( extensions -- ? )
-    gl-extensions swap [ over member? ] all? nip ;
+    gl-extensions [ (has-extension?) ] curry all? ;
 : (make-gl-extensions-error) ( required-extensions -- )
     gl-extensions diff
     "Required OpenGL extensions not supported:\n" %

basis/x11/xlib/xlib.factor

@@ -477,7 +477,7 @@ C-STRUCT: XImage
     { "XImage-funcs" "f" } ;
 
 X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
 
 : XImage-size ( ximage -- size )
     [ XImage-height ] [ XImage-bytes_per_line ] bi * ;

core/io/binary/binary.factor

@@ -24,3 +24,10 @@ IN: io.binary
 : h>b/b ( h -- b1 b2 )
     [ mask-byte ]
     [ -8 shift mask-byte ] bi ;
+
+: signed-le> ( bytes -- x )
+    [ le> ] [ length 8 * 1 - 2^ 1 - ] bi
+    2dup > [ bitnot bitor ] [ drop ] if ;
+
+: signed-be> ( bytes -- x )
+    <reversed> signed-le> ;

extra/alien/cxx/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/cxx.factor

@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+    create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+    "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+    [ drop class-wrapper { } define-tuple-class ]
+    [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+    [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+    add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+    [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make           :> name'
+    effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+    types class-name "*" append suffix                  :> types'
+    effect in>> "," join                                :> args
+    class-name virtual [ "#" append ] unless current-vocab lookup                  :> class
+    SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+    name' types' effect' body define-c-marshalled
+    class generic create-method name' current-vocab lookup 1quotation define ;

extra/alien/cxx/parser/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/parser/parser.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+    scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+    scan scan-word function-types-effect ;

extra/alien/cxx/syntax/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/syntax/syntax-tests.factor

@@ -0,0 +1,113 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+    return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+RAW-C:
+class alpha {
+    public:
+    alpha(const char* s) {
+        str = s;
+    };
+    const char* render() {
+        return str;
+    };
+    virtual const char* chop() {
+        return str;
+    };
+    virtual int length() {
+        return strlen(str);
+    };
+    const char* str;
+};
+
+class beta : alpha {
+    public:
+    beta(const char* s) : alpha(s + 1) { };
+    const char* render() {
+        return str + 1;
+    };
+    virtual const char* chop() {
+        return str + 2;
+    };
+};
+;
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+    return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+    return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test

extra/alien/cxx/syntax/syntax.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+    parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+    parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+    parse-c++-method-definition t define-c++-method ;

extra/alien/inline/types/types.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types assocs combinators.short-circuit
 continuations effects fry kernel math memoize sequences
-splitting ;
+splitting strings peg.ebnf make ;
 IN: alien.inline.types
 
 : cify-type ( str -- str' )
@@ -21,6 +21,9 @@ IN: alien.inline.types
 : pointer-to-const? ( str -- ? )
     cify-type "const " head? ;
 
+: template-class? ( str -- ? )
+    [ CHAR: < = ] any? ;
+
 MEMO: resolved-primitives ( -- seq )
     primitive-types [ resolve-typedef ] map ;
 
@@ -57,3 +60,42 @@ MEMO: resolved-primitives ( -- seq )
         [ over pointer-to-primitive? [ ">" prepend ] when ]
         assoc-map unzip
     ] dip <effect> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig  = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+    factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+    [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+    [
+        [ name>> % ]
+        [ params>> [ params>string % ] when* ]
+        [ ptr>> [ "*" % ] when ]
+        tri
+    ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;

extra/alien/marshall/marshall-docs.factor

@@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller
     "for all types except pointers to non-const primitives."
 } ;
 
-HELP: pointer-unmarshaller
+HELP: class-unmarshaller
 { $values
     { "type" " a C type string" }
     { "quot" quotation }

extra/alien/marshall/marshall.factor

@@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong
 specialized-arrays.short specialized-arrays.uchar
 specialized-arrays.uint specialized-arrays.ulong
 specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays ;
+unix.utilities vocabs.parser words libc.private struct-arrays
+locals generalizations math ;
 IN: alien.marshall
 
 << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
@@ -19,6 +20,9 @@ filter [ define-primitive-marshallers ] each >>
 
 TUPLE: alien-wrapper { underlying alien } ;
 TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
 
 GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
 
@@ -27,6 +31,8 @@ M: struct-wrapper unmarshall-cast ;
 
 M: struct-wrapper dispose* underlying>> free ;
 
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
 : marshall-pointer ( obj -- alien )
     {
         { [ dup alien? ] [ ] }
@@ -269,33 +275,43 @@ ALIAS: marshall-void* marshall-pointer
 : ?malloc-byte-array ( c-type -- alien )
     dup alien? [ malloc-byte-array ] unless ;
 
-: struct-unmarshaller ( type -- quot )
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
-    current-vocab lookup [
+    type type-quot call current-vocab lookup [
-        dup superclasses [ \ struct-wrapper = ] any? [
+        dup superclasses superclass swap member?
-            '[ ?malloc-byte-array _ new swap >>underlying ]
+        [ def call ] [ drop clean call f ] if
-        ] [ drop [ ] ] if
+    ] [ clean call f ] if* ; inline
-    ] [ [ ] ] if* ;
 
-: pointer-unmarshaller ( type -- quot )
+: struct-unmarshaller ( type -- quot/f )
-    type-sans-pointer current-vocab lookup [
+    [ ] \ struct-wrapper
-        dup superclasses [ \ alien-wrapper = ] any? [
+    [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
-            '[ _ new swap >>underlying unmarshall-cast ]
+    [ ]
-        ] [ drop [ ] ] if
+    x-unmarshaller ;
-    ] [ [ ] ] if* ;
+
+: class-unmarshaller ( type -- quot/f )
+    [ type-sans-pointer "#" append ] \ class-wrapper
+    [ '[ _ new swap >>underlying ] ]
+    [ ]
+    x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+    {
+        { [ dup pointer? ] [ class-unmarshaller ] }
+        [ struct-unmarshaller ]
+    } cond ;
 
 : unmarshaller ( type -- quot )
-    factorize-type dup primitive-unmarshaller [ nip ] [
+    factorize-type {
-        dup pointer?
+        [ primitive-unmarshaller ]
-        [ pointer-unmarshaller ]
+        [ non-primitive-unmarshaller ]
-        [ struct-unmarshaller ] if
+        [ drop [ ] ]
-    ] if* ;
+    } 1|| ;
 
 : struct-field-unmarshaller ( type -- quot )
-    factorize-type dup struct-primitive-unmarshaller [ nip ] [
+    factorize-type {
-        dup pointer?
+        [ struct-primitive-unmarshaller ]
-        [ pointer-unmarshaller ]
+        [ non-primitive-unmarshaller ]
-        [ struct-unmarshaller ] if
+        [ drop [ ] ]
-    ] if* ;
+    } 1|| ;
 
 : out-arg-unmarshaller ( type -- quot )
     dup pointer-to-non-const-primitive?

extra/combinators/tuple/tuple-docs.factor

@@ -0,0 +1,43 @@
+! (c)2009 Joe Groff bsd license
+USING: assocs classes help.markup help.syntax kernel math
+quotations strings ;
+IN: combinators.tuple
+
+HELP: 2make-tuple
+{ $values
+    { "x" object } { "y" object } { "class" class } { "assoc" assoc }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: 3make-tuple
+{ $values
+    { "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: make-tuple
+{ $values
+    { "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: nmake-tuple
+{ $values
+    { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ;
+
+{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words
+
+ARTICLE: "combinators.tuple" "Tuple-constructing combinators"
+"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects."
+{ $subsection make-tuple }
+{ $subsection 2make-tuple }
+{ $subsection 3make-tuple }
+{ $subsection nmake-tuple }
+;
+
+ABOUT: "combinators.tuple"

extra/combinators/tuple/tuple.factor

@@ -0,0 +1,29 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs classes.tuple generalizations kernel
+locals quotations sequences ;
+IN: combinators.tuple
+
+<PRIVATE
+
+:: (tuple-slot-quot) ( slot assoc n -- quot )
+    slot name>> assoc at [
+        slot initial>> :> initial
+        { n ndrop initial } >quotation
+    ] unless* ;
+
+PRIVATE>
+
+MACRO:: nmake-tuple ( class assoc n -- )
+    class all-slots [ assoc n (tuple-slot-quot) ] map :> quots
+    class <wrapper> :> \class
+    { quots n ncleave \class boa } >quotation ;
+    
+: make-tuple ( x class assoc -- tuple )
+    1 nmake-tuple ; inline
+
+: 2make-tuple ( x y class assoc -- tuple )
+    2 nmake-tuple ; inline
+
+: 3make-tuple ( x y z class assoc -- tuple )
+    3 nmake-tuple ; inline
+

extra/constructors/constructors-tests.factor

@@ -29,58 +29,15 @@ CONSTRUCTOR: ct1 ( a -- obj )
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct2 ( a b -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct3 ( a b c -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct4 ( a b c d -- obj )
-    initialize-ct3
     [ 1 + ] change-a ;
 
 [ 1001 ] [ 1000 <ct1> a>> ] unit-test
 [ 2 ] [ 0 0 <ct2> a>> ] unit-test
-[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: rofl a b c ;
-CONSTRUCTOR: rofl ( b c a  -- obj ) ;
-
-[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
-
-
-TUPLE: default { a integer initial: 0 } ;
-
-CONSTRUCTOR: default ( -- obj ) ;
-
-[ 0 ] [ <default> a>> ] unit-test
-
-
-TUPLE: inherit1 a ;
-TUPLE: inherit2 < inherit1 a ;
-
-CONSTRUCTOR: inherit2 ( a -- obj ) ;
-
-[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
-
-
-TUPLE: inherit3 hp max-hp ;
-TUPLE: inherit4 < inherit3 ;
-TUPLE: inherit5 < inherit3 ;
-
-CONSTRUCTOR: inherit3 ( -- obj )
-    dup max-hp>> >>hp ;
-
-BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
-    10 >>max-hp ;
-
-[ 10 ] [ <inherit4> hp>> ] unit-test
-
-FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
-    5 >>hp
-    10 >>max-hp ;
-
-[ 5 ] [ <inherit5> hp>> ] unit-test

extra/constructors/constructors.factor

@@ -43,12 +43,7 @@ MACRO:: slots>constructor ( class slots -- quot )
     class def define-initializer
     class effect in>> '[ _ _ slots>constructor ] ;
 
-:: define-constructor ( constructor-word class effect def -- )
+:: define-constructor ( constructor-word class effect def reverse? -- )
-    constructor-word class effect def (define-constructor)
-    class lookup-initializer
-    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
-
-:: define-auto-constructor ( constructor-word class effect def reverse? -- )
     constructor-word class effect def (define-constructor)
     class superclasses [ lookup-initializer ] map sift
     reverse? [ reverse ] when
@@ -60,9 +55,6 @@ MACRO:: slots>constructor ( class slots -- quot )
 : parse-constructor ( -- class word effect def )
     scan-constructor complete-effect parse-definition ;
 
-SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
+SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
-SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
-SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
 
 "initializers" create-vocab drop

extra/gpu/demos/bunny/bunny.factor

@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
 USING: accessors alien.c-types arrays combinators combinators.short-circuit
 game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
 gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
@@ -52,22 +53,22 @@ VERTEX-FORMAT: bunny-vertex
 VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
 
 UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms
-    { "light_position" float-uniform 3 }
+    { "light-position" vec3-uniform  f }
-    { "color"          float-uniform 4 }
+    { "color"          vec4-uniform  f }
-    { "ambient"        float-uniform 4 }
+    { "ambient"        vec4-uniform  f }
-    { "diffuse"        float-uniform 4 }
+    { "diffuse"        vec4-uniform  f }
-    { "shininess"      float-uniform 1 } ;
+    { "shininess"      float-uniform f } ;
 
 UNIFORM-TUPLE: sobel-uniforms
-    { "texcoord_scale" float-uniform   2 }
+    { "texcoord-scale" vec2-uniform    f }
-    { "color_texture"  texture-uniform 1 }
+    { "color-texture"  texture-uniform f }
-    { "normal_texture" texture-uniform 1 }
+    { "normal-texture" texture-uniform f }
-    { "depth_texture"  texture-uniform 1 }
+    { "depth-texture"  texture-uniform f }
-    { "line_color"     float-uniform   4 } ; 
+    { "line-color"     vec4-uniform    f } ; 
 
 UNIFORM-TUPLE: loading-uniforms
-    { "texcoord_scale"  float-uniform   2 }
+    { "texcoord-scale"  vec2-uniform    f }
-    { "loading_texture" texture-uniform 1 } ;
+    { "loading-texture" texture-uniform f } ;
 
 : numbers ( str -- seq )
     " " split [ string>number ] map sift ;
@@ -229,16 +230,14 @@ BEFORE: bunny-world begin-world
             { depth-attachment 1.0 }
         } clear-framebuffer
     ] [
-        render-set new
+        {
-            triangles-mode >>primitive-mode
+            { "primitive-mode"     [ drop triangles-mode ] }
-            { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments
+            { "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] }
-            swap {
+            { "uniforms"           [ <bunny-uniforms> ] }
-                [ <bunny-uniforms> >>uniforms ]
+            { "vertex-array"       [ bunny>> vertex-array>> ] }
-                [ bunny>> vertex-array>> >>vertex-array ]
+            { "indexes"            [ bunny>> index-elements>> ] }
-                [ bunny>> index-elements>> >>indexes ]
+            { "framebuffer"        [ sobel>> framebuffer>> ] }
-                [ sobel>> framebuffer>> >>framebuffer ]
+        } <render-set> render
-            } cleave
-        render
     ] bi ;
 
 : <sobel-uniforms> ( sobel -- uniforms )
@@ -250,13 +249,12 @@ BEFORE: bunny-world begin-world
 : draw-sobel ( world -- )
     T{ depth-state { comparison f } } set-gpu-state*
 
-    render-set new
+    sobel>> {
-        triangle-strip-mode >>primitive-mode
+        { "primitive-mode" [ drop triangle-strip-mode ] }
-        T{ index-range f 0 4 } >>indexes
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
-        swap sobel>>
+        { "uniforms"       [ <sobel-uniforms> ] }
-        [ <sobel-uniforms> >>uniforms ]
+        { "vertex-array"   [ vertex-array>> ] }
-        [ vertex-array>> >>vertex-array ] bi
+    } <render-set> render ;
-    render ;
 
 : draw-sobeled-bunny ( world -- )
     [ draw-bunny ] [ draw-sobel ] bi ;
@@ -264,13 +262,12 @@ BEFORE: bunny-world begin-world
 : draw-loading ( world -- )
     T{ depth-state { comparison f } } set-gpu-state*
 
-    render-set new
+    loading>> {
-        triangle-strip-mode >>primitive-mode
+        { "primitive-mode" [ drop triangle-strip-mode ] }
-        T{ index-range f 0 4 } >>indexes
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
-        swap loading>>
+        { "uniforms"       [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] }
-        [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ]
+        { "vertex-array"   [ vertex-array>> ] }
-        [ vertex-array>> >>vertex-array ] bi
+    } <render-set> render ;
-    render ;
 
 M: bunny-world draw-world*
     dup bunny>>

extra/gpu/demos/raytrace/raytrace.factor

@@ -1,7 +1,7 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays game-loop game-worlds generalizations
+USING: accessors arrays combinators.tuple game-loop game-worlds
-gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel
+generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd
-literals math math.matrices math.order math.vectors
+kernel literals math math.matrices math.order math.vectors
 method-chains sequences ui ui.gadgets ui.gadgets.worlds
 ui.pixel-formats ;
 IN: gpu.demos.raytrace
@@ -11,31 +11,21 @@ GLSL-SHADER-FILE: raytrace-fragment-shader fragment-shader "raytrace.f.glsl"
 GLSL-PROGRAM: raytrace-program
     raytrace-vertex-shader raytrace-fragment-shader ;
 
+UNIFORM-TUPLE: sphere-uniforms
+    { "center" vec3-uniform  f }
+    { "radius" float-uniform f }
+    { "color"  vec4-uniform  f } ;
+
 UNIFORM-TUPLE: raytrace-uniforms
-    { "mv_inv_matrix" float-uniform { 4 4 } }
+    { "mv-inv-matrix"    mat4-uniform f }
-    { "fov" float-uniform 2 }
+    { "fov"              vec2-uniform f }
-
-    { "spheres[0].center" float-uniform 3 }
-    { "spheres[0].radius" float-uniform 1 }
-    { "spheres[0].color"  float-uniform 4 }
-
-    { "spheres[1].center" float-uniform 3 }
-    { "spheres[1].radius" float-uniform 1 }
-    { "spheres[1].color"  float-uniform 4 }
-
-    { "spheres[2].center" float-uniform 3 }
-    { "spheres[2].radius" float-uniform 1 }
-    { "spheres[2].color"  float-uniform 4 }
-
-    { "spheres[3].center" float-uniform 3 }
-    { "spheres[3].radius" float-uniform 1 }
-    { "spheres[3].color"  float-uniform 4 }
     
-    { "floor_height"   float-uniform 1 }
+    { "spheres"          sphere-uniforms 4 }
-    { "floor_color[0]" float-uniform 4 }
+
-    { "floor_color[1]" float-uniform 4 }
+    { "floor-height"     float-uniform f }
-    { "background_color" float-uniform 4 }
+    { "floor-color"      vec4-uniform 2 }
-    { "light_direction" float-uniform 3 } ;
+    { "background-color" vec4-uniform f }
+    { "light-direction"  vec3-uniform f } ;
 
 CONSTANT: reflection-color { 1.0 0.0 1.0 0.0 }
 
@@ -64,12 +54,10 @@ TUPLE: raytrace-world < wasd-world
     [ fov>> ]
     [
         spheres>>
-        [ [ sphere-center ] [ radius>> ] [ color>> ] tri 3array ] map
+        [ [ sphere-center ] [ radius>> ] [ color>> ] tri sphere-uniforms boa ] map
-        first4 [ first3 ] 4 napply
     ] tri
     -30.0 ! floor_height
-    { 1.0 0.0 0.0 1.0 } ! floor_color[0]
+    { { 1.0 0.0 0.0 1.0 } { 1.0 1.0 1.0 1.0 } } ! floor_color
-    { 1.0 1.0 1.0 1.0 } ! floor_color[1]
     { 0.15 0.15 1.0 1.0 } ! background_color
     { 0.0 -1.0 -0.1 } ! light_direction
     raytrace-uniforms boa ;
@@ -97,13 +85,12 @@ AFTER: raytrace-world tick*
     spheres>> [ tick-sphere ] each ;
 
 M: raytrace-world draw-world*
-    render-set new
+    {
-        triangle-strip-mode >>primitive-mode
+        { "primitive-mode" [ drop triangle-strip-mode    ] }
-        T{ index-range f 0 4 } >>indexes
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
-        swap
+        { "uniforms"       [ <sphere-uniforms>           ] }
-        [ <sphere-uniforms> >>uniforms ]
+        { "vertex-array"   [ vertex-array>>              ] }
-        [ vertex-array>> >>vertex-array ] bi
+    } <render-set> render ;
-    render ;
 
 M: raytrace-world pref-dim* drop { 1024 768 } ;
 M: raytrace-world tick-length drop 1000 30 /i ;

extra/gpu/render/render-docs.factor

@@ -47,7 +47,7 @@ HELP: UNIFORM-TUPLE:
     { "slot" uniform-type dimension }
     ...
     { "slot" uniform-type dimension } ; "> }
-{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " defines the vector or matrix dimensions; for example, a slot " { $snippet "{ \"foo\" float-uniform { 2 2 } }" } " will define a slot " { $snippet "foo" } " as a 2x2 matrix of floats."
+{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " specifies an array length if not " { $link f } "."
 $nl
 "Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
 { $list
@@ -55,8 +55,26 @@ $nl
 { { $link float-uniform } "s take their values from Factor " { $link float } "s." }
 { { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
 { { $link texture-uniform } "s take their values from " { $link texture } " objects." }
-{ "Vector uniforms are passed as Factor " { $link sequence } "s of the corresponding component type." }
+{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type."
-{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } }
+    { $list
+    { "Float vector types: " { $link vec2-uniform } ", " { $link vec3-uniform } ", " { $link vec4-uniform } }
+    { "Integer vector types: " { $link ivec2-uniform } ", " { $link ivec3-uniform } ", " { $link ivec4-uniform } }
+    { "Unsigned integer vector types: " { $link uvec2-uniform } ", " { $link uvec3-uniform } ", " { $link uvec4-uniform } }
+    { "Boolean vector types: " { $link bvec2-uniform } ", " { $link bvec3-uniform } ", " { $link bvec4-uniform } }
+    }
+}
+{ "Matrix uniforms take their values from row-major Factor " { $link sequence } "s of sequences of floats. Matrix types are:" 
+    { $list
+    { { $link mat2-uniform } ", " { $link mat2x3-uniform } ", " { $link mat2x4-uniform } }
+    { { $link mat3x2-uniform } ", " { $link mat3-uniform } ", " { $link mat3x4-uniform } }
+    { { $link mat4x2-uniform } ", " { $link mat4x3-uniform } ", " { $link mat4-uniform } }
+    }
+"Rectangular matrix type names are column x row."
+}
+{ "Uniform slots can also be defined as other " { $snippet "uniform-tuple" } " types to bind uniform structures. The uniform structure will take its value from the slots of a tuple of the given type." }
+{ "Array uniforms are passed as Factor sequences of the corresponding value type above." }
+}
+$nl
 "A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors."
 } ;
 
@@ -73,7 +91,7 @@ HELP: VERTEX-STRUCT:
 { $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
 
 HELP: bool-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "bool" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ;
 
 HELP: buffer>vertex-array
 { $values
@@ -84,6 +102,15 @@ HELP: buffer>vertex-array
 
 { vertex-array <vertex-array> buffer>vertex-array } related-words
 
+HELP: bvec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ;
+
+HELP: bvec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component boolean vector uniform parameter." } ;
+
+HELP: bvec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component boolean vector uniform parameter." } ;
+
 HELP: define-uniform-tuple
 { $values
     { "class" class } { "superclass" class } { "uniforms" sequence }
@@ -103,9 +130,7 @@ HELP: define-vertex-struct
 { $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;
 
 HELP: float-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ;
-
-{ bool-uniform int-uniform float-uniform texture-uniform } related-words
 
 { index-elements index-range multi-index-elements multi-index-range } related-words
 
@@ -130,7 +155,7 @@ HELP: index-type
 { index-type ubyte-indexes ushort-indexes uint-indexes } related-words
 
 HELP: int-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "int" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a signed integer uniform parameter." } ;
 
 HELP: invalid-uniform-type
 { $values
@@ -138,6 +163,15 @@ HELP: invalid-uniform-type
 }
 { $description "Throws an error indicating that a slot of a " { $link uniform-tuple } " has been declared to have an invalid type." } ;
 
+HELP: ivec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component integer vector uniform parameter." } ;
+
+HELP: ivec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component integer vector uniform parameter." } ;
+
+HELP: ivec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component integer vector uniform parameter." } ;
+
 HELP: lines-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a line from each pair of indexed vertex array elements." } ;
 
@@ -147,6 +181,33 @@ HELP: line-loop-mode
 HELP: line-strip-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected strip of lines from each consecutive pair of indexed vertex array elements." } ;
 
+HELP: mat2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2x2 square float matrix uniform parameter." } ;
+
+HELP: mat2x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat2x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat3x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3x3 square float matrix uniform parameter." } ;
+
+HELP: mat3x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat4x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat4x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4x4 square float matrix uniform parameter." } ;
+
 HELP: multi-index-elements
 { $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple arrays of indexes in CPU or GPU memory."
 { $list
@@ -200,7 +261,7 @@ HELP: render-set
 { render render-set } related-words
 
 HELP: texture-uniform
-{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a texture. The dimension of the corresponding " { $link uniform } " slot must be " { $snippet "1" } "." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a texture uniform parameter." } ;
 
 HELP: triangle-fan-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a fan of triangles using the first indexed vertex array element and every subsequent consecutive pair of elements." } ;
@@ -218,7 +279,7 @@ HELP: uint-indexes
 { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of four-byte unsigned int indexes." } ;
 
 HELP: uint-uniform
-{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a scalar or vector of unsigned integers." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to an unsigned integer uniform parameter." } ;
 
 HELP: uniform
 { $class-description "Values of this tuple type are passed to " { $link define-uniform-tuple } " to define a new " { $link uniform-tuple } " type." } ;
@@ -229,13 +290,29 @@ HELP: uniform-tuple
 HELP: uniform-type
 { $class-description { $snippet "uniform-type" } " values are used as part of a " { $link POSTPONE: UNIFORM-TUPLE: } " definition to define the types of uniform slots." } ;
 
-{ uniform-type bool-uniform int-uniform float-uniform texture-uniform uint-uniform } related-words
-
 HELP: ushort-indexes
 { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of two-byte unsigned short indexes." } ;
 
 { index-type ubyte-indexes ushort-indexes uint-indexes } related-words
 
+HELP: uvec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component unsigned integer vector uniform parameter." } ;
+
+HELP: uvec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component unsigned integer vector uniform parameter." } ;
+
+HELP: uvec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component unsigned integer vector uniform parameter." } ;
+
+HELP: vec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component float vector uniform parameter." } ;
+
+HELP: vec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component float vector uniform parameter." } ;
+
+HELP: vec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component float vector uniform parameter." } ;
+
 HELP: vertex-array
 { $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <vertex-array> } " or " { $link buffer>vertex-array } " words." } ;
 

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

@@ -1,19 +1,19 @@
 ! (c)2009 Joe Groff bsd license
 USING: accessors alien alien.c-types alien.structs arrays
-assocs classes.mixin classes.parser classes.singleton
+assocs classes classes.mixin classes.parser classes.singleton
-classes.tuple classes.tuple.private combinators destructors fry
+classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
 generic generic.parser gpu gpu.buffers gpu.framebuffers
 gpu.framebuffers.private gpu.shaders gpu.state gpu.textures
 gpu.textures.private half-floats images kernel lexer locals
 math math.order math.parser namespaces opengl opengl.gl parser
 quotations sequences slots sorting specialized-arrays.alien
 specialized-arrays.float specialized-arrays.int
-specialized-arrays.uint strings ui.gadgets.worlds variants
+specialized-arrays.uint strings tr ui.gadgets.worlds variants
 vocabs.parser words ;
 IN: gpu.render
 
 UNION: ?string string POSTPONE: f ;
-UNION: uniform-dim integer sequence ;
+UNION: ?integer integer POSTPONE: f ;
 
 TUPLE: vertex-attribute
     { name            ?string        read-only initial: f }
@@ -23,15 +23,44 @@ TUPLE: vertex-attribute
 
 VARIANT: uniform-type
     bool-uniform
+    bvec2-uniform
+    bvec3-uniform
+    bvec4-uniform
     uint-uniform
+    uvec2-uniform
+    uvec3-uniform
+    uvec4-uniform
     int-uniform
+    ivec2-uniform
+    ivec3-uniform
+    ivec4-uniform
     float-uniform
+    vec2-uniform
+    vec3-uniform
+    vec4-uniform
+
+    mat2-uniform
+    mat2x3-uniform
+    mat2x4-uniform
+
+    mat3x2-uniform
+    mat3-uniform
+    mat3x4-uniform
+
+    mat4x2-uniform
+    mat4x3-uniform
+    mat4-uniform
+
     texture-uniform ;
 
+ALIAS: mat2x2-uniform mat2-uniform
+ALIAS: mat3x3-uniform mat3-uniform
+ALIAS: mat4x4-uniform mat4-uniform
+
 TUPLE: uniform
-    { name         string       read-only initial: "" }
+    { name         string   read-only initial: "" }
-    { uniform-type uniform-type read-only initial: float-uniform }
+    { uniform-type class    read-only initial: float-uniform }
-    { dim          uniform-dim  read-only initial: 4 } ;
+    { dim          ?integer read-only initial: f } ;
 
 VARIANT: index-type
     ubyte-indexes
@@ -50,8 +79,6 @@ TUPLE: multi-index-range
 
 C: <multi-index-range> multi-index-range
 
-UNION: ?integer integer POSTPONE: f ;
-
 TUPLE: index-elements
     { ptr gpu-data-ptr read-only }
     { count integer read-only }
@@ -180,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
@@ -242,96 +269,204 @@ M: uniform-tuple bind-uniforms
     2drop ;
 
 : uniform-slot-type ( uniform -- type )
-    dup dim>> 1 = [
+    dup dim>> [ drop sequence ] [
         uniform-type>> {
             { bool-uniform    [ boolean ] }
             { uint-uniform    [ integer ] }
             { int-uniform     [ integer ] }
             { float-uniform   [ float   ] }
             { texture-uniform [ texture ] }
+            [ drop sequence ]
         } case
-    ] [ drop sequence ] if ;
+    ] if ;
 
 : uniform>slot ( uniform -- slot )
     [ name>> ] [ uniform-slot-type ] bi 2array ;
 
-:: [bind-uniform-texture] ( uniform index -- quot )
+: uniform-type-texture-units ( uniform-type -- units )
-    uniform name>> reader-word :> value>>-word
+    dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
-    { index swap value>>-word (bind-texture-unit) } >quotation ;
 
-:: [bind-uniform-textures] ( superclass uniforms -- quot )
+: all-uniform-tuple-slots ( class -- slots )
-    superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
+    dup "uniform-tuple-slots" word-prop 
-    superclass \ bind-uniform-textures method :> next-method
+    [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
-    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 ;
 
-:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
+: uniform-type-texture-accessors ( uniform-type -- accessors )
-    uniform name>> :> name
+    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]
+
+:: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
     { name uniform-index } >quotation :> index-quot
-    uniform name>> reader-word 1quotation :> value>>-quot
     { index-quot value>>-quot bi* } >quotation :> pre-quot
 
-    uniform [ uniform-type>> ] [ dim>> ] bi 2array H{
+    type H{
-        { { bool-uniform  1 } [ >c-bool glUniform1i  ] }
+        { bool-uniform  { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv  } }
-        { { int-uniform   1 } [ glUniform1i  ] }
+        { int-uniform   { dim swap >int-array   glUniform1iv  } }
-        { { uint-uniform  1 } [ glUniform1ui ] }
+        { uint-uniform  { dim swap >uint-array  glUniform1uiv } }
-        { { float-uniform 1 } [ glUniform1f  ] }
+        { float-uniform { dim swap >float-array glUniform1fv  } }
 
-        { { bool-uniform  2 } [ [ >c-bool ] map first2 glUniform2i  ] }
+        { bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv  } }
-        { { int-uniform   2 } [ first2 glUniform2i  ] }
+        { ivec2-uniform { dim swap int-array{ }   concat-as glUniform2i  } }
-        { { uint-uniform  2 } [ first2 glUniform2ui ] }
+        { uvec2-uniform { dim swap uint-array{ }  concat-as glUniform2ui } }
-        { { float-uniform 2 } [ first2 glUniform2f  ] }
+        { vec2-uniform  { dim swap float-array{ } concat-as glUniform2f  } }
 
-        { { bool-uniform  3 } [ [ >c-bool ] map first3 glUniform3i  ] }
+        { bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv  } }
-        { { int-uniform   3 } [ first3 glUniform3i  ] }
+        { ivec3-uniform { dim swap int-array{ }   concat-as glUniform3i  } }
-        { { uint-uniform  3 } [ first3 glUniform3ui ] }
+        { uvec3-uniform { dim swap uint-array{ }  concat-as glUniform3ui } }
-        { { float-uniform 3 } [ first3 glUniform3f  ] }
+        { vec3-uniform  { dim swap float-array{ } concat-as glUniform3f  } }
 
-        { { bool-uniform  4 } [ [ >c-bool ] map first4 glUniform4i  ] }
+        { bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv  } }
-        { { int-uniform   4 } [ first4 glUniform4i  ] }
+        { ivec4-uniform { dim swap int-array{ }   concat-as glUniform4iv  } }
-        { { uint-uniform  4 } [ first4 glUniform4ui ] }
+        { uvec4-uniform { dim swap uint-array{ }  concat-as glUniform4uiv } }
-        { { float-uniform 4 } [ first4 glUniform4f  ] }
+        { vec4-uniform  { dim swap float-array{ } concat-as glUniform4fv  } }
 
-        { { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv   ] }
+        { mat2-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv   } }
-        { { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] }
+        { mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } }
-        { { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] }
+        { mat2x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x4fv } }
+                                                                 
+        { mat3x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x2fv } }
+        { mat3-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3fv   } }
+        { mat3x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x4fv } }
+                                                                  
+        { mat4x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x2fv } }
+        { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } }
+        { mat4-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv   } }
 
-        { { float-uniform { 2 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x2fv ] }
+        { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
-        { { float-uniform { 3 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3fv   ] }
-        { { float-uniform { 4 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x4fv ] }
-
-        { { float-uniform { 2 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x2fv ] }
-        { { float-uniform { 3 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x3fv ] }
-        { { float-uniform { 4 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4fv   ] }
-
-        { { texture-uniform 1 } { drop texture-unit glUniform1i } }
     } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
 
-    uniform uniform-type>> texture-uniform =
+    type uniform-type-texture-units dim * texture-unit +
-    [ texture-unit 1 + ] [ texture-unit ] if
     pre-quot value-quot append ;
 
+:: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot )
+    { name uniform-index } >quotation :> index-quot
+    { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+    type H{
+        { bool-uniform  [ >c-bool glUniform1i  ] }
+        { int-uniform   [ glUniform1i  ] }
+        { uint-uniform  [ glUniform1ui ] }
+        { float-uniform [ glUniform1f  ] }
+
+        { bvec2-uniform [ [ >c-bool ] map first2 glUniform2i  ] }
+        { ivec2-uniform [ first2 glUniform2i  ] }
+        { uvec2-uniform [ first2 glUniform2ui ] }
+        { vec2-uniform  [ first2 glUniform2f  ] }
+
+        { bvec3-uniform [ [ >c-bool ] map first3 glUniform3i  ] }
+        { ivec3-uniform [ first3 glUniform3i  ] }
+        { uvec3-uniform [ first3 glUniform3ui ] }
+        { vec3-uniform  [ first3 glUniform3f  ] }
+
+        { bvec4-uniform [ [ >c-bool ] map first4 glUniform4i  ] }
+        { ivec4-uniform [ first4 glUniform4i  ] }
+        { uvec4-uniform [ first4 glUniform4ui ] }
+        { vec4-uniform  [ first4 glUniform4f  ] }
+
+        { mat2-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2fv   ] }
+        { mat2x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x3fv ] }
+        { mat2x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x4fv ] }
+
+        { mat3x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x2fv ] }
+        { mat3-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3fv   ] }
+        { mat3x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x4fv ] }
+
+        { mat4x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x2fv ] }
+        { mat4x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x3fv ] }
+        { mat4-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4fv   ] }
+
+        { texture-uniform { drop texture-unit glUniform1i } }
+    } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+    type uniform-type-texture-units texture-unit +
+    pre-quot value-quot append ;
+
+:: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
+    dim
+    [
+        iota
+        [ [ [ swap nth ] swap prefix ] map ]
+        [ [ number>string name "[" append "]." surround ] map ] bi
+    ] [
+        { [ ] }
+        name "." append 1array
+    ] if* :> name-prefixes :> quot-prefixes
+    type all-uniform-tuple-slots :> uniforms
+
+    texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
+        uniforms name-prefix [bind-uniform-tuple]
+        quot-prefix prepend
+    ] 2map :> value-cleave :> texture-unit'
+
+    texture-unit' 
+    value>>-quot { value-cleave 2cleave } append ;
+
+TR: hyphens>underscores "-" "_" ;
+
+:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
+    prefix uniform name>> append hyphens>underscores :> name
+    uniform uniform-type>> :> type
+    uniform dim>> :> dim
+    uniform name>> reader-word 1quotation :> value>>-quot
+
+    value>>-quot type texture-unit name {
+        { [ type uniform-type? dim     and ] [ dim [bind-uniform-array] ] }
+        { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] }
+        [ dim [bind-uniform-struct] ]
+    } cond ;
+
+:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
+    texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
+
+    texture-unit'
+    { uniforms-cleave 2cleave } >quotation ;
+
 :: [bind-uniforms] ( superclass uniforms -- quot )
     superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
     superclass \ bind-uniforms method :> next-method
-    first-texture-unit uniforms [ [bind-uniform] ] map nip :> uniforms-cleave
+    first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
-    
+
-    {
+    { 2dup next-method } bind-quot [ ] append-as ;
-        2dup next-method
-        uniforms-cleave 2cleave
-    } >quotation ;
 
 : 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
@@ -384,22 +519,21 @@ padding-no [ 0 ] initialize
 : (define-uniform-tuple) ( class superclass uniforms -- )
     {
         [ [ uniform>slot ] map define-tuple-class ]
-        [ define-uniform-tuple-methods ]
         [
-            [ "uniform-tuple-texture-units" word-prop 0 or ]
+            [ uniform-type-texture-units ]
-            [ [ uniform-type>> texture-uniform = ] filter length ] 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 -- )
@@ -426,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 ;
@@ -474,13 +607,22 @@ M: vertex-array dispose
 PRIVATE>
 
 TUPLE: render-set
-    { primitive-mode primitive-mode }
+    { primitive-mode primitive-mode read-only }
-    { vertex-array vertex-array }
+    { vertex-array vertex-array read-only }
-    { uniforms uniform-tuple }
+    { uniforms uniform-tuple read-only }
-    { indexes vertex-indexes initial: T{ index-range } } 
+    { indexes vertex-indexes initial: T{ index-range } read-only } 
-    { instances ?integer initial: f }
+    { instances ?integer initial: f read-only }
-    { framebuffer any-framebuffer initial: system-framebuffer }
+    { framebuffer any-framebuffer initial: system-framebuffer read-only }
-    { output-attachments sequence initial: { default-attachment } } ;
+    { output-attachments sequence initial: { default-attachment } read-only } ;
+
+: <render-set> ( x quot-assoc -- render-set )
+    render-set swap make-tuple ; inline
+
+: 2<render-set> ( x y quot-assoc -- render-set )
+    render-set swap 2make-tuple ; inline
+
+: 3<render-set> ( x y z quot-assoc -- render-set )
+    render-set swap 3make-tuple ; inline
 
 : render ( render-set -- )
     {

extra/gpu/util/wasd/wasd.factor

@@ -8,8 +8,8 @@ specialized-arrays.float ui ui.gadgets.worlds ;
 IN: gpu.util.wasd
 
 UNIFORM-TUPLE: mvp-uniforms
-    { "mv_matrix"  float-uniform   { 4 4 } }
+    { "mv_matrix"  mat4-uniform f }
-    { "p_matrix"   float-uniform   { 4 4 } } ;
+    { "p_matrix"   mat4-uniform f } ;
 
 CONSTANT: -pi/2 $[ pi -2.0 / ]
 CONSTANT:  pi/2 $[ pi  2.0 / ]