-! 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 ;
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 ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time namespaces system ;
+kernel math unix unix.time unix.types namespaces system ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
timespec>seconds since-1970 ;
: get-time ( -- alien )
- f time <uint> localtime ;
+ f time <time_t> localtime ;
: timezone-name ( -- string )
get-time tm-zone ;
! 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
: 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 ;
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" } }
--- /dev/null
+! (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
! 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" %
! Programs
-: <mrt-gl-program> ( shaders frag-data-locations -- program )
+: (gl-program) ( shaders quot: ( gl-program -- ) -- program )
glCreateProgram
[
[ swap [ glAttachShader ] with each ]
- [ swap [ first2 swap glBindFragDataLocation ] with each ] bi-curry bi*
- ]
- [ glLinkProgram ]
- [ ] tri
- gl-error ;
+ [ swap call ] bi-curry bi*
+ ] [ glLinkProgram ] [ ] tri gl-error ; inline
+
+: <mrt-gl-program> ( shaders frag-data-locations -- program )
+ [ [ first2 swap glBindFragDataLocation ] with each ] curry (gl-program) ;
: <gl-program> ( shaders -- program )
- glCreateProgram
- [ swap [ glAttachShader ] with each ]
- [ glLinkProgram ]
- [ ] tri
- gl-error ;
+ [ drop ] (gl-program) ;
: (gl-program?) ( object -- ? )
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
{ "str" string }
{ "hash" hashtable }
{ "hashtable" hashtable }
- { "?" "a boolean" }
+ { "?" boolean }
{ "ch" "a character" }
{ "word" word }
{ "array" array }
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
+
+ALIAS: <time_t> <int>
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
TYPEDEF: ulonglong __uquad_type
TYPEDEF: ulonglong __fsfilcnt64_t
TYPEDEF: ulonglong ino64_t
TYPEDEF: ulonglong off64_t
+
+ALIAS: <time_t> <long>
\ No newline at end of file
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
! Darwin 9.1.0
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
TYPEDEF: long time_t
+
+ALIAS: <time_t> <long>
\ No newline at end of file
-USING: alien.syntax combinators layouts vocabs.loader ;
+USING: alien.syntax alien.c-types combinators layouts vocabs.loader ;
IN: unix.types
! NetBSD 4.0
TYPEDEF: int pid_t
TYPEDEF: int time_t
+ALIAS: <time_t> <int>
+
cell-bits {
{ 32 [ "unix.types.netbsd.32" require ] }
{ 64 [ "unix.types.netbsd.64" require ] }
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
! OpenBSD 4.2
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
+
+ALIAS: <time_t> <int>
\ No newline at end of file
{ "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 * ;
: 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> ;
USING: help.markup help.syntax math math.private ;
IN: math.floats
-ARTICLE: "floats" "Floats"
-{ $subsection float }
-"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers."
-$nl
-"Introducing a floating point number in a computation forces the result to be expressed in floating point."
-{ $example "5/4 1/2 + ." "1+3/4" }
-{ $example "5/4 0.5 + ." "1.75" }
-"Integers and rationals can be converted to floats:"
-{ $subsection >float }
-"Two real numbers can be divided yielding a float result:"
-{ $subsection /f }
-"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
-{ $subsection float>bits }
-{ $subsection double>bits }
-{ $subsection bits>float }
-{ $subsection bits>double }
-{ $see-also "syntax-floats" } ;
-
-ABOUT: "floats"
-
HELP: float
{ $class-description "The class of double-precision floating point numbers." } ;
{ $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;
HELP: bits>double ( n -- x )
-{ $values { "n" "a 64-bit integer representing an 754 double-precision float" } { "x" float } }
+{ $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
{ bits>double bits>float double>bits float>bits } related-words
HELP: bits>float ( n -- x )
-{ $values { "n" "a 32-bit integer representing an 754 single-precision float" } { "x" float } }
+{ $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
HELP: double>bits ( x -- n )
-{ $values { "x" float } { "n" "a 64-bit integer representing an 754 double-precision float" } }
+{ $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
HELP: float>bits ( x -- n )
-{ $values { "x" float } { "n" "a 32-bit integer representing an 754 single-precision float" } }
+{ $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
! Unsafe primitives
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
{ $description "Primitive version of " { $link >= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
+
+ARTICLE: "floats" "Floats"
+{ $subsection float }
+"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+$nl
+"Introducing a floating point number in a computation forces the result to be expressed in floating point."
+{ $example "5/4 1/2 + ." "1+3/4" }
+{ $example "5/4 0.5 + ." "1.75" }
+"Integers and rationals can be converted to floats:"
+{ $subsection >float }
+"Two real numbers can be divided yielding a float result:"
+{ $subsection /f }
+"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
+{ $subsection float>bits }
+{ $subsection double>bits }
+{ $subsection bits>float }
+{ $subsection bits>double }
+"Constructing floating point NaNs:"
+{ $subsection <fp-nan> }
+"Floating point numbers are discrete:"
+{ $subsection prev-float }
+{ $subsection next-float }
+"Introspection on floating point numbers:"
+{ $subsection fp-special? }
+{ $subsection fp-nan? }
+{ $subsection fp-qnan? }
+{ $subsection fp-snan? }
+{ $subsection fp-infinity? }
+{ $subsection fp-nan-payload }
+"Comparing two floating point numbers:"
+{ $subsection fp-bitwise= }
+{ $see-also "syntax-floats" } ;
+
+ABOUT: "floats"
} ;
HELP: <
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
HELP: <=
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
HELP: >
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
HELP: >=
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
{ $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
} ;
+HELP: fp-bitwise=
+{ $values
+ { "x" float } { "y" float }
+ { "?" boolean }
+}
+{ $description "Compares two floating point numbers for bit equality." } ;
+
HELP: fp-special?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
HELP: next-float
{ $values { "m" float } { "n" float } }
-{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } ", or in the case of " { $snippet "-0.0" } ", returns " { $snippet "+0.0" } "." } ;
HELP: prev-float
{ $values { "m" float } { "n" float } }
-{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } ", or in the case of " { $snippet "+0.0" } ", returns " { $snippet "-0.0" } "." } ;
{ next-float prev-float } related-words
} ;
HELP: slice
-{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } "."
+{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } ". Convenience words are also provided for creating slices where one endpoint is the start or end of the sequence; see " { $link "sequences-slices" } " for a list."
$nl
"Slices are mutable if the underlying sequence is mutable, and mutating a slice changes the underlying sequence. However, slices cannot be resized after creation." } ;
}
} ;
+HELP: assert-sequence=
+{ $values
+ { "a" sequence } { "b" sequence }
+}
+{ $description "Throws an error if all the elements of two sequences, taken pairwise, are not equal." }
+{ $notes "The sequences need not be of the same type." }
+{ $examples
+ { $example
+ "USING: prettyprint sequences ;"
+ "{ 1 2 3 } V{ 1 2 3 } assert-sequence="
+ ""
+ }
+} ;
+
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
{ $subsection virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
-"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "."
+"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
+$nl
+"Implementations include the following:"
+{ $list
+ { $link reversed }
+ { $link slice }
+ { $link iota }
+}
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence:"
{ $subsection "virtual-sequences-protocol" } ;
ARTICLE: "sequences-integers" "Counted loops"
{ $subsection pad-tail } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
+"There are two ways to extract a subrange of elements from a sequence. The first approach creates a new sequence of the same type as the input, which does not share storage with the underlying sequence. This takes time proportional to the number of elements being extracted. The second approach creates a " { $emphasis "slice" } ", which is a virtual sequence (see " { $link "virtual-sequences" } ") sharing storage with the original sequence. Slices are constructed in constant time."
+$nl
+"Some general guidelines for choosing between the two approaches:"
+{ $list
+ "If you are using mutable state, the choice has to be made one way or another because of semantics; mutating a slice will change the underlying sequence."
+ { "Using a slice can improve algorithmic complexity. For example, if each iteration of a loop decomposes a sequence using " { $link first } " and " { $link rest } ", then the loop will run in quadratic time, relative to the length of the sequence. Using " { $link rest-slice } " changes the loop to run in linear time, since " { $link rest-slice } " does not copy any elements. Taking a slice of a slice will “collapse” the slice so to avoid the double indirection, so it is safe to use slices in recursive code." }
+ "Accessing elements from a concrete sequence (such as a string or an array) is often faster than accessing elements from a slice, because slice access entails additional indirection. However, in some cases, if the slice is immediately consumed by an iteration combinator, the compiler can eliminate the slice allocation and indirect altogether."
+ "If the slice outlives the original sequence, the original sequence will still remain in memory, since the slice will reference it. This can increase memory consumption unnecessarily."
+}
+{ $heading "Subsequence operations" }
"Extracting a subsequence:"
{ $subsection subseq }
{ $subsection head }
{ $subsection unclip-last }
{ $subsection cut }
{ $subsection cut* }
-"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
+{ $heading "Slice operations" }
+"The slice data type:"
{ $subsection slice }
{ $subsection slice? }
"Extracting a slice:"
{ $subsection sequence= }
{ $subsection mismatch }
{ $subsection drop-prefix }
+{ $subsection assert-sequence= }
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! 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;
+ };
+};
+RAW-C>
+
+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
--- /dev/null
+! 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 ;
concat make-function ;
: define-c-library ( name -- )
- c-library-name c-library set
+ c-library-name [ c-library set ] [ "c-library" set ] bi
V{ } clone c-strings set
V{ } clone linker-args set ;
}
{ $see-also POSTPONE: delete-inline-library } ;
-HELP: RAW-C:
-{ $syntax "RAW-C:" "body" ";" }
-{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+HELP: <RAW-C
+{ $syntax "<RAW-C code RAW-C>" }
+{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
-SYNTAX: RAW-C: parse-here raw-c ;
+SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;
! 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' )
: pointer-to-const? ( str -- ? )
cify-type "const " head? ;
+: template-class? ( str -- ? )
+ [ CHAR: < = ] any? ;
+
MEMO: resolved-primitives ( -- seq )
primitive-types [ resolve-typedef ] map ;
[ 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 ;
"for all types except pointers to non-const primitives."
} ;
-HELP: pointer-unmarshaller
+HELP: class-unmarshaller
{ $values
{ "type" " a C type string" }
- { "quot" quotation }
+ { "quot/f" quotation }
}
{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
" named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
HELP: struct-unmarshaller
{ $values
{ "type" "a C type string" }
- { "quot" quotation }
+ { "quot/f" quotation }
}
{ $description "Returns a quotation which wraps its argument in the subclass of "
{ $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
"Wrap an alien:" { $subsection alien-wrapper }
"Wrap a struct:" { $subsection struct-wrapper }
"Get the marshaller for a C type:" { $subsection marshaller }
-"Get the unmarshaller for a C type:" { $subsection marshaller }
+"Get the unmarshaller for a C type:" { $subsection unmarshaller }
"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
$nl
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 ]
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' )
M: struct-wrapper dispose* underlying>> free ;
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
: marshall-pointer ( obj -- alien )
{
{ [ dup alien? ] [ ] }
: ?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* ;
-
-: pointer-unmarshaller ( type -- quot )
- type-sans-pointer current-vocab lookup [
- dup superclasses [ \ alien-wrapper = ] any? [
- '[ _ new swap >>underlying unmarshall-cast ]
- ] [ 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
+
+: 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?
--- /dev/null
+! (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"
--- /dev/null
+! (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
+
[ 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
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
: 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
}
{ $description "Constructs a " { $link buffer-ptr } " tuple." } ;
+HELP: <buffer-range>
+{ $values
+ { "buffer" buffer } { "offset" integer } { "size" integer }
+ { "buffer-range" buffer-range }
+}
+{ $description "Constructs a " { $link buffer-range } " tuple." } ;
+
HELP: <buffer>
{ $values
{ "upload" buffer-upload-pattern }
{ "An " { $link index-buffer } " is used to store indexes into a vertex array." }
{ "A " { $link pixel-unpack-buffer } " is used as a source for updating texture image data." }
{ "A " { $link pixel-pack-buffer } " is used as a destination for reading texture or framebuffer image data." }
+{ "A " { $link transform-feedback-buffer } " is used as a destination for transform feedback output from a vertex shader." }
} }
{ $notes "The " { $snippet "pixel-unpack-buffer" } " and " { $snippet "pixel-pack-buffer" } " kinds require OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
{ { $snippet "offset" } " is an integer offset from the beginning of the buffer." }
} } ;
+HELP: buffer-ptr>range
+{ $values
+ { "buffer-ptr" buffer-ptr }
+ { "buffer-range" buffer-range }
+}
+{ $description "Converts a " { $link buffer-ptr } " into a " { $link buffer-range } " spanning from the " { $snippet "offset" } " referenced by the " { $snippet "buffer-ptr" } " to the end of the underlying " { $link buffer } "." } ;
+
+HELP: buffer-range
+{ $class-description "A " { $snippet "buffer-range" } " references a subset of a " { $link buffer } " object's memory. " { $snippet "buffer-range" } "s are tuples with the following slots:"
+{ $list
+{ { $snippet "buffer" } " is the " { $link buffer } " object being referenced." }
+{ { $snippet "offset" } " is an integer offset from the beginning of the buffer to the beginning of the referenced range." }
+{ { $snippet "size" } " is the integer length from the beginning offset to the end of the referenced range." }
+} } ;
+
+{ buffer-ptr buffer-range } related-words
+
+HELP: buffer-size
+{ $values
+ { "buffer" buffer }
+ { "size" integer }
+}
+{ $description "Returns the size in bytes of the memory currently allocated for a " { $link buffer } " object." } ;
+
HELP: buffer-upload-pattern
{ $class-description { $snippet "buffer-upload-pattern" } " values aid the graphics driver in optimizing access to " { $link buffer } " objects by declaring the frequency with which the buffer will be supplied new data."
{ $list
{ dynamic-upload static-upload stream-upload } related-words
+HELP: transform-feedback-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to receive transform feedback output from a render job." }
+{ $notes "Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
+
HELP: update-buffer
{ $values
{ "buffer-ptr" buffer-ptr } { "size" integer } { "data" { $maybe c-ptr } }
HELP: vertex-buffer
{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to provide vertex attribute information to a vertex array." } ;
-{ index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer } related-words
+{ index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer transform-feedback-buffer } related-words
HELP: with-mapped-buffer
{ $values
}
{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
-{ allocate-buffer update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
+{ allocate-buffer buffer-size update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
HELP: write-access
{ $class-description "This " { $link buffer-access-mode } " value requests write-only access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
{ $subsection buffer-usage-pattern }
"Referencing buffer data:"
{ $subsection buffer-ptr }
+{ $subsection buffer-range }
"Manipulating buffer data:"
{ $subsection allocate-buffer }
{ $subsection update-buffer }
VARIANT: buffer-kind
vertex-buffer index-buffer
- pixel-unpack-buffer pixel-pack-buffer ;
+ pixel-unpack-buffer pixel-pack-buffer
+ transform-feedback-buffer ;
TUPLE: buffer < gpu-object
{ upload-pattern buffer-upload-pattern }
{ index-buffer [ GL_ELEMENT_ARRAY_BUFFER ] }
{ pixel-unpack-buffer [ GL_PIXEL_UNPACK_BUFFER ] }
{ pixel-pack-buffer [ GL_PIXEL_PACK_BUFFER ] }
+ { transform-feedback-buffer [ GL_TRANSFORM_FEEDBACK_BUFFER ] }
} case ; inline
+: get-buffer-int ( target enum -- value )
+ 0 <int> [ glGetBufferParameteriv ] keep *int ;
+
+: bind-buffer ( buffer -- target )
+ [ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ;
+
PRIVATE>
M: buffer dispose
{ offset integer read-only } ;
C: <buffer-ptr> buffer-ptr
+TUPLE: buffer-range < buffer-ptr
+ { size integer read-only } ;
+C: <buffer-range> buffer-range
+
UNION: gpu-data-ptr buffer-ptr c-ptr ;
+: buffer-size ( buffer -- size )
+ bind-buffer GL_BUFFER_SIZE get-buffer-int ;
+
+: buffer-ptr>range ( buffer-ptr -- buffer-range )
+ [ buffer>> ] [ offset>> ] bi
+ 2dup [ buffer-size ] dip -
+ buffer-range boa ; inline
+
:: allocate-buffer ( buffer size initial-data -- )
- buffer kind>> gl-target :> target
- target buffer handle>> glBindBuffer
+ buffer bind-buffer :> target
target size initial-data buffer gl-buffer-usage glBufferData ;
: <buffer> ( upload usage kind size initial-data -- buffer )
:: update-buffer ( buffer-ptr size data -- )
buffer-ptr buffer>> :> buffer
- buffer kind>> gl-target :> target
- target buffer handle>> glBindBuffer
+ buffer bind-buffer :> target
target buffer-ptr offset>> size data glBufferSubData ;
:: read-buffer ( buffer-ptr size -- data )
buffer-ptr buffer>> :> buffer
- buffer kind>> gl-target :> target
+ buffer bind-buffer :> target
size <byte-array> :> data
- target buffer handle>> glBindBuffer
target buffer-ptr offset>> size data glGetBufferSubData
data ;
size glCopyBufferSubData ;
:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
- buffer kind>> gl-target :> target
-
- target buffer handle>> glBindBuffer
+ buffer bind-buffer :> target
target access gl-access glMapBuffer
quot call
+! (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
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 ;
{ 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 )
: 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 ;
: 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>>
! (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
GLSL-PROGRAM: raytrace-program
raytrace-vertex-shader raytrace-fragment-shader ;
-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 }
+UNIFORM-TUPLE: sphere-uniforms
+ { "center" vec3-uniform f }
+ { "radius" float-uniform f }
+ { "color" vec4-uniform f } ;
- { "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 }
+UNIFORM-TUPLE: raytrace-uniforms
+ { "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 }
[ 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 ;
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 ;
}
{ $description "Constructs a " { $link multi-index-range } " tuple." } ;
-HELP: <vertex-array>
-{ $values
- { "program-instance" program-instance } { "vertex-formats" "a list of " { $link buffer-ptr } "/" { $link vertex-format } " pairs" }
- { "vertex-array" vertex-array }
-}
-{ $description "Creates a new " { $link vertex-array } " to feed data to " { $snippet "program-instance" } " from the set of " { $link buffer } "s specified in " { $snippet "vertex-formats" } "." } ;
-
HELP: UNIFORM-TUPLE:
{ $syntax <" UNIFORM-TUPLE: class-name
{ "slot" uniform-type dimension }
{ "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
{ { $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."
} ;
-HELP: VERTEX-FORMAT:
-{ $syntax <" VERTEX-FORMAT: format-name
- { "attribute"/f component-type dimension normalize? }
- { "attribute"/f component-type dimension normalize? }
- ...
- { "attribute"/f component-type dimension normalize? } ; "> }
-{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
-
-HELP: VERTEX-STRUCT:
-{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
-{ $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
- { "vertex-buffer" buffer } { "program-instance" program-instance } { "format" vertex-format }
- { "vertex-array" vertex-array }
-}
-{ $description "Creates a new " { $link vertex-array } " from the entire contents of a single " { $link buffer } " in a single " { $link vertex-format } " for use with " { $snippet "program-instance" } "." } ;
+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." } ;
-{ vertex-array <vertex-array> buffer>vertex-array } related-words
+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
}
{ $description "Defines a new " { $link uniform-tuple } " as a subclass of " { $snippet "superclass" } " with the slots specified by the " { $link uniform } " tuple values in " { $snippet "uniforms" } ". The runtime equivalent of " { $link POSTPONE: UNIFORM-TUPLE: } ". This word must be called inside a compilation unit." } ;
-HELP: define-vertex-format
-{ $values
- { "class" class } { "vertex-attributes" sequence }
-}
-{ $description "Defines a new " { $link vertex-format } " with the binary format specified by the " { $link vertex-attribute } " tuple values in " { $snippet "vertex-attributes" } ". The runtime equivalent of " { $link POSTPONE: VERTEX-FORMAT: } ". This word must be called inside a compilation unit." } ;
-
-HELP: define-vertex-struct
-{ $values
- { "struct-name" string } { "vertex-format" vertex-format }
-}
-{ $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
{ 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
}
{ $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." } ;
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
{ "The " { $snippet "uniforms" } " slot contains a " { $link uniform-tuple } " with values for the shader program's uniform parameters." }
{ "The " { $snippet "indexes" } " slot contains one of the " { $link vertex-indexes } " types and selects elements from the vertex array to be rendered." }
{ "The " { $snippet "instances" } " slot, if not " { $link f } ", instructs the GPU to render several instances of the same set of vertexes. Instancing requires OpenGL 3.1 or one of the " { $snippet "GL_EXT_draw_instanced" } " or " { $snippet "GL_ARB_draw_instanced" } " extensions." }
-{ "The " { $snippet "framebuffer" } " slot determines the target for the rendering output. Either the " { $link system-framebuffer } " or a user-created " { $link framebuffer } " object can be specified. User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions." }
-{ "The " { $snippet "output-attachments" } " slot specifies which of the framebuffer's " { $link color-attachment-ref } "s to write the fragment shader's color output to. If the shader uses " { $snippet "gl_FragColor" } " or " { $snippet "gl_FragData[n]" } " to write its output, then " { $snippet "output-attachments" } " should be an array of " { $link color-attachment-ref } "s, and the output to color attachment binding is determined positionally. If the shader uses named output values, then " { $snippet "output-attachments" } " should be a list of string/" { $link color-attachment-ref } " pairs, mapping output names to color attachments. Named output values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension." }
-} } ;
+{ "The " { $snippet "framebuffer" } " slot determines the target for the rendering output. Either the " { $link system-framebuffer } " or a user-created " { $link framebuffer } " object can be specified. " { $link f } " can also be specified to disable rasterization and only run the vertex transformation rendering stage." }
+{ "The " { $snippet "output-attachments" } " slot specifies which of the framebuffer's " { $link color-attachment-ref } "s to write the fragment shader's color output to. If the shader uses " { $snippet "gl_FragColor" } " or " { $snippet "gl_FragData[n]" } " to write its output, then " { $snippet "output-attachments" } " should be an array of " { $link color-attachment-ref } "s, and the output to color attachment binding is determined positionally. If the shader uses named output values, then " { $snippet "output-attachments" } " should be a list of string/" { $link color-attachment-ref } " pairs, mapping output names to color attachments." }
+{ "The " { $snippet "transform-feedback-output" } " slot specifies a target for transform feedback output from the vertex shader: either an entire " { $link buffer } ", a " { $link buffer-range } " subset, or a " { $link buffer-ptr } " offset into the buffer. If " { $link f } ", no transform feedback output is collected. The shader program associated with " { $snippet "vertex-array" } " must have a transform feedback output format specified." }
+} }
+{ $notes "User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions. Disabling rasterization requires OpenGL 3.0 or the " { $snippet "GL_EXT_transform_feedback" } " extension. Named output-attachment values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension. Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
{ 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." } ;
{ $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." } ;
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: 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." } ;
+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: vertex-array-buffer
-{ $values
- { "vertex-array" vertex-array }
- { "vertex-buffer" buffer }
-}
-{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
+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: vertex-attribute
-{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
+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: vertex-format
-{ $class-description "This class encompasses all vertex formats defined by " { $link POSTPONE: VERTEX-FORMAT: } ". A vertex format defines the binary layout of vertex attribute data in a " { $link buffer } " for use as part of a " { $link vertex-array } ". See the " { $link POSTPONE: VERTEX-FORMAT: } " documentation for details on how vertex formats are defined." } ;
+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: vertex-format-size
-{ $values
- { "format" vertex-format }
- { "size" integer }
-}
-{ $description "Returns the size in bytes of a set of vertex attributes in " { $snippet "format" } "." } ;
+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-indexes
{ $class-description "This class is a union of the following tuple types, any of which can be used as the " { $snippet "indexes" } " slot of a " { $link render-set } " to select elements from a " { $link vertex-array } " for rendering."
"The " { $vocab-link "gpu.render" } " vocabulary contains words for organizing and submitting data to the GPU for rendering."
{ $subsection render }
{ $subsection render-set }
-"Render data inside GPU " { $link buffer } "s is organized into " { $link vertex-array } "s for consumption by shader code:"
-{ $subsection vertex-array }
-{ $subsection <vertex-array> }
-{ $subsection buffer>vertex-array }
-{ $subsection POSTPONE: VERTEX-FORMAT: }
{ $link uniform-tuple } "s provide Factor types for containing and submitting shader uniform parameters:"
{ $subsection POSTPONE: UNIFORM-TUPLE: }
;
--- /dev/null
+USING: accessors combinators gpu.render gpu.render.private kernel sequences tools.test ;
+IN: gpu.render.tests
+
+UNIFORM-TUPLE: two-textures
+ { "argyle" texture-uniform f }
+ { "thread-count" float-uniform f }
+ { "tweed" texture-uniform f } ;
+
+UNIFORM-TUPLE: inherited-textures < two-textures
+ { "paisley" texture-uniform f } ;
+
+UNIFORM-TUPLE: array-of-textures < two-textures
+ { "plaids" texture-uniform 4 } ;
+
+UNIFORM-TUPLE: struct-containing-texture
+ { "threads" two-textures f } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-texture
+ { "threads" inherited-textures 3 } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-array-of-texture
+ { "threads" array-of-textures 2 } ;
+
+[ 1 ] [ texture-uniform uniform-type-texture-units ] unit-test
+[ 0 ] [ float-uniform uniform-type-texture-units ] unit-test
+[ 2 ] [ two-textures uniform-type-texture-units ] unit-test
+[ 3 ] [ inherited-textures uniform-type-texture-units ] unit-test
+[ 6 ] [ array-of-textures uniform-type-texture-units ] unit-test
+[ 2 ] [ struct-containing-texture uniform-type-texture-units ] unit-test
+[ 9 ] [ array-of-struct-containing-texture uniform-type-texture-units ] unit-test
+[ 12 ] [ array-of-struct-containing-array-of-texture uniform-type-texture-units ] unit-test
+
+[ { [ ] } ] [ texture-uniform f uniform-texture-accessors ] unit-test
+
+[ { } ] [ float-uniform f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] } ] [ two-textures f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] [ paisley>> ] } ]
+[ inherited-textures f uniform-texture-accessors ] unit-test
+
+[ {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+} ] [ array-of-textures f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ argyle>> ]
+ [ tweed>> ]
+ } ]
+} ] [ struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ 0 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ [ 1 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ [ 2 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ } ]
+} ] [ array-of-struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ 0 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+ } ]
+ [ 1 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+ } ]
+ } ]
+} ] [ array-of-struct-containing-array-of-texture f uniform-texture-accessors ] unit-test
+
+[ [
+ nip {
+ [ argyle>> 0 (bind-texture-unit) ]
+ [ tweed>> 1 (bind-texture-unit) ]
+ [ plaids>> {
+ [ 0 swap nth 2 (bind-texture-unit) ]
+ [ 1 swap nth 3 (bind-texture-unit) ]
+ [ 2 swap nth 4 (bind-texture-unit) ]
+ [ 3 swap nth 5 (bind-texture-unit) ]
+ } cleave ]
+ } cleave
+] ] [ array-of-textures [bind-uniform-textures] ] unit-test
+
! (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
+gpu.framebuffers.private gpu.shaders gpu.shaders.private 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 tr ui.gadgets.worlds variants
vocabs.parser words ;
IN: gpu.render
-UNION: ?string string POSTPONE: f ;
-UNION: uniform-dim integer sequence ;
-
-TUPLE: vertex-attribute
- { name ?string read-only initial: f }
- { component-type component-type read-only initial: float-components }
- { dim integer read-only initial: 4 }
- { normalize? boolean read-only initial: f } ;
+UNION: ?integer integer POSTPONE: f ;
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
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 }
triangle-strip-mode
triangle-fan-mode ;
-MIXIN: vertex-format
-
TUPLE: uniform-tuple ;
-GENERIC: vertex-format-size ( format -- size )
-
ERROR: invalid-uniform-type uniform ;
<PRIVATE
-: gl-vertex-type ( component-type -- gl-type )
- {
- { ubyte-components [ GL_UNSIGNED_BYTE ] }
- { ushort-components [ GL_UNSIGNED_SHORT ] }
- { uint-components [ GL_UNSIGNED_INT ] }
- { half-components [ GL_HALF_FLOAT ] }
- { float-components [ GL_FLOAT ] }
- { byte-integer-components [ GL_BYTE ] }
- { short-integer-components [ GL_SHORT ] }
- { int-integer-components [ GL_INT ] }
- { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
- { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
- { uint-integer-components [ GL_UNSIGNED_INT ] }
- } case ;
-
-: vertex-type-size ( component-type -- size )
- {
- { ubyte-components [ 1 ] }
- { ushort-components [ 2 ] }
- { uint-components [ 4 ] }
- { half-components [ 2 ] }
- { float-components [ 4 ] }
- { byte-integer-components [ 1 ] }
- { short-integer-components [ 2 ] }
- { int-integer-components [ 4 ] }
- { ubyte-integer-components [ 1 ] }
- { ushort-integer-components [ 2 ] }
- { uint-integer-components [ 4 ] }
- } case ;
-
-: vertex-attribute-size ( vertex-attribute -- size )
- [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
-
-: vertex-attributes-size ( vertex-attributes -- size )
- [ vertex-attribute-size ] [ + ] map-reduce ;
-
: gl-index-type ( index-type -- gl-index-type )
{
{ ubyte-indexes [ GL_UNSIGNED_BYTE ] }
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-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
- vertex-attribute name>> :> name
- vertex-attribute component-type>> :> type
- type gl-vertex-type :> gl-type
- vertex-attribute dim>> :> dim
- vertex-attribute normalize?>> >c-bool :> normalize?
- vertex-attribute vertex-attribute-size :> size
-
- stride offset size +
- {
- { [ name not ] [ [ 2drop ] ] }
- {
- [ type unnormalized-integer-components? ]
- [
- {
- name attribute-index [ glEnableVertexAttribArray ] keep
- dim gl-type stride offset
- } >quotation :> dip-block
-
- { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
- ]
- }
- [
- {
- name attribute-index [ glEnableVertexAttribArray ] keep
- dim gl-type normalize? stride offset
- } >quotation :> dip-block
-
- { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
- ]
- } cond ;
-
-:: [bind-vertex-format] ( vertex-attributes -- quot )
- vertex-attributes vertex-attributes-size :> stride
- stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
- { attributes-cleave 2cleave } >quotation :> with-block
-
- { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
-
-GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
-
-: define-vertex-format-methods ( class vertex-attributes -- )
- [
- [ \ bind-vertex-format create-method-in ] dip
- [bind-vertex-format] define
- ] [
- [ \ vertex-format-size create-method-in ] dip
- [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
- ] 2bi ;
+: (bind-texture-unit) ( texture texture-unit -- )
+ swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
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
+
+: 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 ;
-:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
- uniform name>> :> name
+: 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
+ { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+ 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 } }
+
+ { 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 } }
+
+ { 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 } }
+
+ { 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 } }
+
+ { 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 } }
+
+ { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
+ } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+ type uniform-type-texture-units dim * texture-unit +
+ pre-quot value-quot append ;
+
+:: [bind-uniform-value] ( value>>-quot type texture-unit name -- 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 [ >c-bool glUniform1i ] }
+ { int-uniform [ glUniform1i ] }
+ { uint-uniform [ glUniform1ui ] }
+ { float-uniform [ glUniform1f ] }
- { { 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 [ [ >c-bool ] map first2 glUniform2i ] }
+ { ivec2-uniform [ first2 glUniform2i ] }
+ { uvec2-uniform [ first2 glUniform2ui ] }
+ { vec2-uniform [ first2 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 [ [ >c-bool ] map first3 glUniform3i ] }
+ { ivec3-uniform [ first3 glUniform3i ] }
+ { uvec3-uniform [ first3 glUniform3ui ] }
+ { vec3-uniform [ first3 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 [ [ >c-bool ] map first4 glUniform4i ] }
+ { ivec4-uniform [ first4 glUniform4i ] }
+ { uvec4-uniform [ first4 glUniform4ui ] }
+ { vec4-uniform [ first4 glUniform4f ] }
- { { 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 [ [ 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 ] }
- { { 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 ] }
+ { 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 ] }
- { { 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 ] }
+ { 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 1 } { drop texture-unit glUniform1i } }
+ { texture-uniform { drop texture-unit glUniform1i } }
} 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 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
] }
} case ;
-: component-type>c-type ( component-type -- c-type )
- {
- { ubyte-components [ "uchar" ] }
- { ushort-components [ "ushort" ] }
- { uint-components [ "uint" ] }
- { half-components [ "half" ] }
- { float-components [ "float" ] }
- { byte-integer-components [ "char" ] }
- { ubyte-integer-components [ "uchar" ] }
- { short-integer-components [ "short" ] }
- { ushort-integer-components [ "ushort" ] }
- { int-integer-components [ "int" ] }
- { uint-integer-components [ "uint" ] }
- } case ;
-
-: c-array-dim ( dim -- string )
- dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
-
-SYMBOL: padding-no
-padding-no [ 0 ] initialize
-
-: padding-name ( -- name )
- "padding-"
- padding-no get number>string append
- "(" ")" surround
- padding-no inc ;
-
-: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
- [
- [ component-type>> component-type>c-type ]
- [ dim>> c-array-dim ] bi append
- ] [ name>> [ padding-name ] unless* ] bi 2array ;
-
: (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 -- )
- [
- [
- [ define-singleton-class ]
- [ vertex-format add-mixin-instance ]
- [ ] tri
- ] [ define-vertex-format-methods ] bi*
- ]
- [ "vertex-format-attributes" set-word-prop ] 2bi ;
-
-SYNTAX: VERTEX-FORMAT:
- CREATE-CLASS parse-definition
- [ first4 vertex-attribute boa ] map
- define-vertex-format ;
-
-: define-vertex-struct ( struct-name vertex-format -- )
- [ current-vocab ] dip
- "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
- define-struct ;
-
-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 ;
-TUPLE: vertex-array < gpu-object
- { program-instance program-instance read-only }
- { vertex-buffers sequence read-only } ;
-
-M: vertex-array dispose
- [ [ delete-vertex-array ] when* f ] change-handle drop ;
-
-: <vertex-array> ( program-instance vertex-formats -- vertex-array )
- gen-vertex-array
- [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
- [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
- window-resource ;
-
-: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
- [ swap ] dip
- [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
-
-: vertex-array-buffer ( vertex-array -- vertex-buffer )
- vertex-buffers>> first ;
-
<PRIVATE
: bind-vertex-array ( vertex-array -- )
dup first sequence?
[ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ;
+GENERIC: bind-transform-feedback-output ( output -- )
+
+M: buffer bind-transform-feedback-output
+ [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip handle>> glBindBufferBase ; inline
+
+M: buffer-range bind-transform-feedback-output
+ [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip
+ [ handle>> ] [ offset>> ] [ size>> ] tri glBindBufferRange ; inline
+
+M: buffer-ptr bind-transform-feedback-output
+ buffer-ptr>range bind-transform-feedback-output ; inline
+
+: gl-feedback-primitive-mode ( primitive-mode -- gl-mode )
+ {
+ { points-mode [ GL_POINTS ] }
+ { lines-mode [ GL_LINES ] }
+ { line-strip-mode [ GL_LINES ] }
+ { line-loop-mode [ GL_LINES ] }
+ { triangles-mode [ GL_TRIANGLES ] }
+ { triangle-strip-mode [ GL_TRIANGLES ] }
+ { triangle-fan-mode [ GL_TRIANGLES ] }
+ } case ;
+
PRIVATE>
+UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
+UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
+
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 }
+ { transform-feedback-output transform-feedback-output initial: f 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 -- )
{
[ vertex-array>> program-instance>> ] [ uniforms>> ] bi
[ bind-uniform-textures ] [ bind-uniforms ] 2bi
]
- [ GL_DRAW_FRAMEBUFFER swap framebuffer>> framebuffer-handle glBindFramebuffer ]
+ [
+ framebuffer>>
+ [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
+ [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
+ ]
[
[ vertex-array>> program-instance>> ]
[ framebuffer>> ]
bind-output-attachments
]
[ vertex-array>> bind-vertex-array ]
+ [
+ dup transform-feedback-output>> [
+ [ primitive-mode>> gl-feedback-primitive-mode glBeginTransformFeedback ]
+ [ bind-transform-feedback-output ] bi*
+ ] [ drop ] if*
+ ]
+
[
[ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
[ render-vertex-indexes-instanced ]
[ render-vertex-indexes ] if*
]
+
+ [ transform-feedback-output>> [ glEndTransformFeedback ] when ]
+ [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]
} cleave ; inline
M: compile-shader-error error.
"The GLSL shader " write
- [ shader>> name>> pprint-short " failed to compile." write nl ]
- [ log>> write nl ] bi ;
+ [ shader>> name>> pprint-short " failed to compile." print ]
+ [ log>> print ] bi ;
M: link-program-error error.
"The GLSL program " write
- [ shader>> name>> pprint-short " failed to link." write nl ]
- [ log>> write nl ] bi ;
+ [ shader>> name>> pprint-short " failed to link." print ]
+ [ log>> print ] bi ;
+
+M: too-many-feedback-formats-error error.
+ drop
+ "Only one transform feedback format can be specified for a program." print ;
+
+M: invalid-link-feedback-format-error error.
+ drop
+ "Vertex formats used for transform feedback can't contain padding fields." print ;
+
+M: inaccurate-feedback-attribute-error error.
+ drop
+ "The types of the transform feedback attributes don't match those specified by the program's vertex format." print ;
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax kernel math multiline quotations strings ;
+USING: alien.syntax classes gpu.buffers help.markup help.syntax
+images kernel math multiline quotations sequences strings ;
IN: gpu.shaders
HELP: <program-instance>
}
{ $description "Compiles an instance of " { $snippet "shader" } " for the current graphics context. If an instance already exists for " { $snippet "shader" } " in the current context, it is reused." } ;
+HELP: <vertex-array>
+{ $values
+ { "program-instance" program-instance } { "vertex-formats" "a list of " { $link buffer-ptr } "/" { $link vertex-format } " pairs" }
+ { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " to feed data to " { $snippet "program-instance" } " from the set of " { $link buffer } "s specified in " { $snippet "vertex-formats" } "." } ;
+
HELP: GLSL-PROGRAM:
-{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader ;" }
-{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance." } ;
+{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader [vertex-format] ;" }
+{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance. A single " { $link vertex-array } " may optionally be specified; if the program is used to collect transform feedback, this format will be used for the output." }
+{ $notes "Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
HELP: GLSL-SHADER-FILE:
{ $syntax "GLSL-SHADER-FILE: shader-name shader-kind \"filename\"" }
; "> }
{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from the current Factor source file between the " { $snippet "GLSL-SHADER:" } " line and the first subsequent line with a single semicolon on it." } ;
+HELP: VERTEX-FORMAT:
+{ $syntax <" VERTEX-FORMAT: format-name
+ { "attribute"/f component-type dimension normalize? }
+ { "attribute"/f component-type dimension normalize? }
+ ...
+ { "attribute"/f component-type dimension normalize? } ; "> }
+{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
+
+HELP: VERTEX-STRUCT:
+{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
+{ $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 } "." } ;
+
{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
HELP: attribute-index
}
{ $description "Returns the numeric index of the vertex attribute named " { $snippet "attribute-name" } " in " { $snippet "program-instance" } "." } ;
+HELP: buffer>vertex-array
+{ $values
+ { "vertex-buffer" buffer } { "program-instance" program-instance } { "format" vertex-format }
+ { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " from the entire contents of a single " { $link buffer } " in a single " { $link vertex-format } " for use with " { $snippet "program-instance" } "." } ;
+
+{ vertex-array <vertex-array> buffer>vertex-array } related-words
+
HELP: compile-shader-error
{ $class-description "An error compiling the source for a " { $link shader } "."
{ $list
{ "The " { $snippet "log" } " slot contains the error string from the GLSL compiler." }
} } ;
+HELP: define-vertex-format
+{ $values
+ { "class" class } { "vertex-attributes" sequence }
+}
+{ $description "Defines a new " { $link vertex-format } " with the binary format specified by the " { $link vertex-attribute } " tuple values in " { $snippet "vertex-attributes" } ". The runtime equivalent of " { $link POSTPONE: VERTEX-FORMAT: } ". This word must be called inside a compilation unit." } ;
+
+HELP: define-vertex-struct
+{ $values
+ { "struct-name" string } { "vertex-format" vertex-format }
+}
+{ $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: fragment-shader
{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a fragment shader." } ;
{ { $link fragment-shader } "s run as part of rasterization and decide the final rendered output of a primitive as the outputs of the vertex shader are interpolated across its surface." }
} } ;
+HELP: too-many-feedback-formats-error
+{ $class-description "This error is thrown when a " { $link POSTPONE: GLSL-PROGRAM: } " definition attempts to include more than one " { $link vertex-format } " for transform feedback formatting." } ;
+
+HELP: invalid-link-feedback-format-error
+{ $class-description "This error is thrown when the " { $link vertex-format } " specified as the transform feedback output format of a " { $link program } " is not suitable for the purpose. Transform feedback formats do not support padding (fields with a name of " { $link f } ")." } ;
+
+HELP: inaccurate-feedback-attribute-error
+{ $class-description "This error is thrown when the " { $link vertex-format } " specified as the transform feedback output format of a " { $link program } " does not match the format of the output attributes linked into a " { $link program-instance } "." } ;
+
HELP: uniform-index
{ $values
{ "program-instance" program-instance } { "uniform-name" string }
HELP: vertex-shader
{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a vertex shader." } ;
+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." } ;
+
+HELP: vertex-array-buffer
+{ $values
+ { "vertex-array" vertex-array }
+ { "vertex-buffer" buffer }
+}
+{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
+
+HELP: vertex-attribute
+{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
+
+HELP: vertex-format
+{ $class-description "This class encompasses all vertex formats defined by " { $link POSTPONE: VERTEX-FORMAT: } ". A vertex format defines the binary layout of vertex attribute data in a " { $link buffer } " for use as part of a " { $link vertex-array } ". See the " { $link POSTPONE: VERTEX-FORMAT: } " documentation for details on how vertex formats are defined." } ;
+
+HELP: vertex-format-size
+{ $values
+ { "format" vertex-format }
+ { "size" integer }
+}
+{ $description "Returns the size in bytes of a set of vertex attributes in " { $snippet "format" } "." } ;
+
ARTICLE: "gpu.shaders" "Shader objects"
"The " { $vocab-link "gpu.shaders" } " vocabulary supports defining, compiling, and linking " { $link shader } "s into " { $link program } "s that run on the GPU and control rendering."
{ $subsection POSTPONE: GLSL-PROGRAM: }
"A program must be instantiated for each graphics context it is used in:"
{ $subsection <program-instance> }
"Program instances can be updated on the fly, allowing for interactive development of shaders:"
-{ $subsection refresh-program } ;
+{ $subsection refresh-program }
+"Render data inside GPU " { $link buffer } "s is organized into " { $link vertex-array } "s for consumption by shader code:"
+{ $subsection vertex-array }
+{ $subsection <vertex-array> }
+{ $subsection buffer>vertex-array }
+{ $subsection POSTPONE: VERTEX-FORMAT: } ;
ABOUT: "gpu.shaders"
! (c)2009 Joe Groff bsd license
-USING: accessors arrays assocs combinators
-combinators.short-circuit definitions destructors gpu
-io.encodings.ascii io.files io.pathnames kernel lexer
-locals math math.parser memoize multiline namespaces
-opengl.gl opengl.shaders parser sequences
-specialized-arrays.int splitting strings ui.gadgets.worlds
-variants hashtables vectors vocabs vocabs.loader words
-words.constant ;
+USING: accessors alien alien.c-types alien.strings
+alien.structs arrays assocs byte-arrays classes.mixin
+classes.parser classes.singleton combinators
+combinators.short-circuit definitions destructors
+generic.parser gpu gpu.buffers hashtables images
+io.encodings.ascii io.files io.pathnames kernel lexer literals
+locals math math.parser memoize multiline namespaces opengl
+opengl.gl opengl.shaders parser quotations sequences
+specialized-arrays.alien specialized-arrays.int splitting
+strings ui.gadgets.worlds variants vectors vocabs vocabs.loader
+vocabs.parser words words.constant ;
IN: gpu.shaders
VARIANT: shader-kind
vertex-shader fragment-shader ;
+UNION: ?string string POSTPONE: f ;
+
+ERROR: too-many-feedback-formats-error formats ;
+ERROR: invalid-link-feedback-format-error format ;
+ERROR: inaccurate-feedback-attribute-error attribute ;
+
+TUPLE: vertex-attribute
+ { name ?string read-only initial: f }
+ { component-type component-type read-only initial: float-components }
+ { dim integer read-only initial: 4 }
+ { normalize? boolean read-only initial: f } ;
+
+MIXIN: vertex-format
+UNION: ?vertex-format vertex-format POSTPONE: f ;
+
TUPLE: shader
{ name word read-only initial: t }
{ kind shader-kind read-only }
{ filename read-only }
{ line integer read-only }
{ shaders array read-only }
+ { feedback-format ?vertex-format read-only }
{ instances hashtable read-only } ;
TUPLE: shader-instance < gpu-object
{ program program }
{ world world } ;
+GENERIC: vertex-format-size ( format -- size )
+
+MEMO: uniform-index ( program-instance uniform-name -- index )
+ [ handle>> ] dip glGetUniformLocation ;
+MEMO: attribute-index ( program-instance attribute-name -- index )
+ [ handle>> ] dip glGetAttribLocation ;
+MEMO: output-index ( program-instance output-name -- index )
+ [ handle>> ] dip glGetFragDataLocation ;
+
<PRIVATE
+: gl-vertex-type ( component-type -- gl-type )
+ {
+ { ubyte-components [ GL_UNSIGNED_BYTE ] }
+ { ushort-components [ GL_UNSIGNED_SHORT ] }
+ { uint-components [ GL_UNSIGNED_INT ] }
+ { half-components [ GL_HALF_FLOAT ] }
+ { float-components [ GL_FLOAT ] }
+ { byte-integer-components [ GL_BYTE ] }
+ { short-integer-components [ GL_SHORT ] }
+ { int-integer-components [ GL_INT ] }
+ { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
+ { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
+ { uint-integer-components [ GL_UNSIGNED_INT ] }
+ } case ;
+
+: vertex-type-size ( component-type -- size )
+ {
+ { ubyte-components [ 1 ] }
+ { ushort-components [ 2 ] }
+ { uint-components [ 4 ] }
+ { half-components [ 2 ] }
+ { float-components [ 4 ] }
+ { byte-integer-components [ 1 ] }
+ { short-integer-components [ 2 ] }
+ { int-integer-components [ 4 ] }
+ { ubyte-integer-components [ 1 ] }
+ { ushort-integer-components [ 2 ] }
+ { uint-integer-components [ 4 ] }
+ } case ;
+
+: vertex-attribute-size ( vertex-attribute -- size )
+ [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
+
+: vertex-attributes-size ( vertex-attributes -- size )
+ [ vertex-attribute-size ] [ + ] map-reduce ;
+
+: feedback-type= ( component-type dim gl-type -- ? )
+ [ 2array ] dip {
+ { $ GL_FLOAT [ { float-components 1 } ] }
+ { $ GL_FLOAT_VEC2 [ { float-components 2 } ] }
+ { $ GL_FLOAT_VEC3 [ { float-components 3 } ] }
+ { $ GL_FLOAT_VEC4 [ { float-components 4 } ] }
+ { $ GL_INT [ { int-integer-components 1 } ] }
+ { $ GL_INT_VEC2 [ { int-integer-components 2 } ] }
+ { $ GL_INT_VEC3 [ { int-integer-components 3 } ] }
+ { $ GL_INT_VEC4 [ { int-integer-components 4 } ] }
+ { $ GL_UNSIGNED_INT [ { uint-integer-components 1 } ] }
+ { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
+ { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
+ { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
+ } case = ;
+
+:: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
+ {
+ [ vertex-attribute name>> name = ]
+ [ size 1 = ]
+ [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
+ } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
+
+:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
+ vertex-attribute name>> :> name
+ vertex-attribute component-type>> :> type
+ type gl-vertex-type :> gl-type
+ vertex-attribute dim>> :> dim
+ vertex-attribute normalize?>> >c-bool :> normalize?
+ vertex-attribute vertex-attribute-size :> size
+
+ stride offset size +
+ {
+ { [ name not ] [ [ 2drop ] ] }
+ {
+ [ type unnormalized-integer-components? ]
+ [
+ {
+ name attribute-index [ glEnableVertexAttribArray ] keep
+ dim gl-type stride offset
+ } >quotation :> dip-block
+
+ { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
+ ]
+ }
+ [
+ {
+ name attribute-index [ glEnableVertexAttribArray ] keep
+ dim gl-type normalize? stride offset
+ } >quotation :> dip-block
+
+ { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
+ ]
+ } cond ;
+
+:: [bind-vertex-format] ( vertex-attributes -- quot )
+ vertex-attributes vertex-attributes-size :> stride
+ stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
+ { attributes-cleave 2cleave } >quotation :> with-block
+
+ { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
+
+:: [link-feedback-format] ( vertex-attributes -- quot )
+ vertex-attributes [ name>> not ] any?
+ [ [ nip invalid-link-feedback-format-error ] ] [
+ vertex-attributes
+ [ name>> ascii malloc-string ]
+ void*-array{ } map-as :> varying-names
+ vertex-attributes length :> varying-count
+ { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
+ >quotation
+ ] if ;
+
+:: [verify-feedback-attribute] ( vertex-attribute index -- quot )
+ vertex-attribute name>> :> name
+ name length 1 + :> name-buffer-length
+ {
+ index name-buffer-length dup
+ [ f 0 <int> 0 <int> ] dip <byte-array>
+ [ glGetTransformFeedbackVarying ] 3keep
+ ascii alien>string
+ vertex-attribute assert-feedback-attribute
+ } >quotation ;
+
+:: [verify-feedback-format] ( vertex-attributes -- quot )
+ vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
+ { drop verify-cleave cleave } >quotation ;
+
+GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
+
+GENERIC: link-feedback-format ( program-handle format -- )
+
+M: f link-feedback-format
+ 2drop ;
+
+GENERIC: (verify-feedback-format) ( program-instance format -- )
+
+M: f (verify-feedback-format)
+ 2drop ;
+
+: verify-feedback-format ( program-instance -- )
+ dup program>> feedback-format>> (verify-feedback-format) ;
+
+: define-vertex-format-methods ( class vertex-attributes -- )
+ {
+ [
+ [ \ bind-vertex-format create-method-in ] dip
+ [bind-vertex-format] define
+ ] [
+ [ \ link-feedback-format create-method-in ] dip
+ [link-feedback-format] define
+ ] [
+ [ \ (verify-feedback-format) create-method-in ] dip
+ [verify-feedback-format] define
+ ] [
+ [ \ vertex-format-size create-method-in ] dip
+ [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
+ ]
+ } 2cleave ;
+
+: component-type>c-type ( component-type -- c-type )
+ {
+ { ubyte-components [ "uchar" ] }
+ { ushort-components [ "ushort" ] }
+ { uint-components [ "uint" ] }
+ { half-components [ "half" ] }
+ { float-components [ "float" ] }
+ { byte-integer-components [ "char" ] }
+ { ubyte-integer-components [ "uchar" ] }
+ { short-integer-components [ "short" ] }
+ { ushort-integer-components [ "ushort" ] }
+ { int-integer-components [ "int" ] }
+ { uint-integer-components [ "uint" ] }
+ } case ;
+
+: c-array-dim ( dim -- string )
+ dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
+
+SYMBOL: padding-no
+padding-no [ 0 ] initialize
+
+: padding-name ( -- name )
+ "padding-"
+ padding-no get number>string append
+ "(" ")" surround
+ padding-no inc ;
+
+: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
+ [
+ [ component-type>> component-type>c-type ]
+ [ dim>> c-array-dim ] bi append
+ ] [ name>> [ padding-name ] unless* ] bi 2array ;
+
: shader-filename ( shader/program -- filename )
dup filename>> [ nip ] [ name>> where first ] if* file-name ;
PRIVATE>
+: define-vertex-format ( class vertex-attributes -- )
+ [
+ [
+ [ define-singleton-class ]
+ [ vertex-format add-mixin-instance ]
+ [ ] tri
+ ] [ define-vertex-format-methods ] bi*
+ ]
+ [ "vertex-format-attributes" set-word-prop ] 2bi ;
+
+SYNTAX: VERTEX-FORMAT:
+ CREATE-CLASS parse-definition
+ [ first4 vertex-attribute boa ] map
+ define-vertex-format ;
+
+: define-vertex-struct ( struct-name vertex-format -- )
+ [ current-vocab ] dip
+ "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
+ define-struct ;
+
+SYNTAX: VERTEX-STRUCT:
+ scan scan-word define-vertex-struct ;
+
+TUPLE: vertex-array < gpu-object
+ { program-instance program-instance read-only }
+ { vertex-buffers sequence read-only } ;
+
+M: vertex-array dispose
+ [ [ delete-vertex-array ] when* f ] change-handle drop ;
+
+: <vertex-array> ( program-instance vertex-formats -- vertex-array )
+ gen-vertex-array
+ [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
+ [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
+ window-resource ;
+
+: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
+ [ swap ] dip
+ [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
+
+: vertex-array-buffer ( vertex-array -- vertex-buffer )
+ vertex-buffers>> first ;
+
TUPLE: compile-shader-error shader log ;
TUPLE: link-program-error program log ;
DEFER: <shader-instance>
-MEMO: uniform-index ( program-instance uniform-name -- index )
- [ handle>> ] dip glGetUniformLocation ;
-MEMO: attribute-index ( program-instance attribute-name -- index )
- [ handle>> ] dip glGetAttribLocation ;
-MEMO: output-index ( program-instance output-name -- index )
- [ handle>> ] dip glGetFragDataLocation ;
-
<PRIVATE
: valid-handle? ( handle -- ? )
[ compile-shader-error ] if ;
: (link-program) ( program shader-instances -- program-instance )
- [ handle>> ] map <gl-program>
- dup gl-program-ok?
- [ swap world get \ program-instance boa window-resource ]
- [ link-program-error ] if ;
+ [ [ handle>> ] map ] curry
+ [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
+ dup gl-program-ok? [
+ [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
+ with-destructors window-resource
+ ] [ link-program-error ] if ;
: link-program ( program -- program-instance )
dup shaders>> [ <shader-instance> ] map (link-program) ;
world get over instances>> at*
[ nip ] [ drop link-program ] if ;
+: shaders-and-feedback-format ( words -- shaders feedback-format )
+ [ vertex-format? ] partition swap
+ [ [ def>> first ] map ] [
+ dup length 1 <=
+ [ [ f ] [ first ] if-empty ]
+ [ too-many-feedback-formats-error ] if
+ ] bi* ;
+
PRIVATE>
:: refresh-program ( program -- )
CREATE-WORD dup
f
lexer get line>>
- \ ; parse-until >array [ def>> first ] map
+ \ ; parse-until >array shaders-and-feedback-format
H{ } clone
program boa
define-constant ;
: get-texture-float ( target level enum -- value )
0 <float> [ glGetTexLevelParameterfv ] keep *float ;
-: get-texture-int ( texture level enum -- value )
+: get-texture-int ( target level enum -- value )
0 <int> [ glGetTexLevelParameteriv ] keep *int ;
: ?product ( x -- y )
! (c)2009 Joe Groff bsd license
-USING: gpu.buffers gpu.render gpu.textures images kernel
+USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
specialized-arrays.float ;
IN: gpu.util
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 / ]
projects / factor.git / commitdiff