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 fry 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 { vertex-formats array read-only }
49 { feedback-format ?vertex-format read-only }
50 { instances hashtable read-only } ;
52 TUPLE: shader-instance < gpu-object
56 TUPLE: program-instance < gpu-object
60 GENERIC: vertex-format-size ( format -- size )
62 MEMO: uniform-index ( program-instance uniform-name -- index )
63 [ handle>> ] dip glGetUniformLocation ;
64 MEMO: attribute-index ( program-instance attribute-name -- index )
65 [ handle>> ] dip glGetAttribLocation ;
66 MEMO: output-index ( program-instance output-name -- index )
67 [ handle>> ] dip glGetFragDataLocation ;
69 : vertex-format-attributes ( vertex-format -- attributes )
70 "vertex-format-attributes" word-prop ; inline
74 TR: hyphens>underscores "-" "_" ;
76 : gl-vertex-type ( component-type -- gl-type )
78 { ubyte-components [ GL_UNSIGNED_BYTE ] }
79 { ushort-components [ GL_UNSIGNED_SHORT ] }
80 { uint-components [ GL_UNSIGNED_INT ] }
81 { half-components [ GL_HALF_FLOAT ] }
82 { float-components [ GL_FLOAT ] }
83 { byte-integer-components [ GL_BYTE ] }
84 { short-integer-components [ GL_SHORT ] }
85 { int-integer-components [ GL_INT ] }
86 { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
87 { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
88 { uint-integer-components [ GL_UNSIGNED_INT ] }
91 : vertex-type-size ( component-type -- size )
93 { ubyte-components [ 1 ] }
94 { ushort-components [ 2 ] }
95 { uint-components [ 4 ] }
96 { half-components [ 2 ] }
97 { float-components [ 4 ] }
98 { byte-integer-components [ 1 ] }
99 { short-integer-components [ 2 ] }
100 { int-integer-components [ 4 ] }
101 { ubyte-integer-components [ 1 ] }
102 { ushort-integer-components [ 2 ] }
103 { uint-integer-components [ 4 ] }
106 : vertex-attribute-size ( vertex-attribute -- size )
107 [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
109 : vertex-attributes-size ( vertex-attributes -- size )
110 [ vertex-attribute-size ] [ + ] map-reduce ;
112 : feedback-type= ( component-type dim gl-type -- ? )
114 { $ GL_FLOAT [ { float-components 1 } ] }
115 { $ GL_FLOAT_VEC2 [ { float-components 2 } ] }
116 { $ GL_FLOAT_VEC3 [ { float-components 3 } ] }
117 { $ GL_FLOAT_VEC4 [ { float-components 4 } ] }
118 { $ GL_INT [ { int-integer-components 1 } ] }
119 { $ GL_INT_VEC2 [ { int-integer-components 2 } ] }
120 { $ GL_INT_VEC3 [ { int-integer-components 3 } ] }
121 { $ GL_INT_VEC4 [ { int-integer-components 4 } ] }
122 { $ GL_UNSIGNED_INT [ { uint-integer-components 1 } ] }
123 { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
124 { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
125 { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
128 :: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
130 [ vertex-attribute name>> name = ]
132 [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
133 } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
135 :: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
136 program-instance name attribute-index :> idx
138 idx glEnableVertexAttribArray
139 idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
142 :: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
143 program-instance name attribute-index :> idx
145 idx glEnableVertexAttribArray
146 idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
149 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
150 vertex-attribute name>> hyphens>underscores :> name
151 vertex-attribute component-type>> :> type
152 type gl-vertex-type :> gl-type
153 vertex-attribute dim>> :> dim
154 vertex-attribute normalize?>> >c-bool :> normalize?
155 vertex-attribute vertex-attribute-size :> size
159 { [ name not ] [ [ 2drop ] ] }
161 [ type unnormalized-integer-components? ]
162 [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
164 [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
167 :: [bind-vertex-format] ( vertex-attributes -- quot )
168 vertex-attributes vertex-attributes-size :> stride
169 stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
170 { attributes-cleave 2cleave } >quotation :> with-block
172 { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
174 :: [link-feedback-format] ( vertex-attributes -- quot )
175 vertex-attributes [ name>> not ] any?
176 [ [ nip invalid-link-feedback-format-error ] ] [
178 [ name>> ascii malloc-string ]
179 void*-array{ } map-as :> varying-names
180 vertex-attributes length :> varying-count
181 { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
185 :: [verify-feedback-attribute] ( vertex-attribute index -- quot )
186 vertex-attribute name>> :> name
187 name length 1 + :> name-buffer-length
189 index name-buffer-length dup
190 [ f 0 <int> 0 <int> ] dip <byte-array>
191 [ glGetTransformFeedbackVarying ] 3keep
193 vertex-attribute assert-feedback-attribute
196 :: [verify-feedback-format] ( vertex-attributes -- quot )
197 vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
198 { drop verify-cleave cleave } >quotation ;
200 GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
202 GENERIC: link-feedback-format ( program-handle format -- )
204 M: f link-feedback-format
207 : link-vertex-formats ( program-handle formats -- )
208 [ vertex-format-attributes [ name>> ] map sift ] map concat
209 swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
211 GENERIC: (verify-feedback-format) ( program-instance format -- )
213 M: f (verify-feedback-format)
216 : verify-feedback-format ( program-instance -- )
217 dup program>> feedback-format>> (verify-feedback-format) ;
219 : define-vertex-format-methods ( class vertex-attributes -- )
222 [ \ bind-vertex-format create-method-in ] dip
223 [bind-vertex-format] define
225 [ \ link-feedback-format create-method-in ] dip
226 [link-feedback-format] define
228 [ \ (verify-feedback-format) create-method-in ] dip
229 [verify-feedback-format] define
231 [ \ vertex-format-size create-method-in ] dip
232 [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
236 : component-type>c-type ( component-type -- c-type )
238 { ubyte-components [ c:uchar ] }
239 { ushort-components [ c:ushort ] }
240 { uint-components [ c:uint ] }
241 { half-components [ half ] }
242 { float-components [ c:float ] }
243 { byte-integer-components [ c:char ] }
244 { ubyte-integer-components [ c:uchar ] }
245 { short-integer-components [ c:short ] }
246 { ushort-integer-components [ c:ushort ] }
247 { int-integer-components [ c:int ] }
248 { uint-integer-components [ c:uint ] }
251 : c-array-dim ( type dim -- type' )
252 dup 1 = [ drop ] [ 2array ] if ;
255 padding-no [ 0 ] initialize
257 : padding-name ( -- name )
259 padding-no get number>string append
263 : vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
264 [ name>> [ padding-name ] unless* ]
265 [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
266 { } <struct-slot-spec> ;
268 : shader-filename ( shader/program -- filename )
269 dup filename>> [ nip ] [ name>> where first ] if* file-name ;
271 : numbered-log-line? ( log-line-components -- ? )
274 [ third string>number ]
277 : replace-log-line-number ( object log-line -- log-line' )
278 ":" split dup numbered-log-line? [
281 [ drop shader-filename " " prepend ]
282 [ [ line>> ] [ third string>number ] bi* + number>string ]
284 } 2cleave [ 3array ] dip append
285 ] [ nip ] if ":" join ;
287 : replace-log-line-numbers ( object log -- log' )
289 [ replace-log-line-number ] with map
292 : gl-shader-kind ( shader-kind -- shader-kind )
294 { vertex-shader [ GL_VERTEX_SHADER ] }
295 { fragment-shader [ GL_FRAGMENT_SHADER ] }
300 : define-vertex-format ( class vertex-attributes -- )
303 [ define-singleton-class ]
304 [ vertex-format add-mixin-instance ]
306 ] [ define-vertex-format-methods ] bi*
308 [ "vertex-format-attributes" set-word-prop ] 2bi ;
310 SYNTAX: VERTEX-FORMAT:
311 CREATE-CLASS parse-definition
312 [ first4 vertex-attribute boa ] map
313 define-vertex-format ;
315 : define-vertex-struct ( class vertex-format -- )
316 vertex-format-attributes [ vertex-attribute>struct-slot ] map
317 define-struct-class ;
319 SYNTAX: VERTEX-STRUCT:
320 CREATE-CLASS scan-word define-vertex-struct ;
322 TUPLE: vertex-array < gpu-object
323 { program-instance program-instance read-only }
324 { vertex-buffers sequence read-only } ;
326 M: vertex-array dispose
327 [ [ delete-vertex-array ] when* f ] change-handle drop ;
329 : <vertex-array> ( program-instance vertex-formats -- vertex-array )
331 [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
332 [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
333 window-resource ; inline
335 TYPED: buffer>vertex-array ( vertex-buffer: buffer
336 program-instance: program-instance
337 format: vertex-format
339 vertex-array: vertex-array )
341 [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
343 TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
344 vertex-buffers>> first ;
346 TUPLE: compile-shader-error shader log ;
347 TUPLE: link-program-error program log ;
349 : compile-shader-error ( shader instance -- * )
350 [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
351 \ compile-shader-error boa throw ;
353 : link-program-error ( program instance -- * )
354 [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
355 \ link-program-error boa throw ;
357 DEFER: <shader-instance>
361 : valid-handle? ( handle -- ? )
362 { [ ] [ zero? not ] } 1&& ;
364 : compile-shader ( shader -- instance )
365 [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
367 [ swap world get \ shader-instance boa window-resource ]
368 [ compile-shader-error ] if ;
370 : (link-program) ( program shader-instances -- program-instance )
371 '[ _ [ handle>> ] map ]
373 [ vertex-formats>> ] [ feedback-format>> ] bi
374 '[ [ _ link-vertex-formats ] [ _ link-feedback-format ] bi ]
377 [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
378 with-destructors window-resource
379 ] [ link-program-error ] if ;
381 : link-program ( program -- program-instance )
382 dup shaders>> [ <shader-instance> ] map (link-program) ;
384 : in-word's-path ( word kind filename -- word kind filename' )
385 [ over ] dip [ where first parent-directory ] dip append-path ;
387 : become-shader-instance ( shader-instance new-shader-instance -- )
388 handle>> [ swap delete-gl-shader ] curry change-handle drop ;
390 : refresh-shader-source ( shader -- )
392 [ ascii file-contents >>source drop ]
395 : become-program-instance ( program-instance new-program-instance -- )
396 handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
399 \ uniform-index reset-memoized
400 \ attribute-index reset-memoized
401 \ output-index reset-memoized ;
403 : ?delete-at ( key assoc value -- )
404 2over at = [ delete-at ] [ 2drop ] if ;
406 : find-shader-instance ( shader -- instance )
407 world get over instances>> at*
408 [ nip ] [ drop compile-shader ] if ;
410 : find-program-instance ( program -- instance )
411 world get over instances>> at*
412 [ nip ] [ drop link-program ] if ;
414 TUPLE: feedback-format
415 { vertex-format ?vertex-format read-only } ;
417 : validate-feedback-format ( sequence -- vertex-format/f )
419 [ [ f ] [ first vertex-format>> ] if-empty ]
420 [ too-many-feedback-formats-error ] if ;
422 : ?shader ( object -- shader/f )
423 dup word? [ def>> first dup shader? [ drop f ] unless ] [ drop f ] if ;
425 : shaders-and-formats ( words -- shaders vertex-formats feedback-format )
426 [ [ ?shader ] map sift ]
427 [ [ vertex-format? ] filter ]
428 [ [ feedback-format? ] filter validate-feedback-format ] tri ;
432 SYNTAX: feedback-format:
433 scan-object feedback-format boa suffix! ;
435 TYPED:: refresh-program ( program: program -- )
436 program shaders>> [ refresh-shader-source ] each
437 program instances>> [| world old-instance |
438 old-instance valid-handle? [
441 program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
442 program new-shader-instances (link-program) |dispose :> new-program-instance
444 old-instance new-program-instance become-program-instance
445 new-shader-instances [| new-shader-instance |
446 world new-shader-instance shader>> instances>> at
447 new-shader-instance become-shader-instance
455 TYPED: <shader-instance> ( shader: shader -- instance: shader-instance )
456 [ find-shader-instance dup world get ] keep instances>> set-at ;
458 TYPED: <program-instance> ( program: program -- instance: program-instance )
459 [ find-program-instance dup world get ] keep instances>> set-at ;
463 : old-instances ( name -- instances )
465 execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
466 [ instances>> ] [ drop H{ } clone ] if
467 ] [ drop H{ } clone ] if ;
483 SYNTAX: GLSL-SHADER-FILE:
486 scan-word execute( -- kind )
487 scan-object in-word's-path
489 over ascii file-contents
495 SYNTAX: GLSL-PROGRAM:
500 \ ; parse-until >array shaders-and-formats
506 M: shader-instance dispose
507 [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
508 [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
510 M: program-instance dispose
511 [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
512 [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
515 "prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when