1 ! (c)2009 Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.data alien.strings
3 arrays assocs byte-arrays classes.mixin classes.parser
4 classes.singleton classes.struct combinators combinators.short-circuit
5 definitions destructors generic.parser gpu gpu.buffers hashtables
6 images io.encodings.ascii io.files io.pathnames kernel lexer
7 literals locals math math.parser memoize multiline namespaces
8 opengl opengl.gl opengl.shaders parser quotations sequences
9 specialized-arrays splitting strings tr ui.gadgets.worlds
10 variants vectors vocabs vocabs.loader vocabs.parser words
12 SPECIALIZED-ARRAY: int
13 SPECIALIZED-ARRAY: void*
17 vertex-shader fragment-shader ;
19 UNION: ?string string POSTPONE: f ;
21 ERROR: too-many-feedback-formats-error formats ;
22 ERROR: invalid-link-feedback-format-error format ;
23 ERROR: inaccurate-feedback-attribute-error attribute ;
25 TUPLE: vertex-attribute
26 { name ?string read-only initial: f }
27 { component-type component-type read-only initial: float-components }
28 { dim integer read-only initial: 4 }
29 { normalize? boolean read-only initial: f } ;
32 UNION: ?vertex-format vertex-format POSTPONE: f ;
35 { name word read-only initial: t }
36 { kind shader-kind read-only }
37 { filename read-only }
38 { line integer read-only }
40 { instances hashtable read-only } ;
43 { name word read-only initial: t }
44 { filename read-only }
45 { line integer read-only }
46 { shaders array read-only }
47 { feedback-format ?vertex-format read-only }
48 { instances hashtable read-only } ;
50 TUPLE: shader-instance < gpu-object
54 TUPLE: program-instance < gpu-object
58 GENERIC: vertex-format-size ( format -- size )
60 MEMO: uniform-index ( program-instance uniform-name -- index )
61 [ handle>> ] dip glGetUniformLocation ;
62 MEMO: attribute-index ( program-instance attribute-name -- index )
63 [ handle>> ] dip glGetAttribLocation ;
64 MEMO: output-index ( program-instance output-name -- index )
65 [ handle>> ] dip glGetFragDataLocation ;
69 TR: hyphens>underscores "-" "_" ;
71 : gl-vertex-type ( component-type -- gl-type )
73 { ubyte-components [ GL_UNSIGNED_BYTE ] }
74 { ushort-components [ GL_UNSIGNED_SHORT ] }
75 { uint-components [ GL_UNSIGNED_INT ] }
76 { half-components [ GL_HALF_FLOAT ] }
77 { float-components [ GL_FLOAT ] }
78 { byte-integer-components [ GL_BYTE ] }
79 { short-integer-components [ GL_SHORT ] }
80 { int-integer-components [ GL_INT ] }
81 { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
82 { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
83 { uint-integer-components [ GL_UNSIGNED_INT ] }
86 : vertex-type-size ( component-type -- size )
88 { ubyte-components [ 1 ] }
89 { ushort-components [ 2 ] }
90 { uint-components [ 4 ] }
91 { half-components [ 2 ] }
92 { float-components [ 4 ] }
93 { byte-integer-components [ 1 ] }
94 { short-integer-components [ 2 ] }
95 { int-integer-components [ 4 ] }
96 { ubyte-integer-components [ 1 ] }
97 { ushort-integer-components [ 2 ] }
98 { uint-integer-components [ 4 ] }
101 : vertex-attribute-size ( vertex-attribute -- size )
102 [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
104 : vertex-attributes-size ( vertex-attributes -- size )
105 [ vertex-attribute-size ] [ + ] map-reduce ;
107 : feedback-type= ( component-type dim gl-type -- ? )
109 { $ GL_FLOAT [ { float-components 1 } ] }
110 { $ GL_FLOAT_VEC2 [ { float-components 2 } ] }
111 { $ GL_FLOAT_VEC3 [ { float-components 3 } ] }
112 { $ GL_FLOAT_VEC4 [ { float-components 4 } ] }
113 { $ GL_INT [ { int-integer-components 1 } ] }
114 { $ GL_INT_VEC2 [ { int-integer-components 2 } ] }
115 { $ GL_INT_VEC3 [ { int-integer-components 3 } ] }
116 { $ GL_INT_VEC4 [ { int-integer-components 4 } ] }
117 { $ GL_UNSIGNED_INT [ { uint-integer-components 1 } ] }
118 { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
119 { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
120 { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
123 :: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
125 [ vertex-attribute name>> name = ]
127 [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
128 } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
130 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
131 vertex-attribute name>> hyphens>underscores :> name
132 vertex-attribute component-type>> :> type
133 type gl-vertex-type :> gl-type
134 vertex-attribute dim>> :> dim
135 vertex-attribute normalize?>> >c-bool :> normalize?
136 vertex-attribute vertex-attribute-size :> size
140 { [ name not ] [ [ 2drop ] ] }
142 [ type unnormalized-integer-components? ]
145 name attribute-index [ glEnableVertexAttribArray ] keep
146 dim gl-type stride offset
147 } >quotation :> dip-block
149 { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
154 name attribute-index [ glEnableVertexAttribArray ] keep
155 dim gl-type normalize? stride offset
156 } >quotation :> dip-block
158 { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
162 :: [bind-vertex-format] ( vertex-attributes -- quot )
163 vertex-attributes vertex-attributes-size :> stride
164 stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
165 { attributes-cleave 2cleave } >quotation :> with-block
167 { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
169 :: [link-feedback-format] ( vertex-attributes -- quot )
170 vertex-attributes [ name>> not ] any?
171 [ [ nip invalid-link-feedback-format-error ] ] [
173 [ name>> ascii malloc-string ]
174 void*-array{ } map-as :> varying-names
175 vertex-attributes length :> varying-count
176 { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
180 :: [verify-feedback-attribute] ( vertex-attribute index -- quot )
181 vertex-attribute name>> :> name
182 name length 1 + :> name-buffer-length
184 index name-buffer-length dup
185 [ f 0 <int> 0 <int> ] dip <byte-array>
186 [ glGetTransformFeedbackVarying ] 3keep
188 vertex-attribute assert-feedback-attribute
191 :: [verify-feedback-format] ( vertex-attributes -- quot )
192 vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
193 { drop verify-cleave cleave } >quotation ;
195 GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
197 GENERIC: link-feedback-format ( program-handle format -- )
199 M: f link-feedback-format
202 GENERIC: (verify-feedback-format) ( program-instance format -- )
204 M: f (verify-feedback-format)
207 : verify-feedback-format ( program-instance -- )
208 dup program>> feedback-format>> (verify-feedback-format) ;
210 : define-vertex-format-methods ( class vertex-attributes -- )
213 [ \ bind-vertex-format create-method-in ] dip
214 [bind-vertex-format] define
216 [ \ link-feedback-format create-method-in ] dip
217 [link-feedback-format] define
219 [ \ (verify-feedback-format) create-method-in ] dip
220 [verify-feedback-format] define
222 [ \ vertex-format-size create-method-in ] dip
223 [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
227 : component-type>c-type ( component-type -- c-type )
229 { ubyte-components [ "uchar" ] }
230 { ushort-components [ "ushort" ] }
231 { uint-components [ "uint" ] }
232 { half-components [ "half" ] }
233 { float-components [ "float" ] }
234 { byte-integer-components [ "char" ] }
235 { ubyte-integer-components [ "uchar" ] }
236 { short-integer-components [ "short" ] }
237 { ushort-integer-components [ "ushort" ] }
238 { int-integer-components [ "int" ] }
239 { uint-integer-components [ "uint" ] }
242 : c-array-dim ( type dim -- type' )
243 dup 1 = [ drop ] [ 2array ] if ;
246 padding-no [ 0 ] initialize
248 : padding-name ( -- name )
250 padding-no get number>string append
254 : vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
255 [ name>> [ padding-name ] unless* ]
256 [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
257 { } <struct-slot-spec> ;
259 : shader-filename ( shader/program -- filename )
260 dup filename>> [ nip ] [ name>> where first ] if* file-name ;
262 : numbered-log-line? ( log-line-components -- ? )
265 [ third string>number ]
268 : replace-log-line-number ( object log-line -- log-line' )
269 ":" split dup numbered-log-line? [
272 [ drop shader-filename " " prepend ]
273 [ [ line>> ] [ third string>number ] bi* + number>string ]
275 } 2cleave [ 3array ] dip append
276 ] [ nip ] if ":" join ;
278 : replace-log-line-numbers ( object log -- log' )
279 "\n" split [ empty? not ] filter
280 [ replace-log-line-number ] with map
283 : gl-shader-kind ( shader-kind -- shader-kind )
285 { vertex-shader [ GL_VERTEX_SHADER ] }
286 { fragment-shader [ GL_FRAGMENT_SHADER ] }
291 : define-vertex-format ( class vertex-attributes -- )
294 [ define-singleton-class ]
295 [ vertex-format add-mixin-instance ]
297 ] [ define-vertex-format-methods ] bi*
299 [ "vertex-format-attributes" set-word-prop ] 2bi ;
301 SYNTAX: VERTEX-FORMAT:
302 CREATE-CLASS parse-definition
303 [ first4 vertex-attribute boa ] map
304 define-vertex-format ;
306 : define-vertex-struct ( class vertex-format -- )
307 "vertex-format-attributes" word-prop [ vertex-attribute>struct-slot ] map
308 define-struct-class ;
310 SYNTAX: VERTEX-STRUCT:
311 CREATE-CLASS scan-word define-vertex-struct ;
313 TUPLE: vertex-array < gpu-object
314 { program-instance program-instance read-only }
315 { vertex-buffers sequence read-only } ;
317 M: vertex-array dispose
318 [ [ delete-vertex-array ] when* f ] change-handle drop ;
320 : <vertex-array> ( program-instance vertex-formats -- vertex-array )
322 [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
323 [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
326 : buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
328 [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
330 : vertex-array-buffer ( vertex-array -- vertex-buffer )
331 vertex-buffers>> first ;
333 TUPLE: compile-shader-error shader log ;
334 TUPLE: link-program-error program log ;
336 : compile-shader-error ( shader instance -- * )
337 [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
338 \ compile-shader-error boa throw ;
340 : link-program-error ( program instance -- * )
341 [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
342 \ link-program-error boa throw ;
344 DEFER: <shader-instance>
348 : valid-handle? ( handle -- ? )
349 { [ ] [ zero? not ] } 1&& ;
351 : compile-shader ( shader -- instance )
352 [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
354 [ swap world get \ shader-instance boa window-resource ]
355 [ compile-shader-error ] if ;
357 : (link-program) ( program shader-instances -- program-instance )
358 [ [ handle>> ] map ] curry
359 [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
361 [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
362 with-destructors window-resource
363 ] [ link-program-error ] if ;
365 : link-program ( program -- program-instance )
366 dup shaders>> [ <shader-instance> ] map (link-program) ;
368 : in-word's-path ( word kind filename -- word kind filename' )
369 [ over ] dip [ where first parent-directory ] dip append-path ;
371 : become-shader-instance ( shader-instance new-shader-instance -- )
372 handle>> [ swap delete-gl-shader ] curry change-handle drop ;
374 : refresh-shader-source ( shader -- )
376 [ ascii file-contents >>source drop ]
379 : become-program-instance ( program-instance new-program-instance -- )
380 handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
383 \ uniform-index reset-memoized
384 \ attribute-index reset-memoized
385 \ output-index reset-memoized ;
387 : ?delete-at ( key assoc value -- )
388 2over at = [ delete-at ] [ 2drop ] if ;
390 : find-shader-instance ( shader -- instance )
391 world get over instances>> at*
392 [ nip ] [ drop compile-shader ] if ;
394 : find-program-instance ( program -- instance )
395 world get over instances>> at*
396 [ nip ] [ drop link-program ] if ;
398 : shaders-and-feedback-format ( words -- shaders feedback-format )
399 [ vertex-format? ] partition swap
400 [ [ def>> first ] map ] [
402 [ [ f ] [ first ] if-empty ]
403 [ too-many-feedback-formats-error ] if
408 :: refresh-program ( program -- )
409 program shaders>> [ refresh-shader-source ] each
410 program instances>> [| world old-instance |
411 old-instance valid-handle? [
414 program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
415 program new-shader-instances (link-program) |dispose :> new-program-instance
417 old-instance new-program-instance become-program-instance
418 new-shader-instances [| new-shader-instance |
419 world new-shader-instance shader>> instances>> at
420 new-shader-instance become-shader-instance
428 : <shader-instance> ( shader -- instance )
429 [ find-shader-instance dup world get ] keep instances>> set-at ;
431 : <program-instance> ( program -- instance )
432 [ find-program-instance dup world get ] keep instances>> set-at ;
444 SYNTAX: GLSL-SHADER-FILE:
446 scan-word execute( -- kind )
447 scan-object in-word's-path
449 over ascii file-contents
454 SYNTAX: GLSL-PROGRAM:
458 \ ; parse-until >array shaders-and-feedback-format
463 M: shader-instance dispose
464 [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
465 [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
467 M: program-instance dispose
468 [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
469 [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
472 "prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when