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 ;
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-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
132 vertex-attribute name>> hyphens>underscores :> name
133 vertex-attribute component-type>> :> type
134 type gl-vertex-type :> gl-type
135 vertex-attribute dim>> :> dim
136 vertex-attribute normalize?>> >c-bool :> normalize?
137 vertex-attribute vertex-attribute-size :> size
141 { [ name not ] [ [ 2drop ] ] }
143 [ type unnormalized-integer-components? ]
146 name attribute-index [ glEnableVertexAttribArray ] keep
147 dim gl-type stride offset
148 } >quotation :> dip-block
150 { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
155 name attribute-index [ glEnableVertexAttribArray ] keep
156 dim gl-type normalize? stride offset
157 } >quotation :> dip-block
159 { dip-block dip <displaced-alien> glVertexAttribPointer } >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' )
280 "\n" split [ empty? not ] filter
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
327 : buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
329 [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
331 : vertex-array-buffer ( vertex-array -- vertex-buffer )
332 vertex-buffers>> first ;
334 TUPLE: compile-shader-error shader log ;
335 TUPLE: link-program-error program log ;
337 : compile-shader-error ( shader instance -- * )
338 [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
339 \ compile-shader-error boa throw ;
341 : link-program-error ( program instance -- * )
342 [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
343 \ link-program-error boa throw ;
345 DEFER: <shader-instance>
349 : valid-handle? ( handle -- ? )
350 { [ ] [ zero? not ] } 1&& ;
352 : compile-shader ( shader -- instance )
353 [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
355 [ swap world get \ shader-instance boa window-resource ]
356 [ compile-shader-error ] if ;
358 : (link-program) ( program shader-instances -- program-instance )
359 [ [ handle>> ] map ] curry
360 [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
362 [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
363 with-destructors window-resource
364 ] [ link-program-error ] if ;
366 : link-program ( program -- program-instance )
367 dup shaders>> [ <shader-instance> ] map (link-program) ;
369 : in-word's-path ( word kind filename -- word kind filename' )
370 [ over ] dip [ where first parent-directory ] dip append-path ;
372 : become-shader-instance ( shader-instance new-shader-instance -- )
373 handle>> [ swap delete-gl-shader ] curry change-handle drop ;
375 : refresh-shader-source ( shader -- )
377 [ ascii file-contents >>source drop ]
380 : become-program-instance ( program-instance new-program-instance -- )
381 handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
384 \ uniform-index reset-memoized
385 \ attribute-index reset-memoized
386 \ output-index reset-memoized ;
388 : ?delete-at ( key assoc value -- )
389 2over at = [ delete-at ] [ 2drop ] if ;
391 : find-shader-instance ( shader -- instance )
392 world get over instances>> at*
393 [ nip ] [ drop compile-shader ] if ;
395 : find-program-instance ( program -- instance )
396 world get over instances>> at*
397 [ nip ] [ drop link-program ] if ;
399 : shaders-and-feedback-format ( words -- shaders feedback-format )
400 [ vertex-format? ] partition swap
401 [ [ def>> first ] map ] [
403 [ [ f ] [ first ] if-empty ]
404 [ too-many-feedback-formats-error ] if
409 :: refresh-program ( program -- )
410 program shaders>> [ refresh-shader-source ] each
411 program instances>> [| world old-instance |
412 old-instance valid-handle? [
415 program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
416 program new-shader-instances (link-program) |dispose :> new-program-instance
418 old-instance new-program-instance become-program-instance
419 new-shader-instances [| new-shader-instance |
420 world new-shader-instance shader>> instances>> at
421 new-shader-instance become-shader-instance
429 : <shader-instance> ( shader -- instance )
430 [ find-shader-instance dup world get ] keep instances>> set-at ;
432 : <program-instance> ( program -- instance )
433 [ find-program-instance dup world get ] keep instances>> set-at ;
437 : old-instances ( name -- instances )
439 execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
440 [ instances>> ] [ drop H{ } clone ] if
441 ] [ drop H{ } clone ] if ;
457 SYNTAX: GLSL-SHADER-FILE:
460 scan-word execute( -- kind )
461 scan-object in-word's-path
463 over ascii file-contents
469 SYNTAX: GLSL-PROGRAM:
474 \ ; parse-until >array shaders-and-feedback-format
480 M: shader-instance dispose
481 [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
482 [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
484 M: program-instance dispose
485 [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
486 [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
489 "prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when