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
11 words.constant half-floats typed ;
12 QUALIFIED-WITH: alien.c-types c
13 SPECIALIZED-ARRAY: int
14 SPECIALIZED-ARRAY: void*
18 vertex-shader fragment-shader ;
20 UNION: ?string string POSTPONE: f ;
22 ERROR: too-many-feedback-formats-error formats ;
23 ERROR: invalid-link-feedback-format-error format ;
24 ERROR: inaccurate-feedback-attribute-error attribute ;
26 TUPLE: vertex-attribute
27 { name ?string read-only initial: f }
28 { component-type component-type read-only initial: float-components }
29 { dim integer read-only initial: 4 }
30 { normalize? boolean read-only initial: f } ;
33 UNION: ?vertex-format vertex-format POSTPONE: f ;
36 { name word read-only initial: t }
37 { kind shader-kind read-only }
38 { filename read-only }
39 { line integer read-only }
41 { instances hashtable read-only } ;
44 { name word read-only initial: t }
45 { filename read-only }
46 { line integer read-only }
47 { shaders array read-only }
48 { feedback-format ?vertex-format read-only }
49 { instances hashtable read-only } ;
51 TUPLE: shader-instance < gpu-object
55 TUPLE: program-instance < gpu-object
59 GENERIC: vertex-format-size ( format -- size )
61 MEMO: uniform-index ( program-instance uniform-name -- index )
62 [ handle>> ] dip glGetUniformLocation ;
63 MEMO: attribute-index ( program-instance attribute-name -- index )
64 [ handle>> ] dip glGetAttribLocation ;
65 MEMO: output-index ( program-instance output-name -- index )
66 [ handle>> ] dip glGetFragDataLocation ;
70 TR: hyphens>underscores "-" "_" ;
72 : gl-vertex-type ( component-type -- gl-type )
74 { ubyte-components [ GL_UNSIGNED_BYTE ] }
75 { ushort-components [ GL_UNSIGNED_SHORT ] }
76 { uint-components [ GL_UNSIGNED_INT ] }
77 { half-components [ GL_HALF_FLOAT ] }
78 { float-components [ GL_FLOAT ] }
79 { byte-integer-components [ GL_BYTE ] }
80 { short-integer-components [ GL_SHORT ] }
81 { int-integer-components [ GL_INT ] }
82 { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
83 { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
84 { uint-integer-components [ GL_UNSIGNED_INT ] }
87 : vertex-type-size ( component-type -- size )
89 { ubyte-components [ 1 ] }
90 { ushort-components [ 2 ] }
91 { uint-components [ 4 ] }
92 { half-components [ 2 ] }
93 { float-components [ 4 ] }
94 { byte-integer-components [ 1 ] }
95 { short-integer-components [ 2 ] }
96 { int-integer-components [ 4 ] }
97 { ubyte-integer-components [ 1 ] }
98 { ushort-integer-components [ 2 ] }
99 { uint-integer-components [ 4 ] }
102 : vertex-attribute-size ( vertex-attribute -- size )
103 [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
105 : vertex-attributes-size ( vertex-attributes -- size )
106 [ vertex-attribute-size ] [ + ] map-reduce ;
108 : feedback-type= ( component-type dim gl-type -- ? )
110 { $ GL_FLOAT [ { float-components 1 } ] }
111 { $ GL_FLOAT_VEC2 [ { float-components 2 } ] }
112 { $ GL_FLOAT_VEC3 [ { float-components 3 } ] }
113 { $ GL_FLOAT_VEC4 [ { float-components 4 } ] }
114 { $ GL_INT [ { int-integer-components 1 } ] }
115 { $ GL_INT_VEC2 [ { int-integer-components 2 } ] }
116 { $ GL_INT_VEC3 [ { int-integer-components 3 } ] }
117 { $ GL_INT_VEC4 [ { int-integer-components 4 } ] }
118 { $ GL_UNSIGNED_INT [ { uint-integer-components 1 } ] }
119 { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
120 { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
121 { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
124 :: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
126 [ vertex-attribute name>> name = ]
128 [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
129 } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
131 :: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
132 program-instance name attribute-index :> idx
134 idx glEnableVertexAttribArray
135 idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
138 :: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
139 program-instance name attribute-index :> idx
141 idx glEnableVertexAttribArray
142 idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
145 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
146 vertex-attribute name>> hyphens>underscores :> name
147 vertex-attribute component-type>> :> type
148 type gl-vertex-type :> gl-type
149 vertex-attribute dim>> :> dim
150 vertex-attribute normalize?>> >c-bool :> normalize?
151 vertex-attribute vertex-attribute-size :> size
155 { [ name not ] [ [ 2drop ] ] }
157 [ type unnormalized-integer-components? ]
158 [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
160 [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
163 :: [bind-vertex-format] ( vertex-attributes -- quot )
164 vertex-attributes vertex-attributes-size :> stride
165 stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
166 { attributes-cleave 2cleave } >quotation :> with-block
168 { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
170 :: [link-feedback-format] ( vertex-attributes -- quot )
171 vertex-attributes [ name>> not ] any?
172 [ [ nip invalid-link-feedback-format-error ] ] [
174 [ name>> ascii malloc-string ]
175 void*-array{ } map-as :> varying-names
176 vertex-attributes length :> varying-count
177 { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
181 :: [verify-feedback-attribute] ( vertex-attribute index -- quot )
182 vertex-attribute name>> :> name
183 name length 1 + :> name-buffer-length
185 index name-buffer-length dup
186 [ f 0 <int> 0 <int> ] dip <byte-array>
187 [ glGetTransformFeedbackVarying ] 3keep
189 vertex-attribute assert-feedback-attribute
192 :: [verify-feedback-format] ( vertex-attributes -- quot )
193 vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
194 { drop verify-cleave cleave } >quotation ;
196 GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
198 GENERIC: link-feedback-format ( program-handle format -- )
200 M: f link-feedback-format
203 GENERIC: (verify-feedback-format) ( program-instance format -- )
205 M: f (verify-feedback-format)
208 : verify-feedback-format ( program-instance -- )
209 dup program>> feedback-format>> (verify-feedback-format) ;
211 : define-vertex-format-methods ( class vertex-attributes -- )
214 [ \ bind-vertex-format create-method-in ] dip
215 [bind-vertex-format] define
217 [ \ link-feedback-format create-method-in ] dip
218 [link-feedback-format] define
220 [ \ (verify-feedback-format) create-method-in ] dip
221 [verify-feedback-format] define
223 [ \ vertex-format-size create-method-in ] dip
224 [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
228 : component-type>c-type ( component-type -- c-type )
230 { ubyte-components [ c:uchar ] }
231 { ushort-components [ c:ushort ] }
232 { uint-components [ c:uint ] }
233 { half-components [ half ] }
234 { float-components [ c:float ] }
235 { byte-integer-components [ c:char ] }
236 { ubyte-integer-components [ c:uchar ] }
237 { short-integer-components [ c:short ] }
238 { ushort-integer-components [ c:ushort ] }
239 { int-integer-components [ c:int ] }
240 { uint-integer-components [ c:uint ] }
243 : c-array-dim ( type dim -- type' )
244 dup 1 = [ drop ] [ 2array ] if ;
247 padding-no [ 0 ] initialize
249 : padding-name ( -- name )
251 padding-no get number>string append
255 : vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
256 [ name>> [ padding-name ] unless* ]
257 [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
258 { } <struct-slot-spec> ;
260 : shader-filename ( shader/program -- filename )
261 dup filename>> [ nip ] [ name>> where first ] if* file-name ;
263 : numbered-log-line? ( log-line-components -- ? )
266 [ third string>number ]
269 : replace-log-line-number ( object log-line -- log-line' )
270 ":" split dup numbered-log-line? [
273 [ drop shader-filename " " prepend ]
274 [ [ line>> ] [ third string>number ] bi* + number>string ]
276 } 2cleave [ 3array ] dip append
277 ] [ nip ] if ":" join ;
279 : replace-log-line-numbers ( object log -- log' )
281 [ replace-log-line-number ] with map
284 : gl-shader-kind ( shader-kind -- shader-kind )
286 { vertex-shader [ GL_VERTEX_SHADER ] }
287 { fragment-shader [ GL_FRAGMENT_SHADER ] }
292 : define-vertex-format ( class vertex-attributes -- )
295 [ define-singleton-class ]
296 [ vertex-format add-mixin-instance ]
298 ] [ define-vertex-format-methods ] bi*
300 [ "vertex-format-attributes" set-word-prop ] 2bi ;
302 SYNTAX: VERTEX-FORMAT:
303 CREATE-CLASS parse-definition
304 [ first4 vertex-attribute boa ] map
305 define-vertex-format ;
307 : define-vertex-struct ( class vertex-format -- )
308 "vertex-format-attributes" word-prop [ vertex-attribute>struct-slot ] map
309 define-struct-class ;
311 SYNTAX: VERTEX-STRUCT:
312 CREATE-CLASS scan-word define-vertex-struct ;
314 TUPLE: vertex-array < gpu-object
315 { program-instance program-instance read-only }
316 { vertex-buffers sequence read-only } ;
318 M: vertex-array dispose
319 [ [ delete-vertex-array ] when* f ] change-handle drop ;
321 : <vertex-array> ( program-instance vertex-formats -- vertex-array )
323 [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
324 [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
325 window-resource ; inline
327 TYPED: buffer>vertex-array ( vertex-buffer: buffer
328 program-instance: program-instance
329 format: vertex-format
331 vertex-array: vertex-array )
333 [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
335 TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
336 vertex-buffers>> first ;
338 TUPLE: compile-shader-error shader log ;
339 TUPLE: link-program-error program log ;
341 : compile-shader-error ( shader instance -- * )
342 [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
343 \ compile-shader-error boa throw ;
345 : link-program-error ( program instance -- * )
346 [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
347 \ link-program-error boa throw ;
349 DEFER: <shader-instance>
353 : valid-handle? ( handle -- ? )
354 { [ ] [ zero? not ] } 1&& ;
356 : compile-shader ( shader -- instance )
357 [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
359 [ swap world get \ shader-instance boa window-resource ]
360 [ compile-shader-error ] if ;
362 : (link-program) ( program shader-instances -- program-instance )
363 [ [ handle>> ] map ] curry
364 [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
366 [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
367 with-destructors window-resource
368 ] [ link-program-error ] if ;
370 : link-program ( program -- program-instance )
371 dup shaders>> [ <shader-instance> ] map (link-program) ;
373 : in-word's-path ( word kind filename -- word kind filename' )
374 [ over ] dip [ where first parent-directory ] dip append-path ;
376 : become-shader-instance ( shader-instance new-shader-instance -- )
377 handle>> [ swap delete-gl-shader ] curry change-handle drop ;
379 : refresh-shader-source ( shader -- )
381 [ ascii file-contents >>source drop ]
384 : become-program-instance ( program-instance new-program-instance -- )
385 handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
388 \ uniform-index reset-memoized
389 \ attribute-index reset-memoized
390 \ output-index reset-memoized ;
392 : ?delete-at ( key assoc value -- )
393 2over at = [ delete-at ] [ 2drop ] if ;
395 : find-shader-instance ( shader -- instance )
396 world get over instances>> at*
397 [ nip ] [ drop compile-shader ] if ;
399 : find-program-instance ( program -- instance )
400 world get over instances>> at*
401 [ nip ] [ drop link-program ] if ;
403 : shaders-and-feedback-format ( words -- shaders feedback-format )
404 [ vertex-format? ] partition swap
405 [ [ def>> first ] map ] [
407 [ [ f ] [ first ] if-empty ]
408 [ too-many-feedback-formats-error ] if
413 TYPED:: refresh-program ( program: program -- )
414 program shaders>> [ refresh-shader-source ] each
415 program instances>> [| world old-instance |
416 old-instance valid-handle? [
419 program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
420 program new-shader-instances (link-program) |dispose :> new-program-instance
422 old-instance new-program-instance become-program-instance
423 new-shader-instances [| new-shader-instance |
424 world new-shader-instance shader>> instances>> at
425 new-shader-instance become-shader-instance
433 TYPED: <shader-instance> ( shader: shader -- instance: shader-instance )
434 [ find-shader-instance dup world get ] keep instances>> set-at ;
436 TYPED: <program-instance> ( program: program -- instance: program-instance )
437 [ find-program-instance dup world get ] keep instances>> set-at ;
441 : old-instances ( name -- instances )
443 execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
444 [ instances>> ] [ drop H{ } clone ] if
445 ] [ drop H{ } clone ] if ;
461 SYNTAX: GLSL-SHADER-FILE:
464 scan-word execute( -- kind )
465 scan-object in-word's-path
467 over ascii file-contents
473 SYNTAX: GLSL-PROGRAM:
478 \ ; parse-until >array shaders-and-feedback-format
484 M: shader-instance dispose
485 [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
486 [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
488 M: program-instance dispose
489 [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
490 [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
493 "prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when