1 ! Copyright (C) 2009 Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.data alien.strings
4 arrays assocs byte-arrays classes.mixin classes.parser
5 classes.singleton classes.struct combinators combinators.short-circuit
6 definitions destructors fry generic.parser gpu gpu.buffers gpu.private
7 gpu.state hashtables images io.encodings.ascii io.files io.pathnames
8 kernel lexer literals locals math math.parser memoize multiline namespaces
9 opengl opengl.gl opengl.shaders parser quotations sequences
10 specialized-arrays splitting strings tr ui.gadgets.worlds
11 variants vectors vocabs vocabs.loader vocabs.parser words
12 words.constant math.floats.half typed ;
13 QUALIFIED-WITH: alien.c-types c
14 SPECIALIZED-ARRAY: int
15 SPECIALIZED-ARRAY: void*
19 vertex-shader fragment-shader geometry-shader ;
21 VARIANT: geometry-shader-input
24 lines-with-adjacency-input
26 triangles-with-adjacency-input ;
27 VARIANT: geometry-shader-output
30 triangle-strips-output ;
32 ERROR: too-many-feedback-formats-error formats ;
33 ERROR: invalid-link-feedback-format-error format ;
34 ERROR: inaccurate-feedback-attribute-error attribute ;
36 TUPLE: vertex-attribute
37 { name maybe{ string } read-only initial: f }
38 { component-type component-type read-only initial: float-components }
39 { dim integer read-only initial: 4 }
40 { normalize? boolean read-only initial: f } ;
45 { name word read-only initial: t }
46 { kind shader-kind read-only }
47 { filename read-only }
48 { line integer read-only }
50 { instances hashtable read-only } ;
53 { name word read-only initial: t }
54 { filename read-only }
55 { line integer read-only }
56 { shaders array read-only }
57 { vertex-formats array read-only }
58 { feedback-format maybe{ vertex-format } read-only }
59 { geometry-shader-parameters array read-only }
60 { instances hashtable read-only } ;
62 TUPLE: shader-instance < gpu-object
66 TUPLE: program-instance < gpu-object
70 GENERIC: vertex-format-size ( format -- size )
72 MEMO: uniform-index ( program-instance uniform-name -- index )
73 [ handle>> ] dip glGetUniformLocation ;
74 MEMO: attribute-index ( program-instance attribute-name -- index )
75 [ handle>> ] dip glGetAttribLocation ;
76 MEMO: output-index ( program-instance output-name -- index )
77 [ handle>> ] dip glGetFragDataLocation ;
79 : vertex-format-attributes ( vertex-format -- attributes )
80 "vertex-format-attributes" word-prop ; inline
84 TR: hyphens>underscores "-" "_" ;
86 : gl-vertex-type ( component-type -- gl-type )
88 { ubyte-components [ GL_UNSIGNED_BYTE ] }
89 { ushort-components [ GL_UNSIGNED_SHORT ] }
90 { uint-components [ GL_UNSIGNED_INT ] }
91 { half-components [ GL_HALF_FLOAT ] }
92 { float-components [ GL_FLOAT ] }
93 { byte-integer-components [ GL_BYTE ] }
94 { short-integer-components [ GL_SHORT ] }
95 { int-integer-components [ GL_INT ] }
96 { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
97 { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
98 { uint-integer-components [ GL_UNSIGNED_INT ] }
101 : vertex-type-size ( component-type -- size )
103 { ubyte-components [ 1 ] }
104 { ushort-components [ 2 ] }
105 { uint-components [ 4 ] }
106 { half-components [ 2 ] }
107 { float-components [ 4 ] }
108 { byte-integer-components [ 1 ] }
109 { short-integer-components [ 2 ] }
110 { int-integer-components [ 4 ] }
111 { ubyte-integer-components [ 1 ] }
112 { ushort-integer-components [ 2 ] }
113 { uint-integer-components [ 4 ] }
116 : vertex-attribute-size ( vertex-attribute -- size )
117 [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
119 : vertex-attributes-size ( vertex-attributes -- size )
120 [ vertex-attribute-size ] [ + ] map-reduce ;
122 : feedback-type= ( component-type dim gl-type -- ? )
124 { $ GL_FLOAT [ { float-components 1 } ] }
125 { $ GL_FLOAT_VEC2 [ { float-components 2 } ] }
126 { $ GL_FLOAT_VEC3 [ { float-components 3 } ] }
127 { $ GL_FLOAT_VEC4 [ { float-components 4 } ] }
128 { $ GL_INT [ { int-integer-components 1 } ] }
129 { $ GL_INT_VEC2 [ { int-integer-components 2 } ] }
130 { $ GL_INT_VEC3 [ { int-integer-components 3 } ] }
131 { $ GL_INT_VEC4 [ { int-integer-components 4 } ] }
132 { $ GL_UNSIGNED_INT [ { uint-integer-components 1 } ] }
133 { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
134 { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
135 { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
138 :: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
140 [ vertex-attribute name>> name = ]
142 [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
143 } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
145 :: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
146 program-instance name attribute-index :> idx
148 idx glEnableVertexAttribArray
149 idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
152 :: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
153 program-instance name attribute-index :> idx
155 idx glEnableVertexAttribArray
156 idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
159 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
160 vertex-attribute name>> hyphens>underscores :> name
161 vertex-attribute component-type>> :> type
162 type gl-vertex-type :> gl-type
163 vertex-attribute dim>> :> dim
164 vertex-attribute normalize?>> >c-bool :> normalize?
165 vertex-attribute vertex-attribute-size :> size
169 { [ name not ] [ [ 2drop ] ] }
171 [ type unnormalized-integer-components? ]
172 [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
174 [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
177 :: [bind-vertex-format] ( vertex-attributes -- quot )
178 vertex-attributes vertex-attributes-size :> stride
179 stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
180 { attributes-cleave 2cleave } >quotation :> with-block
182 { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
184 :: [link-feedback-format] ( vertex-attributes -- quot )
185 vertex-attributes [ name>> not ] any?
186 [ [ nip invalid-link-feedback-format-error ] ] [
188 [ name>> ascii malloc-string ]
189 void*-array{ } map-as :> varying-names
190 vertex-attributes length :> varying-count
191 { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
195 :: [verify-feedback-attribute] ( vertex-attribute index -- quot )
196 vertex-attribute name>> :> name
197 name length 1 + :> name-buffer-length
199 index name-buffer-length dup
200 [ f 0 int <ref> 0 int <ref> ] dip <byte-array>
201 [ glGetTransformFeedbackVarying ] 3keep
203 vertex-attribute assert-feedback-attribute
206 :: [verify-feedback-format] ( vertex-attributes -- quot )
207 vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
208 { drop verify-cleave cleave } >quotation ;
210 : gl-geometry-shader-input ( input -- input )
212 { points-input [ GL_POINTS ] }
213 { lines-input [ GL_LINES ] }
214 { lines-with-adjacency-input [ GL_LINES_ADJACENCY ] }
215 { triangles-input [ GL_TRIANGLES ] }
216 { triangles-with-adjacency-input [ GL_TRIANGLES_ADJACENCY ] }
219 : gl-geometry-shader-output ( output -- output )
221 { points-output [ GL_POINTS ] }
222 { line-strips-output [ GL_LINE_STRIP ] }
223 { triangle-strips-output [ GL_TRIANGLE_STRIP ] }
226 TUPLE: geometry-shader-vertices-out
227 { count integer read-only } ;
229 UNION: geometry-shader-parameter
230 geometry-shader-input
231 geometry-shader-output
232 geometry-shader-vertices-out ;
235 GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
237 GENERIC: link-feedback-format ( program-handle format -- )
239 M: f link-feedback-format
242 : link-vertex-formats ( program-handle formats -- )
243 [ vertex-format-attributes [ name>> ] map sift ] map concat
244 swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
246 GENERIC: link-geometry-shader-parameter ( program-handle parameter -- )
248 M: geometry-shader-input link-geometry-shader-parameter
249 [ GL_GEOMETRY_INPUT_TYPE ] dip gl-geometry-shader-input glProgramParameteriARB ;
250 M: geometry-shader-output link-geometry-shader-parameter
251 [ GL_GEOMETRY_OUTPUT_TYPE ] dip gl-geometry-shader-output glProgramParameteriARB ;
252 M: geometry-shader-vertices-out link-geometry-shader-parameter
253 [ GL_GEOMETRY_VERTICES_OUT ] dip count>> glProgramParameteriARB ;
255 : link-geometry-shader-parameters ( program-handle parameters -- )
256 [ link-geometry-shader-parameter ] with each ;
258 GENERIC: (verify-feedback-format) ( program-instance format -- )
260 M: f (verify-feedback-format)
263 : verify-feedback-format ( program-instance -- )
264 dup program>> feedback-format>> (verify-feedback-format) ;
266 : define-vertex-format-methods ( class vertex-attributes -- )
269 [ \ bind-vertex-format create-method-in ] dip
270 [bind-vertex-format] define
272 [ \ link-feedback-format create-method-in ] dip
273 [link-feedback-format] define
275 [ \ (verify-feedback-format) create-method-in ] dip
276 [verify-feedback-format] define
278 [ \ vertex-format-size create-method-in ] dip
279 [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
283 : component-type>c-type ( component-type -- c-type )
285 { ubyte-components [ c:uchar ] }
286 { ushort-components [ c:ushort ] }
287 { uint-components [ c:uint ] }
288 { half-components [ half ] }
289 { float-components [ c:float ] }
290 { byte-integer-components [ c:char ] }
291 { ubyte-integer-components [ c:uchar ] }
292 { short-integer-components [ c:short ] }
293 { ushort-integer-components [ c:ushort ] }
294 { int-integer-components [ c:int ] }
295 { uint-integer-components [ c:uint ] }
298 : c-array-dim ( type dim -- type' )
299 dup 1 = [ drop ] [ 2array ] if ;
303 : padding-name ( -- name )
305 padding-no counter number>string append
308 : vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
309 [ name>> [ padding-name ] unless* ]
310 [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
311 { } <struct-slot-spec> ;
313 : shader-filename ( shader/program -- filename )
314 dup filename>> [ ] [ name>> where first ] ?if file-name ;
316 : numbered-log-line? ( log-line-components -- ? )
319 [ third string>number ]
322 : replace-log-line-number ( object log-line -- log-line' )
323 ":" split dup numbered-log-line? [
326 [ drop shader-filename " " prepend ]
327 [ [ line>> ] [ third string>number ] bi* + number>string ]
329 } 2cleave [ 3array ] dip append
330 ] [ nip ] if ":" join ;
332 : replace-log-line-numbers ( object log -- log' )
334 [ replace-log-line-number ] with map
337 : gl-shader-kind ( shader-kind -- shader-kind )
339 { vertex-shader [ GL_VERTEX_SHADER ] }
340 { fragment-shader [ GL_FRAGMENT_SHADER ] }
341 { geometry-shader [ GL_GEOMETRY_SHADER ] }
346 : define-vertex-format ( class vertex-attributes -- )
349 [ define-singleton-class ]
350 [ vertex-format add-mixin-instance ]
352 ] [ define-vertex-format-methods ] bi*
354 [ "vertex-format-attributes" set-word-prop ] 2bi ;
356 SYNTAX: VERTEX-FORMAT:
357 scan-new-class parse-definition
358 [ first4 vertex-attribute boa ] map
359 define-vertex-format ;
361 : define-vertex-struct ( class vertex-format -- )
362 vertex-format-attributes [ vertex-attribute>struct-slot ] map
363 define-struct-class ;
365 SYNTAX: VERTEX-STRUCT:
366 scan-new-class scan-word define-vertex-struct ;
368 TUPLE: vertex-array-object < gpu-object
369 { program-instance program-instance read-only }
370 { vertex-buffers sequence read-only } ;
372 TUPLE: vertex-array-collection
373 { vertex-formats sequence read-only }
374 { program-instance program-instance read-only } ;
377 vertex-array-object vertex-array-collection ;
379 M: vertex-array-object dispose
380 [ [ delete-vertex-array ] when* f ] change-handle drop ;
382 : ?>buffer-ptr ( buffer/ptr -- buffer-ptr )
383 dup buffer-ptr? [ 0 <buffer-ptr> ] unless ; inline
384 : ?>buffer ( buffer/ptr -- buffer )
385 dup buffer? [ buffer>> ] unless ; inline
389 : normalize-vertex-formats ( vertex-formats -- vertex-formats' )
390 [ first2 [ ?>buffer-ptr ] dip 2array ] map ; inline
392 : (bind-vertex-array) ( vertex-formats program-instance -- )
393 '[ _ swap first2 bind-vertex-format ] each ; inline
395 : (reset-vertex-array) ( -- )
396 GL_MAX_VERTEX_ATTRIBS get-gl-int <iota> [ glDisableVertexAttribArray ] each ; inline
398 :: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
399 gen-vertex-array :> handle
400 handle glBindVertexArray
402 vertex-formats normalize-vertex-formats program-instance (bind-vertex-array)
404 handle program-instance vertex-formats [ first ?>buffer ] map
405 vertex-array-object boa window-resource ; inline
407 : <multi-vertex-array-collection> ( vertex-formats program-instance -- vertex-array )
408 [ normalize-vertex-formats ] dip vertex-array-collection boa ; inline
410 :: <vertex-array-object> ( vertex-buffer program-instance format -- vertex-array )
411 gen-vertex-array :> handle
412 handle glBindVertexArray
413 program-instance vertex-buffer ?>buffer-ptr format bind-vertex-format
414 handle program-instance vertex-buffer ?>buffer 1array
415 vertex-array-object boa window-resource ; inline
417 : <vertex-array-collection> ( vertex-buffer program-instance format -- vertex-array )
418 swap [ [ ?>buffer-ptr ] dip 2array 1array ] dip <multi-vertex-array-collection> ; inline
422 GENERIC: bind-vertex-array ( vertex-array -- )
424 M: vertex-array-object bind-vertex-array
425 handle>> glBindVertexArray ; inline
427 M: vertex-array-collection bind-vertex-array
429 [ vertex-formats>> ] [ program-instance>> ] bi (bind-vertex-array) ; inline
431 : <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
432 has-vertex-array-objects? get
433 [ <multi-vertex-array-object> ]
434 [ <multi-vertex-array-collection> ] if ; inline
436 : <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
437 has-vertex-array-objects? get
438 [ <vertex-array-object> ]
439 [ <vertex-array-collection> ] if ; inline
441 : <vertex-array> ( vertex-buffer program-instance -- vertex-array )
442 dup program>> vertex-formats>> first <vertex-array*> ; inline
444 GENERIC: vertex-array-buffers ( vertex-array -- buffers )
446 M: vertex-array-object vertex-array-buffers
447 vertex-buffers>> ; inline
449 M: vertex-array-collection vertex-array-buffers
450 vertex-formats>> [ first buffer>> ] map ; inline
452 : vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
453 vertex-array-buffers first ; inline
455 TUPLE: compile-shader-error shader log ;
456 TUPLE: link-program-error program log ;
458 : throw-compile-shader-error ( shader instance -- * )
459 [ dup ] dip [ gl-shader-info-log ] [ glDeleteShader ] bi
460 replace-log-line-numbers compile-shader-error boa throw ;
462 : throw-link-program-error ( program instance -- * )
463 [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi
464 replace-log-line-numbers link-program-error boa throw ;
466 DEFER: <shader-instance>
470 : valid-handle? ( handle -- ? )
471 { [ ] [ zero? not ] } 1&& ;
473 : compile-shader ( shader -- instance )
474 [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
476 [ swap world get \ shader-instance boa window-resource ]
477 [ throw-compile-shader-error ] if ;
479 : (link-program) ( program shader-instances -- program-instance )
480 '[ _ [ handle>> ] map ]
482 [ vertex-formats>> ] [ feedback-format>> ] [ geometry-shader-parameters>> ] tri
484 [ _ link-vertex-formats ]
485 [ _ link-feedback-format ]
486 [ _ link-geometry-shader-parameters ] tri
490 [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
491 with-destructors window-resource
492 ] [ throw-link-program-error ] if ;
494 : link-program ( program -- program-instance )
495 dup shaders>> [ <shader-instance> ] map (link-program) ;
497 : word-directory ( word -- directory )
498 where first parent-directory ;
500 : in-word's-path ( word kind filename -- word kind filename' )
501 pick word-directory prepend-path ;
503 : become-shader-instance ( shader-instance new-shader-instance -- )
504 handle>> [ swap glDeleteShader ] curry change-handle drop ;
506 : refresh-shader-source ( shader -- )
508 [ ascii file-contents >>source drop ]
511 : become-program-instance ( program-instance new-program-instance -- )
512 handle>> [ swap glDeleteProgram ] curry change-handle drop ;
515 \ uniform-index reset-memoized
516 \ attribute-index reset-memoized
517 \ output-index reset-memoized ;
519 : ?delete-at ( key assoc value -- )
520 2over at = [ delete-at ] [ 2drop ] if ;
522 : find-shader-instance ( shader -- instance )
523 world get over instances>> at*
524 [ nip ] [ drop compile-shader ] if ;
526 : find-program-instance ( program -- instance )
527 world get over instances>> at*
528 [ nip ] [ drop link-program ] if ;
530 TUPLE: feedback-format
531 { vertex-format maybe{ vertex-format } read-only } ;
533 : validate-feedback-format ( sequence -- vertex-format/f )
535 [ [ f ] [ first vertex-format>> ] if-empty ]
536 [ too-many-feedback-formats-error ] if ;
538 : ?shader ( object -- shader/f )
539 dup word? [ def>> first dup shader? [ drop f ] unless ] [ drop f ] if ;
541 : shaders-and-formats ( words -- shaders vertex-formats feedback-format geom-parameters )
543 [ [ ?shader ] map sift ]
544 [ [ vertex-format-attributes ] filter ]
545 [ [ feedback-format? ] filter validate-feedback-format ]
546 [ [ geometry-shader-parameter? ] filter ]
551 SYNTAX: feedback-format:
552 scan-object feedback-format boa suffix! ;
553 SYNTAX: geometry-shader-vertices-out:
554 scan-object geometry-shader-vertices-out boa suffix! ;
556 TYPED:: refresh-program ( program: program -- )
557 program shaders>> [ refresh-shader-source ] each
558 program instances>> [| world old-instance |
559 old-instance valid-handle? [
562 program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
563 program new-shader-instances (link-program) |dispose :> new-program-instance
565 old-instance new-program-instance become-program-instance
566 new-shader-instances [| new-shader-instance |
567 world new-shader-instance shader>> instances>> at
568 new-shader-instance become-shader-instance
576 TYPED: <shader-instance> ( shader: shader -- instance: shader-instance )
577 [ find-shader-instance dup world get ] keep instances>> set-at ;
579 TYPED: <program-instance> ( program: program -- instance: program-instance )
580 [ find-program-instance dup world get ] keep instances>> set-at ;
584 : old-instances ( name -- instances )
586 execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
587 [ instances>> ] [ drop H{ } clone ] if
588 ] [ drop H{ } clone ] if ;
604 SYNTAX: GLSL-SHADER-FILE:
607 scan-word execute( -- kind )
608 scan-object in-word's-path
610 over ascii file-contents
616 SYNTAX: GLSL-PROGRAM:
621 parse-array-def shaders-and-formats
627 M: shader-instance dispose
628 [ dup valid-handle? [ glDeleteShader ] [ drop ] if f ] change-handle
629 [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
631 M: program-instance dispose
632 [ dup valid-handle? [ glDeleteProgram ] [ drop ] if f ] change-handle
633 [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
636 { "gpu.shaders" "prettyprint" } "gpu.shaders.prettyprint" require-when