-! (c)2009 Joe Groff bsd license
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs byte-arrays classes.mixin classes.parser
-classes.singleton classes.struct combinators combinators.short-circuit
-definitions destructors fry generic.parser gpu gpu.buffers gpu.private
-gpu.state hashtables images io.encodings.ascii io.files io.pathnames
-kernel lexer literals locals math math.parser memoize multiline namespaces
+classes.singleton classes.struct combinators
+combinators.short-circuit definitions destructors generic.parser
+gpu gpu.buffers gpu.private gpu.state hashtables images
+io.encodings.ascii io.files io.pathnames kernel lexer literals
+math math.floats.half math.parser memoize multiline namespaces
opengl opengl.gl opengl.shaders parser quotations sequences
-specialized-arrays splitting strings tr ui.gadgets.worlds
-variants vectors vocabs vocabs.loader vocabs.parser words
-words.constant math.floats.half typed ;
+specialized-arrays splitting strings tr typed ui.gadgets.worlds
+variants vocabs.loader words words.constant ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: void*
line-strips-output
triangle-strips-output ;
-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 } ;
+ { name maybe{ 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 }
{ line integer read-only }
{ shaders array read-only }
{ vertex-formats array read-only }
- { feedback-format ?vertex-format read-only }
+ { feedback-format maybe{ vertex-format } read-only }
{ geometry-shader-parameters array read-only }
{ instances hashtable read-only } ;
[ handle>> ] dip glGetFragDataLocation ;
: vertex-format-attributes ( vertex-format -- attributes )
- "vertex-format-attributes" word-prop ; inline
+ "vertex-format-attributes" word-prop ; inline
<PRIVATE
{ uint-integer-components [ GL_UNSIGNED_INT ] }
} case ;
-: vertex-type-size ( component-type -- size )
+: vertex-type-size ( component-type -- size )
{
{ ubyte-components [ 1 ] }
{ ushort-components [ 2 ] }
:: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
{
- [ vertex-attribute name>> name = ]
+ [ vertex-attribute name>> name = ]
[ size 1 = ]
[ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
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 ;
+ { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
:: [link-feedback-format] ( vertex-attributes -- quot )
vertex-attributes [ name>> not ] any?
name length 1 + :> name-buffer-length
{
index name-buffer-length dup
- [ f 0 <int> 0 <int> ] dip <byte-array>
+ [ f 0 int <ref> 0 int <ref> ] dip <byte-array>
[ glGetTransformFeedbackVarying ] 3keep
ascii alien>string
- vertex-attribute assert-feedback-attribute
+ vertex-attribute assert-feedback-attribute
} >quotation ;
:: [verify-feedback-format] ( vertex-attributes -- quot )
: link-vertex-formats ( program-handle formats -- )
[ vertex-format-attributes [ name>> ] map sift ] map concat
- swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
+ swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
GENERIC: link-geometry-shader-parameter ( program-handle parameter -- )
{ } <struct-slot-spec> ;
: shader-filename ( shader/program -- filename )
- dup filename>> [ nip ] [ name>> where first ] if* file-name ;
+ dup filename>> [ ] [ name>> where first ] ?if file-name ;
: numbered-log-line? ( log-line-components -- ? )
{
] [ nip ] if ":" join ;
: replace-log-line-numbers ( object log -- log' )
- "\n" split harvest
+ split-lines harvest
[ replace-log-line-number ] with map
- "\n" join ;
+ join-lines ;
: gl-shader-kind ( shader-kind -- shader-kind )
{
[ "vertex-format-attributes" set-word-prop ] 2bi ;
SYNTAX: VERTEX-FORMAT:
- CREATE-CLASS parse-definition
+ scan-new-class parse-definition
[ first4 vertex-attribute boa ] map
define-vertex-format ;
define-struct-class ;
SYNTAX: VERTEX-STRUCT:
- CREATE-CLASS scan-word define-vertex-struct ;
+ scan-new-class scan-word define-vertex-struct ;
TUPLE: vertex-array-object < gpu-object
{ program-instance program-instance read-only }
'[ _ swap first2 bind-vertex-format ] each ; inline
: (reset-vertex-array) ( -- )
- GL_MAX_VERTEX_ATTRIBS get-gl-int iota [ glDisableVertexAttribArray ] each ; inline
+ GL_MAX_VERTEX_ATTRIBS get-gl-int <iota> [ glDisableVertexAttribArray ] each ; inline
:: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
gen-vertex-array :> handle
has-vertex-array-objects? get
[ <multi-vertex-array-object> ]
[ <multi-vertex-array-collection> ] if ; inline
-
+
: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
has-vertex-array-objects? get
[ <vertex-array-object> ]
TUPLE: compile-shader-error shader log ;
TUPLE: link-program-error program log ;
-: compile-shader-error ( shader instance -- * )
- [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
- \ compile-shader-error boa throw ;
+: throw-compile-shader-error ( shader instance -- * )
+ [ dup ] dip [ gl-shader-info-log ] [ glDeleteShader ] bi
+ replace-log-line-numbers compile-shader-error boa throw ;
-: link-program-error ( program instance -- * )
- [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
- \ link-program-error boa throw ;
+: throw-link-program-error ( program instance -- * )
+ [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi
+ replace-log-line-numbers link-program-error boa throw ;
DEFER: <shader-instance>
[ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
dup gl-shader-ok?
[ swap world get \ shader-instance boa window-resource ]
- [ compile-shader-error ] if ;
+ [ throw-compile-shader-error ] if ;
: (link-program) ( program shader-instances -- program-instance )
'[ _ [ handle>> ] map ]
dup gl-program-ok? [
[ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
with-destructors window-resource
- ] [ link-program-error ] if ;
+ ] [ throw-link-program-error ] if ;
: link-program ( program -- program-instance )
dup shaders>> [ <shader-instance> ] map (link-program) ;
+: word-directory ( word -- directory )
+ where first parent-directory ;
+
: in-word's-path ( word kind filename -- word kind filename' )
- [ over ] dip [ where first parent-directory ] dip append-path ;
+ pick word-directory prepend-path ;
: become-shader-instance ( shader-instance new-shader-instance -- )
- handle>> [ swap delete-gl-shader ] curry change-handle drop ;
+ handle>> [ swap glDeleteShader ] curry change-handle drop ;
: refresh-shader-source ( shader -- )
dup filename>>
[ drop ] if* ;
: become-program-instance ( program-instance new-program-instance -- )
- handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
+ handle>> [ swap glDeleteProgram ] curry change-handle drop ;
: reset-memos ( -- )
\ uniform-index reset-memoized
[ nip ] [ drop link-program ] if ;
TUPLE: feedback-format
- { vertex-format ?vertex-format read-only } ;
+ { vertex-format maybe{ vertex-format } read-only } ;
: validate-feedback-format ( sequence -- vertex-format/f )
dup length 1 <=
PRIVATE>
SYNTAX: GLSL-SHADER:
- CREATE dup
+ scan-new dup
dup old-instances [
scan-word
f
define-constant ;
SYNTAX: GLSL-SHADER-FILE:
- CREATE dup
+ scan-new dup
dup old-instances [
scan-word execute( -- kind )
scan-object in-word's-path
0
- over ascii file-contents
+ over ascii file-contents
] dip
shader boa
over reset-generic
define-constant ;
SYNTAX: GLSL-PROGRAM:
- CREATE dup
+ scan-new dup
dup old-instances [
f
lexer get line>>
- \ ; parse-until >array shaders-and-formats
+ parse-array-def shaders-and-formats
] dip
program boa
over reset-generic
define-constant ;
M: shader-instance dispose
- [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
+ [ dup valid-handle? [ glDeleteShader ] [ drop ] if f ] change-handle
[ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
M: program-instance dispose
- [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
+ [ dup valid-handle? [ glDeleteProgram ] [ drop ] if f ] change-handle
[ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
reset-memos ;