Merge branch 'master' of git://factorcode.org/git/factor

db4
Sam Anklesaria 2009-07-27 21:46:10 -05:00
commit 16e44372e3
49 changed files with 1498 additions and 617 deletions

View File

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

View File

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

View File

@ -1,7 +1,7 @@
! 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 )
@ -19,7 +19,7 @@ IN: calendar.unix
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <uint> localtime ;
f time <time_t> localtime ;
: timezone-name ( -- string )
get-time tm-zone ;

View File

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

View File

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

View File

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

View File

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

View File

@ -61,22 +61,18 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
! 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 ;

View File

@ -124,7 +124,7 @@ M: bad-developer-name summary
{ "str" string }
{ "hash" hashtable }
{ "hashtable" hashtable }
{ "?" "a boolean" }
{ "?" boolean }
{ "ch" "a character" }
{ "word" word }
{ "array" array }

View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
@ -22,3 +22,5 @@ TYPEDEF: __uint32_t fflags_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
ALIAS: <time_t> <int>

View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
TYPEDEF: ulonglong __uquad_type
@ -31,3 +31,5 @@ TYPEDEF: ulonglong __fsblkcnt64_t
TYPEDEF: ulonglong __fsfilcnt64_t
TYPEDEF: ulonglong ino64_t
TYPEDEF: ulonglong off64_t
ALIAS: <time_t> <long>

View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
! Darwin 9.1.0
@ -21,3 +21,5 @@ TYPEDEF: __int32_t blksize_t
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
TYPEDEF: long time_t
ALIAS: <time_t> <long>

View File

@ -1,4 +1,4 @@
USING: alien.syntax combinators layouts vocabs.loader ;
USING: alien.syntax alien.c-types combinators layouts vocabs.loader ;
IN: unix.types
! NetBSD 4.0
@ -17,6 +17,8 @@ TYPEDEF: long ssize_t
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 ] }

View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
! OpenBSD 4.2
@ -17,3 +17,5 @@ TYPEDEF: __uint32_t fflags_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
ALIAS: <time_t> <int>

View File

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

View File

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

View File

@ -1,26 +1,6 @@
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." } ;
@ -29,21 +9,21 @@ HELP: >float
{ $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
@ -91,3 +71,37 @@ HELP: float>= ( x y -- ? )
{ $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"

View File

@ -12,19 +12,19 @@ HELP: number=
} ;
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" } "." } ;
@ -245,6 +245,13 @@ HELP: times
{ $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 } "." } ;
@ -282,11 +289,11 @@ HELP: <fp-nan>
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

View File

@ -627,7 +627,7 @@ HELP: slice-error
} ;
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." } ;
@ -1311,6 +1311,20 @@ HELP: iota
}
} ;
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
@ -1357,7 +1371,15 @@ ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
{ $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"
@ -1422,6 +1444,16 @@ ARTICLE: "sequences-appending" "Appending sequences"
{ $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 }
@ -1436,7 +1468,8 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $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:"
@ -1591,6 +1624,7 @@ ARTICLE: "sequences-comparing" "Comparing sequences"
{ $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"

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

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

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

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

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

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

View File

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

View File

@ -65,7 +65,7 @@ PRIVATE>
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 ;

View File

@ -95,6 +95,6 @@ HELP: DELETE-C-LIBRARY:
}
{ $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" } "." } ;

View File

@ -28,4 +28,4 @@ SYNTAX: ;C-LIBRARY compile-c-library ;
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 ;

View File

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

View File

@ -327,10 +327,10 @@ HELP: out-arg-unmarshaller
"for all types except pointers to non-const primitives."
} ;
HELP: pointer-unmarshaller
HELP: class-unmarshaller
{ $values
{ "type" " a C type string" }
{ "quot" quotation }
{ "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 "
@ -376,7 +376,7 @@ HELP: struct-primitive-unmarshaller
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."
@ -604,7 +604,7 @@ ARTICLE: "alien.marshall" "C marshalling"
"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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -10,6 +10,13 @@ HELP: <buffer-ptr>
}
{ $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 }
@ -52,6 +59,7 @@ HELP: buffer-kind
{ "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." } ;
@ -62,6 +70,30 @@ HELP: buffer-ptr
{ { $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
@ -148,6 +180,10 @@ HELP: stream-upload
{ 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 } }
@ -157,7 +193,7 @@ HELP: update-buffer
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
@ -165,7 +201,7 @@ HELP: with-mapped-buffer
}
{ $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 } "." } ;
@ -183,6 +219,7 @@ ARTICLE: "gpu.buffers" "Buffer objects"
{ $subsection buffer-usage-pattern }
"Referencing buffer data:"
{ $subsection buffer-ptr }
{ $subsection buffer-range }
"Manipulating buffer data:"
{ $subsection allocate-buffer }
{ $subsection update-buffer }

View File

@ -15,7 +15,8 @@ VARIANT: buffer-access-mode
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 }
@ -52,8 +53,15 @@ TUPLE: buffer < gpu-object
{ 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
@ -64,11 +72,22 @@ TUPLE: buffer-ptr
{ 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 )
@ -81,15 +100,13 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ;
:: 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 ;
@ -102,9 +119,7 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ;
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

View File

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

View File

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

View File

@ -34,20 +34,13 @@ HELP: <multi-index-range>
}
{ $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
@ -55,34 +48,40 @@ $nl
{ { $link float-uniform } "s take their values from Factor " { $link float } "s." }
{ { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
{ { $link texture-uniform } "s take their values from " { $link texture } " objects." }
{ "Vector uniforms are passed as Factor " { $link sequence } "s of the corresponding component type." }
{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } }
{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type."
{ $list
{ "Float vector types: " { $link vec2-uniform } ", " { $link vec3-uniform } ", " { $link vec4-uniform } }
{ "Integer vector types: " { $link ivec2-uniform } ", " { $link ivec3-uniform } ", " { $link ivec4-uniform } }
{ "Unsigned integer vector types: " { $link uvec2-uniform } ", " { $link uvec3-uniform } ", " { $link uvec4-uniform } }
{ "Boolean vector types: " { $link bvec2-uniform } ", " { $link bvec3-uniform } ", " { $link bvec4-uniform } }
}
}
{ "Matrix uniforms take their values from row-major Factor " { $link sequence } "s of sequences of floats. Matrix types are:"
{ $list
{ { $link mat2-uniform } ", " { $link mat2x3-uniform } ", " { $link mat2x4-uniform } }
{ { $link mat3x2-uniform } ", " { $link mat3-uniform } ", " { $link mat3x4-uniform } }
{ { $link mat4x2-uniform } ", " { $link mat4x3-uniform } ", " { $link mat4-uniform } }
}
"Rectangular matrix type names are column x row."
}
{ "Uniform slots can also be defined as other " { $snippet "uniform-tuple" } " types to bind uniform structures. The uniform structure will take its value from the slots of a tuple of the given type." }
{ "Array uniforms are passed as Factor sequences of the corresponding value type above." }
}
$nl
"A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors."
} ;
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." } ;
{ vertex-array <vertex-array> buffer>vertex-array } related-words
HELP: bvec3-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component boolean vector uniform parameter." } ;
HELP: bvec4-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component boolean vector uniform parameter." } ;
HELP: define-uniform-tuple
{ $values
@ -90,22 +89,8 @@ HELP: define-uniform-tuple
}
{ $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
@ -130,7 +115,7 @@ HELP: index-type
{ index-type ubyte-indexes ushort-indexes uint-indexes } related-words
HELP: int-uniform
{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "int" } "s." } ;
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a signed integer uniform parameter." } ;
HELP: invalid-uniform-type
{ $values
@ -138,6 +123,15 @@ HELP: invalid-uniform-type
}
{ $description "Throws an error indicating that a slot of a " { $link uniform-tuple } " has been declared to have an invalid type." } ;
HELP: ivec2-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component integer vector uniform parameter." } ;
HELP: ivec3-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component integer vector uniform parameter." } ;
HELP: ivec4-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component integer vector uniform parameter." } ;
HELP: lines-mode
{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a line from each pair of indexed vertex array elements." } ;
@ -147,6 +141,33 @@ HELP: line-loop-mode
HELP: line-strip-mode
{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected strip of lines from each consecutive pair of indexed vertex array elements." } ;
HELP: mat2-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2x2 square float matrix uniform parameter." } ;
HELP: mat2x3-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 3-row float matrix uniform parameter." } ;
HELP: mat2x4-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 4-row float matrix uniform parameter." } ;
HELP: mat3x2-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 2-row float matrix uniform parameter." } ;
HELP: mat3-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3x3 square float matrix uniform parameter." } ;
HELP: mat3x4-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 4-row float matrix uniform parameter." } ;
HELP: mat4x2-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 2-row float matrix uniform parameter." } ;
HELP: mat4x3-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 3-row float matrix uniform parameter." } ;
HELP: mat4-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4x4 square float matrix uniform parameter." } ;
HELP: multi-index-elements
{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple arrays of indexes in CPU or GPU memory."
{ $list
@ -193,14 +214,16 @@ HELP: render-set
{ "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." } ;
@ -218,7 +241,7 @@ HELP: uint-indexes
{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of four-byte unsigned int indexes." } ;
HELP: uint-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a scalar or vector of unsigned integers." } ;
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to an unsigned integer uniform parameter." } ;
HELP: uniform
{ $class-description "Values of this tuple type are passed to " { $link define-uniform-tuple } " to define a new " { $link uniform-tuple } " type." } ;
@ -229,35 +252,28 @@ HELP: uniform-tuple
HELP: uniform-type
{ $class-description { $snippet "uniform-type" } " values are used as part of a " { $link POSTPONE: UNIFORM-TUPLE: } " definition to define the types of uniform slots." } ;
{ uniform-type bool-uniform int-uniform float-uniform texture-uniform uint-uniform } related-words
HELP: ushort-indexes
{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of two-byte unsigned short indexes." } ;
{ index-type ubyte-indexes ushort-indexes uint-indexes } related-words
HELP: 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."
@ -272,11 +288,6 @@ ARTICLE: "gpu.render" "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: }
;

View File

@ -0,0 +1,117 @@
USING: accessors combinators gpu.render gpu.render.private kernel sequences tools.test ;
IN: gpu.render.tests
UNIFORM-TUPLE: two-textures
{ "argyle" texture-uniform f }
{ "thread-count" float-uniform f }
{ "tweed" texture-uniform f } ;
UNIFORM-TUPLE: inherited-textures < two-textures
{ "paisley" texture-uniform f } ;
UNIFORM-TUPLE: array-of-textures < two-textures
{ "plaids" texture-uniform 4 } ;
UNIFORM-TUPLE: struct-containing-texture
{ "threads" two-textures f } ;
UNIFORM-TUPLE: array-of-struct-containing-texture
{ "threads" inherited-textures 3 } ;
UNIFORM-TUPLE: array-of-struct-containing-array-of-texture
{ "threads" array-of-textures 2 } ;
[ 1 ] [ texture-uniform uniform-type-texture-units ] unit-test
[ 0 ] [ float-uniform uniform-type-texture-units ] unit-test
[ 2 ] [ two-textures uniform-type-texture-units ] unit-test
[ 3 ] [ inherited-textures uniform-type-texture-units ] unit-test
[ 6 ] [ array-of-textures uniform-type-texture-units ] unit-test
[ 2 ] [ struct-containing-texture uniform-type-texture-units ] unit-test
[ 9 ] [ array-of-struct-containing-texture uniform-type-texture-units ] unit-test
[ 12 ] [ array-of-struct-containing-array-of-texture uniform-type-texture-units ] unit-test
[ { [ ] } ] [ texture-uniform f uniform-texture-accessors ] unit-test
[ { } ] [ float-uniform f uniform-texture-accessors ] unit-test
[ { [ argyle>> ] [ tweed>> ] } ] [ two-textures f uniform-texture-accessors ] unit-test
[ { [ argyle>> ] [ tweed>> ] [ paisley>> ] } ]
[ inherited-textures f uniform-texture-accessors ] unit-test
[ {
[ argyle>> ]
[ tweed>> ]
[ plaids>> {
[ 0 swap nth ]
[ 1 swap nth ]
[ 2 swap nth ]
[ 3 swap nth ]
} ]
} ] [ array-of-textures f uniform-texture-accessors ] unit-test
[ {
[ threads>> {
[ argyle>> ]
[ tweed>> ]
} ]
} ] [ struct-containing-texture f uniform-texture-accessors ] unit-test
[ {
[ threads>> {
[ 0 swap nth {
[ argyle>> ]
[ tweed>> ]
[ paisley>> ]
} ]
[ 1 swap nth {
[ argyle>> ]
[ tweed>> ]
[ paisley>> ]
} ]
[ 2 swap nth {
[ argyle>> ]
[ tweed>> ]
[ paisley>> ]
} ]
} ]
} ] [ array-of-struct-containing-texture f uniform-texture-accessors ] unit-test
[ {
[ threads>> {
[ 0 swap nth {
[ argyle>> ]
[ tweed>> ]
[ plaids>> {
[ 0 swap nth ]
[ 1 swap nth ]
[ 2 swap nth ]
[ 3 swap nth ]
} ]
} ]
[ 1 swap nth {
[ argyle>> ]
[ tweed>> ]
[ plaids>> {
[ 0 swap nth ]
[ 1 swap nth ]
[ 2 swap nth ]
[ 3 swap nth ]
} ]
} ]
} ]
} ] [ array-of-struct-containing-array-of-texture f uniform-texture-accessors ] unit-test
[ [
nip {
[ argyle>> 0 (bind-texture-unit) ]
[ tweed>> 1 (bind-texture-unit) ]
[ plaids>> {
[ 0 swap nth 2 (bind-texture-unit) ]
[ 1 swap nth 3 (bind-texture-unit) ]
[ 2 swap nth 4 (bind-texture-unit) ]
[ 3 swap nth 5 (bind-texture-unit) ]
} cleave ]
} cleave
] ] [ array-of-textures [bind-uniform-textures] ] unit-test

View File

@ -1,37 +1,59 @@
! (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
@ -50,8 +72,6 @@ TUPLE: multi-index-range
C: <multi-index-range> multi-index-range
UNION: ?integer integer POSTPONE: f ;
TUPLE: index-elements
{ ptr gpu-data-ptr read-only }
{ count integer read-only }
@ -84,52 +104,12 @@ VARIANT: primitive-mode
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 ] }
@ -180,58 +160,8 @@ M: multi-index-elements render-vertex-indexes
bi*
GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
: (bind-texture-unit) ( texture-unit texture -- )
[ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
:: [bind-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 -- )
@ -242,96 +172,204 @@ M: uniform-tuple bind-uniforms
2drop ;
: uniform-slot-type ( uniform -- type )
dup dim>> 1 = [
dup dim>> [ drop sequence ] [
uniform-type>> {
{ bool-uniform [ boolean ] }
{ uint-uniform [ integer ] }
{ int-uniform [ integer ] }
{ float-uniform [ float ] }
{ texture-uniform [ texture ] }
[ drop sequence ]
} case
] [ drop sequence ] if ;
] if ;
: uniform>slot ( uniform -- slot )
[ name>> ] [ uniform-slot-type ] bi 2array ;
:: [bind-uniform-texture] ( uniform index -- quot )
uniform name>> reader-word :> value>>-word
{ index swap value>>-word (bind-texture-unit) } >quotation ;
: uniform-type-texture-units ( uniform-type -- units )
dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
:: [bind-uniform-textures] ( superclass uniforms -- quot )
superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
superclass \ bind-uniform-textures method :> next-method
uniforms
[ uniform-type>> texture-uniform = ] filter
[ first-texture-unit + [bind-uniform-texture] ] map-index
:> texture-uniforms-cleave
: all-uniform-tuple-slots ( class -- slots )
dup "uniform-tuple-slots" word-prop
[ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
{
2dup next-method
nip texture-uniforms-cleave cleave
} >quotation ;
DEFER: uniform-texture-accessors
:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
uniform name>> :> name
: uniform-type-texture-accessors ( uniform-type -- accessors )
texture-uniform = [ { [ ] } ] [ { } ] if ;
: uniform-slot-texture-accessor ( uniform -- accessor )
[ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi
dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ;
: uniform-tuple-texture-accessors ( uniform-type -- accessors )
all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter
[ uniform-slot-texture-accessor ] map ;
: uniform-texture-accessors ( uniform-type dim -- accessors )
[
dup uniform-type?
[ uniform-type-texture-accessors ]
[ uniform-tuple-texture-accessors ] if
] [
2dup swap empty? not and [
iota [
[ swap nth ] swap prefix
over length 1 = [ swap first append ] [ swap suffix ] if
] with map
] [ drop ] if
] bi* ;
: texture-accessor>cleave ( unit accessors -- unit' cleaves )
dup last sequence?
[ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
[ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
: [bind-uniform-textures] ( class -- quot )
f uniform-texture-accessors
0 swap [ texture-accessor>cleave ] map nip
\ nip swap \ cleave [ ] 3sequence ;
DEFER: [bind-uniform-tuple]
:: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
{ name uniform-index } >quotation :> index-quot
uniform name>> reader-word 1quotation :> value>>-quot
{ index-quot value>>-quot bi* } >quotation :> pre-quot
uniform [ uniform-type>> ] [ dim>> ] bi 2array H{
{ { bool-uniform 1 } [ >c-bool glUniform1i ] }
{ { int-uniform 1 } [ glUniform1i ] }
{ { uint-uniform 1 } [ glUniform1ui ] }
{ { float-uniform 1 } [ glUniform1f ] }
type H{
{ bool-uniform { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv } }
{ int-uniform { dim swap >int-array glUniform1iv } }
{ uint-uniform { dim swap >uint-array glUniform1uiv } }
{ float-uniform { dim swap >float-array glUniform1fv } }
{ { bool-uniform 2 } [ [ >c-bool ] map first2 glUniform2i ] }
{ { int-uniform 2 } [ first2 glUniform2i ] }
{ { uint-uniform 2 } [ first2 glUniform2ui ] }
{ { float-uniform 2 } [ first2 glUniform2f ] }
{ bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv } }
{ ivec2-uniform { dim swap int-array{ } concat-as glUniform2i } }
{ uvec2-uniform { dim swap uint-array{ } concat-as glUniform2ui } }
{ vec2-uniform { dim swap float-array{ } concat-as glUniform2f } }
{ { bool-uniform 3 } [ [ >c-bool ] map first3 glUniform3i ] }
{ { int-uniform 3 } [ first3 glUniform3i ] }
{ { uint-uniform 3 } [ first3 glUniform3ui ] }
{ { float-uniform 3 } [ first3 glUniform3f ] }
{ bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv } }
{ ivec3-uniform { dim swap int-array{ } concat-as glUniform3i } }
{ uvec3-uniform { dim swap uint-array{ } concat-as glUniform3ui } }
{ vec3-uniform { dim swap float-array{ } concat-as glUniform3f } }
{ { bool-uniform 4 } [ [ >c-bool ] map first4 glUniform4i ] }
{ { int-uniform 4 } [ first4 glUniform4i ] }
{ { uint-uniform 4 } [ first4 glUniform4ui ] }
{ { float-uniform 4 } [ first4 glUniform4f ] }
{ bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv } }
{ ivec4-uniform { dim swap int-array{ } concat-as glUniform4iv } }
{ uvec4-uniform { dim swap uint-array{ } concat-as glUniform4uiv } }
{ vec4-uniform { dim swap float-array{ } concat-as glUniform4fv } }
{ { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv ] }
{ { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] }
{ { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] }
{ mat2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv } }
{ mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } }
{ mat2x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x4fv } }
{ mat3x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x2fv } }
{ mat3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3fv } }
{ mat3x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x4fv } }
{ mat4x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x2fv } }
{ mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } }
{ mat4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv } }
{ { float-uniform { 2 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x2fv ] }
{ { float-uniform { 3 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3fv ] }
{ { float-uniform { 4 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x4fv ] }
{ { float-uniform { 2 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x2fv ] }
{ { float-uniform { 3 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x3fv ] }
{ { float-uniform { 4 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4fv ] }
{ { texture-uniform 1 } { drop texture-unit glUniform1i } }
{ texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
} at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
uniform uniform-type>> texture-uniform =
[ texture-unit 1 + ] [ texture-unit ] if
type uniform-type-texture-units dim * texture-unit +
pre-quot value-quot append ;
:: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot )
{ name uniform-index } >quotation :> index-quot
{ index-quot value>>-quot bi* } >quotation :> pre-quot
type H{
{ bool-uniform [ >c-bool glUniform1i ] }
{ int-uniform [ glUniform1i ] }
{ uint-uniform [ glUniform1ui ] }
{ float-uniform [ glUniform1f ] }
{ bvec2-uniform [ [ >c-bool ] map first2 glUniform2i ] }
{ ivec2-uniform [ first2 glUniform2i ] }
{ uvec2-uniform [ first2 glUniform2ui ] }
{ vec2-uniform [ first2 glUniform2f ] }
{ bvec3-uniform [ [ >c-bool ] map first3 glUniform3i ] }
{ ivec3-uniform [ first3 glUniform3i ] }
{ uvec3-uniform [ first3 glUniform3ui ] }
{ vec3-uniform [ first3 glUniform3f ] }
{ bvec4-uniform [ [ >c-bool ] map first4 glUniform4i ] }
{ ivec4-uniform [ first4 glUniform4i ] }
{ uvec4-uniform [ first4 glUniform4ui ] }
{ vec4-uniform [ first4 glUniform4f ] }
{ mat2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2fv ] }
{ mat2x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x3fv ] }
{ mat2x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x4fv ] }
{ mat3x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x2fv ] }
{ mat3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3fv ] }
{ mat3x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x4fv ] }
{ mat4x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x2fv ] }
{ mat4x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x3fv ] }
{ mat4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4fv ] }
{ texture-uniform { drop texture-unit glUniform1i } }
} at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
type uniform-type-texture-units texture-unit +
pre-quot value-quot append ;
:: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
dim
[
iota
[ [ [ swap nth ] swap prefix ] map ]
[ [ number>string name "[" append "]." surround ] map ] bi
] [
{ [ ] }
name "." append 1array
] if* :> name-prefixes :> quot-prefixes
type all-uniform-tuple-slots :> uniforms
texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
uniforms name-prefix [bind-uniform-tuple]
quot-prefix prepend
] 2map :> value-cleave :> texture-unit'
texture-unit'
value>>-quot { value-cleave 2cleave } append ;
TR: hyphens>underscores "-" "_" ;
:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
prefix uniform name>> append hyphens>underscores :> name
uniform uniform-type>> :> type
uniform dim>> :> dim
uniform name>> reader-word 1quotation :> value>>-quot
value>>-quot type texture-unit name {
{ [ type uniform-type? dim and ] [ dim [bind-uniform-array] ] }
{ [ type uniform-type? dim not and ] [ [bind-uniform-value] ] }
[ dim [bind-uniform-struct] ]
} cond ;
:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
texture-unit'
{ uniforms-cleave 2cleave } >quotation ;
:: [bind-uniforms] ( superclass uniforms -- quot )
superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
superclass \ bind-uniforms method :> next-method
first-texture-unit uniforms [ [bind-uniform] ] map nip :> uniforms-cleave
{
2dup next-method
uniforms-cleave 2cleave
} >quotation ;
first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
{ 2dup next-method } bind-quot [ ] append-as ;
: define-uniform-tuple-methods ( class superclass uniforms -- )
[
[ \ bind-uniform-textures create-method-in ] 2dip
[bind-uniform-textures] define
2drop
[ \ bind-uniform-textures create-method-in ]
[ [bind-uniform-textures] ] bi define
] [
[ \ bind-uniforms create-method-in ] 2dip
[bind-uniforms] define
@ -348,110 +386,32 @@ M: uniform-tuple bind-uniforms
] }
} 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 -- )
@ -471,16 +431,52 @@ M: vertex-array dispose
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 -- )
{
@ -489,7 +485,11 @@ TUPLE: 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>> ]
@ -497,10 +497,20 @@ TUPLE: render-set
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

View File

@ -3,10 +3,22 @@ IN: gpu.shaders.prettyprint
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 ;

View File

@ -1,5 +1,6 @@
! (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>
@ -16,9 +17,17 @@ HELP: <shader-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\"" }
@ -32,6 +41,18 @@ shader source
; "> }
{ $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
@ -41,6 +62,15 @@ 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
@ -48,6 +78,18 @@ HELP: compile-shader-error
{ "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." } ;
@ -93,6 +135,15 @@ HELP: shader-kind
{ { $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 }
@ -103,6 +154,29 @@ HELP: uniform-index
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: }
@ -111,6 +185,11 @@ ARTICLE: "gpu.shaders" "Shader objects"
"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"

View File

@ -1,17 +1,35 @@
! (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 }
@ -25,6 +43,7 @@ TUPLE: program
{ 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
@ -35,8 +54,206 @@ TUPLE: program-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 ;
@ -69,6 +286,49 @@ TUPLE: program-instance < gpu-object
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 ;
@ -82,13 +342,6 @@ 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 -- ? )
@ -101,10 +354,12 @@ MEMO: output-index ( program-instance output-name -- index )
[ 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) ;
@ -139,6 +394,14 @@ MEMO: output-index ( program-instance output-name -- index )
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 -- )
@ -191,7 +454,7 @@ SYNTAX: GLSL-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 ;

View File

@ -151,7 +151,7 @@ M: cube-map-face texture-data-gl-target
: 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 )

View File

@ -1,5 +1,5 @@
! (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

View File

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