Merge branch 'master' into dcn
Slava Pestov
commit
548e575ad9
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
math.bits sequences.private words namespaces macros
|
||||
hints combinators fry io.binary combinators.smart ;
|
||||
USING: arrays assocs combinators combinators.smart fry kernel
|
||||
macros math math.bits sequences sequences.private words ;
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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" %
|
||||
|
|
|
|||
|
|
@ -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 * ;
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
current-vocab lookup [
|
||||
dup superclasses [ \ struct-wrapper = ] any? [
|
||||
'[ ?malloc-byte-array _ new swap >>underlying ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
|
||||
type type-quot call current-vocab lookup [
|
||||
dup superclasses superclass swap member?
|
||||
[ def call ] [ drop clean call f ] if
|
||||
] [ clean call f ] if* ; inline
|
||||
|
||||
: pointer-unmarshaller ( type -- quot )
|
||||
type-sans-pointer current-vocab lookup [
|
||||
dup superclasses [ \ alien-wrapper = ] any? [
|
||||
'[ _ new swap >>underlying unmarshall-cast ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
: struct-unmarshaller ( type -- quot/f )
|
||||
[ ] \ struct-wrapper
|
||||
[ '[ ?malloc-byte-array _ new swap >>underlying ] ]
|
||||
[ ]
|
||||
x-unmarshaller ;
|
||||
|
||||
: 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 ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
factorize-type {
|
||||
[ primitive-unmarshaller ]
|
||||
[ non-primitive-unmarshaller ]
|
||||
[ drop [ ] ]
|
||||
} 1|| ;
|
||||
|
||||
: struct-field-unmarshaller ( type -- quot )
|
||||
factorize-type dup struct-primitive-unmarshaller [ nip ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
factorize-type {
|
||||
[ struct-primitive-unmarshaller ]
|
||||
[ non-primitive-unmarshaller ]
|
||||
[ drop [ ] ]
|
||||
} 1|| ;
|
||||
|
||||
: out-arg-unmarshaller ( type -- quot )
|
||||
dup pointer-to-non-const-primitive?
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 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
|
||||
[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
|
||||
[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
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? -- )
|
||||
:: define-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: 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 ;
|
||||
SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
|
||||
|
||||
"initializers" create-vocab drop
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
{ "color" float-uniform 4 }
|
||||
{ "ambient" float-uniform 4 }
|
||||
{ "diffuse" float-uniform 4 }
|
||||
{ "shininess" float-uniform 1 } ;
|
||||
{ "light-position" vec3-uniform f }
|
||||
{ "color" vec4-uniform f }
|
||||
{ "ambient" vec4-uniform f }
|
||||
{ "diffuse" vec4-uniform f }
|
||||
{ "shininess" float-uniform f } ;
|
||||
|
||||
UNIFORM-TUPLE: sobel-uniforms
|
||||
{ "texcoord_scale" float-uniform 2 }
|
||||
{ "color_texture" texture-uniform 1 }
|
||||
{ "normal_texture" texture-uniform 1 }
|
||||
{ "depth_texture" texture-uniform 1 }
|
||||
{ "line_color" float-uniform 4 } ;
|
||||
{ "texcoord-scale" vec2-uniform f }
|
||||
{ "color-texture" texture-uniform f }
|
||||
{ "normal-texture" texture-uniform f }
|
||||
{ "depth-texture" texture-uniform f }
|
||||
{ "line-color" vec4-uniform f } ;
|
||||
|
||||
UNIFORM-TUPLE: loading-uniforms
|
||||
{ "texcoord_scale" float-uniform 2 }
|
||||
{ "loading_texture" texture-uniform 1 } ;
|
||||
{ "texcoord-scale" vec2-uniform f }
|
||||
{ "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
|
||||
{ T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments
|
||||
swap {
|
||||
[ <bunny-uniforms> >>uniforms ]
|
||||
[ bunny>> vertex-array>> >>vertex-array ]
|
||||
[ bunny>> index-elements>> >>indexes ]
|
||||
[ sobel>> framebuffer>> >>framebuffer ]
|
||||
} cleave
|
||||
render
|
||||
{
|
||||
{ "primitive-mode" [ drop triangles-mode ] }
|
||||
{ "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] }
|
||||
{ "uniforms" [ <bunny-uniforms> ] }
|
||||
{ "vertex-array" [ bunny>> vertex-array>> ] }
|
||||
{ "indexes" [ bunny>> index-elements>> ] }
|
||||
{ "framebuffer" [ sobel>> framebuffer>> ] }
|
||||
} <render-set> 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
|
||||
triangle-strip-mode >>primitive-mode
|
||||
T{ index-range f 0 4 } >>indexes
|
||||
swap sobel>>
|
||||
[ <sobel-uniforms> >>uniforms ]
|
||||
[ vertex-array>> >>vertex-array ] bi
|
||||
render ;
|
||||
sobel>> {
|
||||
{ "primitive-mode" [ drop triangle-strip-mode ] }
|
||||
{ "indexes" [ drop T{ index-range f 0 4 } ] }
|
||||
{ "uniforms" [ <sobel-uniforms> ] }
|
||||
{ "vertex-array" [ vertex-array>> ] }
|
||||
} <render-set> 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
|
||||
triangle-strip-mode >>primitive-mode
|
||||
T{ index-range f 0 4 } >>indexes
|
||||
swap loading>>
|
||||
[ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ]
|
||||
[ vertex-array>> >>vertex-array ] bi
|
||||
render ;
|
||||
loading>> {
|
||||
{ "primitive-mode" [ drop triangle-strip-mode ] }
|
||||
{ "indexes" [ drop T{ index-range f 0 4 } ] }
|
||||
{ "uniforms" [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] }
|
||||
{ "vertex-array" [ vertex-array>> ] }
|
||||
} <render-set> render ;
|
||||
|
||||
M: bunny-world draw-world*
|
||||
dup bunny>>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays game-loop game-worlds generalizations
|
||||
gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel
|
||||
literals math math.matrices math.order math.vectors
|
||||
USING: accessors arrays combinators.tuple game-loop game-worlds
|
||||
generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd
|
||||
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 } }
|
||||
{ "fov" float-uniform 2 }
|
||||
|
||||
{ "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 }
|
||||
{ "mv-inv-matrix" mat4-uniform f }
|
||||
{ "fov" vec2-uniform f }
|
||||
|
||||
{ "floor_height" float-uniform 1 }
|
||||
{ "floor_color[0]" float-uniform 4 }
|
||||
{ "floor_color[1]" float-uniform 4 }
|
||||
{ "background_color" float-uniform 4 }
|
||||
{ "light_direction" float-uniform 3 } ;
|
||||
{ "spheres" sphere-uniforms 4 }
|
||||
|
||||
{ "floor-height" float-uniform f }
|
||||
{ "floor-color" vec4-uniform 2 }
|
||||
{ "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
|
||||
first4 [ first3 ] 4 napply
|
||||
[ [ sphere-center ] [ radius>> ] [ color>> ] tri sphere-uniforms boa ] map
|
||||
] tri
|
||||
-30.0 ! floor_height
|
||||
{ 1.0 0.0 0.0 1.0 } ! floor_color[0]
|
||||
{ 1.0 1.0 1.0 1.0 } ! floor_color[1]
|
||||
{ { 1.0 0.0 0.0 1.0 } { 1.0 1.0 1.0 1.0 } } ! floor_color
|
||||
{ 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
|
||||
T{ index-range f 0 4 } >>indexes
|
||||
swap
|
||||
[ <sphere-uniforms> >>uniforms ]
|
||||
[ vertex-array>> >>vertex-array ] bi
|
||||
render ;
|
||||
{
|
||||
{ "primitive-mode" [ drop triangle-strip-mode ] }
|
||||
{ "indexes" [ drop T{ index-range f 0 4 } ] }
|
||||
{ "uniforms" [ <sphere-uniforms> ] }
|
||||
{ "vertex-array" [ vertex-array>> ] }
|
||||
} <render-set> render ;
|
||||
|
||||
M: raytrace-world pref-dim* drop { 1024 768 } ;
|
||||
M: raytrace-world tick-length drop 1000 30 /i ;
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } }
|
||||
{ "Vector uniforms take their values from Factor " { $link sequence } "s 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." } ;
|
||||
|
||||
{ bool-uniform int-uniform float-uniform texture-uniform } related-words
|
||||
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ;
|
||||
|
||||
{ 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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
classes.tuple classes.tuple.private combinators destructors fry
|
||||
assocs classes classes.mixin classes.parser classes.singleton
|
||||
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: "" }
|
||||
{ uniform-type uniform-type read-only initial: float-uniform }
|
||||
{ dim uniform-dim read-only initial: 4 } ;
|
||||
{ name string read-only initial: "" }
|
||||
{ uniform-type class read-only initial: float-uniform }
|
||||
{ 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 -- )
|
||||
[ 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
|
||||
|
|
@ -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 name>> reader-word :> value>>-word
|
||||
{ index swap value>>-word (bind-texture-unit) } >quotation ;
|
||||
: uniform-type-texture-units ( uniform-type -- units )
|
||||
dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] 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
|
||||
: all-uniform-tuple-slots ( class -- slots )
|
||||
dup "uniform-tuple-slots" word-prop
|
||||
[ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
|
||||
|
||||
{
|
||||
2dup next-method
|
||||
nip texture-uniforms-cleave cleave
|
||||
} >quotation ;
|
||||
DEFER: uniform-texture-accessors
|
||||
|
||||
:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
|
||||
uniform name>> :> name
|
||||
: 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]
|
||||
|
||||
:: [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{
|
||||
{ { bool-uniform 1 } [ >c-bool glUniform1i ] }
|
||||
{ { int-uniform 1 } [ glUniform1i ] }
|
||||
{ { uint-uniform 1 } [ glUniform1ui ] }
|
||||
{ { float-uniform 1 } [ glUniform1f ] }
|
||||
type H{
|
||||
{ bool-uniform { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv } }
|
||||
{ int-uniform { dim swap >int-array glUniform1iv } }
|
||||
{ uint-uniform { dim swap >uint-array glUniform1uiv } }
|
||||
{ float-uniform { dim swap >float-array glUniform1fv } }
|
||||
|
||||
{ { bool-uniform 2 } [ [ >c-bool ] map first2 glUniform2i ] }
|
||||
{ { int-uniform 2 } [ first2 glUniform2i ] }
|
||||
{ { uint-uniform 2 } [ first2 glUniform2ui ] }
|
||||
{ { float-uniform 2 } [ first2 glUniform2f ] }
|
||||
{ bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv } }
|
||||
{ ivec2-uniform { dim swap int-array{ } concat-as glUniform2i } }
|
||||
{ uvec2-uniform { dim swap uint-array{ } concat-as glUniform2ui } }
|
||||
{ vec2-uniform { dim swap float-array{ } concat-as glUniform2f } }
|
||||
|
||||
{ { bool-uniform 3 } [ [ >c-bool ] map first3 glUniform3i ] }
|
||||
{ { int-uniform 3 } [ first3 glUniform3i ] }
|
||||
{ { uint-uniform 3 } [ first3 glUniform3ui ] }
|
||||
{ { float-uniform 3 } [ first3 glUniform3f ] }
|
||||
{ bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv } }
|
||||
{ ivec3-uniform { dim swap int-array{ } concat-as glUniform3i } }
|
||||
{ uvec3-uniform { dim swap uint-array{ } concat-as glUniform3ui } }
|
||||
{ vec3-uniform { dim swap float-array{ } concat-as glUniform3f } }
|
||||
|
||||
{ { bool-uniform 4 } [ [ >c-bool ] map first4 glUniform4i ] }
|
||||
{ { int-uniform 4 } [ first4 glUniform4i ] }
|
||||
{ { uint-uniform 4 } [ first4 glUniform4ui ] }
|
||||
{ { float-uniform 4 } [ first4 glUniform4f ] }
|
||||
{ bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv } }
|
||||
{ ivec4-uniform { dim swap int-array{ } concat-as glUniform4iv } }
|
||||
{ uvec4-uniform { dim swap uint-array{ } concat-as glUniform4uiv } }
|
||||
{ vec4-uniform { dim swap float-array{ } concat-as glUniform4fv } }
|
||||
|
||||
{ { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv ] }
|
||||
{ { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] }
|
||||
{ { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] }
|
||||
{ mat2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv } }
|
||||
{ mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } }
|
||||
{ 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 ] }
|
||||
{ { 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 } }
|
||||
{ texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
|
||||
} at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
|
||||
|
||||
uniform uniform-type>> texture-uniform =
|
||||
[ texture-unit 1 + ] [ texture-unit ] if
|
||||
type uniform-type-texture-units dim * texture-unit +
|
||||
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
|
||||
|
||||
{
|
||||
2dup next-method
|
||||
uniforms-cleave 2cleave
|
||||
} >quotation ;
|
||||
first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
|
||||
|
||||
{ 2dup next-method } bind-quot [ ] append-as ;
|
||||
|
||||
: 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
|
||||
|
|
@ -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-uniform = ] filter length ] bi* +
|
||||
[ uniform-type-texture-units ]
|
||||
[
|
||||
[ [ 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) ]
|
||||
[ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ;
|
||||
(define-uniform-tuple) ; inline
|
||||
|
||||
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 }
|
||||
{ vertex-array vertex-array }
|
||||
{ uniforms uniform-tuple }
|
||||
{ indexes vertex-indexes initial: T{ index-range } }
|
||||
{ instances ?integer initial: f }
|
||||
{ framebuffer any-framebuffer initial: system-framebuffer }
|
||||
{ output-attachments sequence initial: { default-attachment } } ;
|
||||
{ primitive-mode primitive-mode read-only }
|
||||
{ vertex-array vertex-array read-only }
|
||||
{ uniforms uniform-tuple read-only }
|
||||
{ indexes vertex-indexes initial: T{ index-range } read-only }
|
||||
{ instances ?integer initial: f read-only }
|
||||
{ framebuffer any-framebuffer initial: system-framebuffer read-only }
|
||||
{ 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 -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
{ "p_matrix" float-uniform { 4 4 } } ;
|
||||
{ "mv_matrix" mat4-uniform f }
|
||||
{ "p_matrix" mat4-uniform f } ;
|
||||
|
||||
CONSTANT: -pi/2 $[ pi -2.0 / ]
|
||||
CONSTANT: pi/2 $[ pi 2.0 / ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue