! (c)2009 Joe Groff bsd license USING: accessors alien alien.c-types alien.data arrays assocs classes classes.mixin classes.parser classes.singleton classes.struct classes.tuple classes.tuple.private combinators combinators.tuple destructors fry generic generic.parser gpu gpu.buffers gpu.framebuffers gpu.framebuffers.private gpu.shaders gpu.shaders.private gpu.state gpu.textures gpu.textures.private half-floats images kernel lexer locals math math.order math.parser namespaces opengl opengl.gl parser quotations sequences slots sorting specialized-arrays strings ui.gadgets.worlds variants vocabs.parser words math.vectors.simd ; FROM: math => float ; QUALIFIED-WITH: alien.c-types c SPECIALIZED-ARRAY: c:float SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: void* IN: gpu.render UNION: ?integer integer POSTPONE: f ; VARIANT: uniform-type bool-uniform bvec2-uniform bvec3-uniform bvec4-uniform uint-uniform uvec2-uniform uvec3-uniform uvec4-uniform int-uniform ivec2-uniform ivec3-uniform ivec4-uniform float-uniform vec2-uniform vec3-uniform vec4-uniform mat2-uniform mat2x3-uniform mat2x4-uniform mat3x2-uniform mat3-uniform mat3x4-uniform mat4x2-uniform mat4x3-uniform mat4-uniform texture-uniform ; ALIAS: mat2x2-uniform mat2-uniform ALIAS: mat3x3-uniform mat3-uniform ALIAS: mat4x4-uniform mat4-uniform TUPLE: uniform { name string read-only initial: "" } { uniform-type class read-only initial: float-uniform } { dim ?integer read-only initial: f } ; VARIANT: index-type ubyte-indexes ushort-indexes uint-indexes ; TUPLE: index-range { start integer read-only } { count integer read-only } ; C: index-range TUPLE: multi-index-range { starts uint-array read-only } { counts uint-array read-only } ; C: multi-index-range TUPLE: index-elements { ptr read-only } { count integer read-only } { index-type index-type read-only } ; C: index-elements UNION: ?buffer buffer POSTPONE: f ; TUPLE: multi-index-elements { buffer ?buffer read-only } { ptrs read-only } { counts uint-array read-only } { index-type index-type read-only } ; C: multi-index-elements UNION: vertex-indexes index-range multi-index-range index-elements multi-index-elements ; VARIANT: primitive-mode points-mode lines-mode line-strip-mode line-loop-mode triangles-mode triangle-strip-mode triangle-fan-mode ; TUPLE: uniform-tuple ; ERROR: invalid-uniform-type uniform ; > ] [ count>> ] bi ] bi* glDrawArrays ; M: index-range render-vertex-indexes-instanced [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] [ ] tri* glDrawArraysInstanced ; M: multi-index-range render-vertex-indexes [ gl-primitive-mode ] [ [ starts>> ] [ counts>> dup length ] bi ] bi* glMultiDrawArrays ; M: index-elements render-vertex-indexes [ gl-primitive-mode ] [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ] bi* index-buffer [ glDrawElements ] with-gpu-data-ptr ; M: index-elements render-vertex-indexes-instanced [ gl-primitive-mode ] [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ] [ ] tri* swap index-buffer [ swap glDrawElementsInstanced ] with-gpu-data-ptr ; M: multi-index-elements render-vertex-indexes [ gl-primitive-mode ] [ { [ counts>> ] [ index-type>> gl-index-type ] [ ptrs>> dup length ] [ buffer>> ] } cleave ] bi* GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ; : (bind-texture-unit) ( texture texture-unit -- ) swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline GENERIC: (bind-uniform-textures) ( program-instance uniform-tuple -- ) GENERIC: (bind-uniforms) ( program-instance uniform-tuple -- ) M: uniform-tuple (bind-uniform-textures) 2drop ; M: uniform-tuple (bind-uniforms) 2drop ; : uniform-slot-type ( uniform -- type ) dup dim>> [ drop sequence ] [ uniform-type>> { { bool-uniform [ boolean ] } { uint-uniform [ integer ] } { int-uniform [ integer ] } { float-uniform [ float ] } { texture-uniform [ texture ] } [ drop sequence ] } case ] if ; : uniform>slot ( uniform -- slot ) [ name>> ] [ uniform-slot-type ] bi 2array ; : uniform-type-texture-units ( uniform-type -- units ) dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ; : all-uniform-tuple-slots ( class -- slots ) dup "uniform-tuple-slots" word-prop [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ; DEFER: uniform-texture-accessors : uniform-type-texture-accessors ( uniform-type -- accessors ) texture-uniform = [ { [ ] } ] [ { } ] if ; : uniform-slot-texture-accessor ( uniform -- accessor ) [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ; : uniform-tuple-texture-accessors ( uniform-type -- accessors ) all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter [ uniform-slot-texture-accessor ] map ; : uniform-texture-accessors ( uniform-type dim -- accessors ) [ dup uniform-type? [ uniform-type-texture-accessors ] [ uniform-tuple-texture-accessors ] if ] [ 2dup swap empty? not and [ iota [ [ swap nth ] swap prefix over length 1 = [ swap first append ] [ swap suffix ] if ] with map ] [ drop ] if ] bi* ; : texture-accessor>cleave ( unit accessors -- unit' cleaves ) dup last sequence? [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ] [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ; : [bind-uniform-textures] ( class -- quot ) f uniform-texture-accessors 0 swap [ texture-accessor>cleave ] map nip \ nip swap \ cleave [ ] 3sequence ; UNION: binary-data c-ptr specialized-array struct simd-128 ; GENERIC: >uniform-bool-array ( sequence -- c-array ) GENERIC: >uniform-int-array ( sequence -- c-array ) GENERIC: >uniform-uint-array ( sequence -- c-array ) GENERIC: >uniform-float-array ( sequence -- c-array ) GENERIC# >uniform-bvec-array 1 ( sequence dim -- c-array ) GENERIC# >uniform-ivec-array 1 ( sequence dim -- c-array ) GENERIC# >uniform-uvec-array 1 ( sequence dim -- c-array ) GENERIC# >uniform-vec-array 1 ( sequence dim -- c-array ) GENERIC# >uniform-matrix 2 ( sequence cols rows -- c-array ) GENERIC# >uniform-matrix-array 2 ( sequence cols rows -- c-array ) GENERIC: bind-uniform-bvec2 ( index sequence -- ) GENERIC: bind-uniform-bvec3 ( index sequence -- ) GENERIC: bind-uniform-bvec4 ( index sequence -- ) GENERIC: bind-uniform-ivec2 ( index sequence -- ) GENERIC: bind-uniform-ivec3 ( index sequence -- ) GENERIC: bind-uniform-ivec4 ( index sequence -- ) GENERIC: bind-uniform-uvec2 ( index sequence -- ) GENERIC: bind-uniform-uvec3 ( index sequence -- ) GENERIC: bind-uniform-uvec4 ( index sequence -- ) GENERIC: bind-uniform-vec2 ( index sequence -- ) GENERIC: bind-uniform-vec3 ( index sequence -- ) GENERIC: bind-uniform-vec4 ( index sequence -- ) M: object >uniform-bool-array [ >c-bool ] int-array{ } map-as ; inline M: binary-data >uniform-bool-array ; inline M: object >uniform-int-array >int-array ; inline M: binary-data >uniform-int-array ; inline M: object >uniform-uint-array >uint-array ; inline M: binary-data >uniform-uint-array ; inline M: object >uniform-float-array >float-array ; inline M: binary-data >uniform-float-array ; inline M: object >uniform-bvec-array '[ _ head-slice [ >c-bool ] int-array{ } map-as ] map concat ; inline M: binary-data >uniform-bvec-array drop ; inline M: object >uniform-ivec-array '[ _ head ] map int-array{ } concat-as ; inline M: binary-data >uniform-ivec-array drop ; inline M: object >uniform-uvec-array '[ _ head ] map uint-array{ } concat-as ; inline M: binary-data >uniform-uvec-array drop ; inline M: object >uniform-vec-array '[ _ head ] map float-array{ } concat-as ; inline M: binary-data >uniform-vec-array drop ; inline M:: object >uniform-matrix ( sequence cols rows -- c-array ) sequence flip cols head-slice [ rows head-slice >float-array ] { } map-as concat ; inline M: binary-data >uniform-matrix 2drop ; inline M: object >uniform-matrix-array '[ _ _ >uniform-matrix ] map concat ; inline M: binary-data >uniform-matrix-array 2drop ; inline M: object bind-uniform-bvec2 ( index sequence -- ) 1 swap 2 head-slice [ >c-bool ] int-array{ } map-as glUniform2iv ; inline M: binary-data bind-uniform-bvec2 ( index sequence -- ) 1 swap glUniform2iv ; inline M: object bind-uniform-bvec3 ( index sequence -- ) 1 swap 3 head-slice [ >c-bool ] int-array{ } map-as glUniform3iv ; inline M: binary-data bind-uniform-bvec3 ( index sequence -- ) 1 swap glUniform3iv ; inline M: object bind-uniform-bvec4 ( index sequence -- ) 1 swap 4 head-slice [ >c-bool ] int-array{ } map-as glUniform4iv ; inline M: binary-data bind-uniform-bvec4 ( index sequence -- ) 1 swap glUniform4iv ; inline M: object bind-uniform-ivec2 ( index sequence -- ) first2 glUniform2i ; inline M: binary-data bind-uniform-ivec2 ( index sequence -- ) 1 swap glUniform2iv ; inline M: object bind-uniform-ivec3 ( index sequence -- ) first3 glUniform3i ; inline M: binary-data bind-uniform-ivec3 ( index sequence -- ) 1 swap glUniform3iv ; inline M: object bind-uniform-ivec4 ( index sequence -- ) first4 glUniform4i ; inline M: binary-data bind-uniform-ivec4 ( index sequence -- ) 1 swap glUniform4iv ; inline M: object bind-uniform-uvec2 ( index sequence -- ) first2 glUniform2ui ; inline M: binary-data bind-uniform-uvec2 ( index sequence -- ) 1 swap glUniform2uiv ; inline M: object bind-uniform-uvec3 ( index sequence -- ) first3 glUniform3ui ; inline M: binary-data bind-uniform-uvec3 ( index sequence -- ) 1 swap glUniform3uiv ; inline M: object bind-uniform-uvec4 ( index sequence -- ) first4 glUniform4ui ; inline M: binary-data bind-uniform-uvec4 ( index sequence -- ) 1 swap glUniform4uiv ; inline M: object bind-uniform-vec2 ( index sequence -- ) first2 glUniform2f ; inline M: binary-data bind-uniform-vec2 ( index sequence -- ) 1 swap glUniform2fv ; inline M: object bind-uniform-vec3 ( index sequence -- ) first3 glUniform3f ; inline M: binary-data bind-uniform-vec3 ( index sequence -- ) 1 swap glUniform3fv ; inline M: object bind-uniform-vec4 ( index sequence -- ) first4 glUniform4f ; inline M: binary-data bind-uniform-vec4 ( index sequence -- ) 1 swap glUniform4fv ; inline DEFER: [bind-uniform-tuple] :: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot ) { name uniform-index } >quotation :> index-quot { index-quot value>>-quot bi* } >quotation :> pre-quot type H{ { bool-uniform { dim swap >uniform-bool-array glUniform1iv } } { int-uniform { dim swap >uniform-int-array glUniform1iv } } { uint-uniform { dim swap >uniform-uint-array glUniform1uiv } } { float-uniform { dim swap >uniform-float-array glUniform1fv } } { bvec2-uniform { dim swap 2 >uniform-bvec-array glUniform2iv } } { ivec2-uniform { dim swap 2 >uniform-ivec-array glUniform2i } } { uvec2-uniform { dim swap 2 >uniform-uvec-array glUniform2ui } } { vec2-uniform { dim swap 2 >uniform-vec-array glUniform2f } } { bvec3-uniform { dim swap 3 >uniform-bvec-array glUniform3iv } } { ivec3-uniform { dim swap 3 >uniform-ivec-array glUniform3i } } { uvec3-uniform { dim swap 3 >uniform-uvec-array glUniform3ui } } { vec3-uniform { dim swap 3 >uniform-vec-array glUniform3f } } { bvec4-uniform { dim swap 4 >uniform-bvec-array glUniform4iv } } { ivec4-uniform { dim swap 4 >uniform-ivec-array glUniform4iv } } { uvec4-uniform { dim swap 4 >uniform-uvec-array glUniform4uiv } } { vec4-uniform { dim swap 4 >uniform-vec-array glUniform4fv } } { mat2-uniform { [ dim 0 ] dip 2 2 >uniform-matrix-array glUniformMatrix2fv } } { mat2x3-uniform { [ dim 0 ] dip 2 3 >uniform-matrix-array glUniformMatrix2x3fv } } { mat2x4-uniform { [ dim 0 ] dip 2 4 >uniform-matrix-array glUniformMatrix2x4fv } } { mat3x2-uniform { [ dim 0 ] dip 3 2 >uniform-matrix-array glUniformMatrix3x2fv } } { mat3-uniform { [ dim 0 ] dip 3 3 >uniform-matrix-array glUniformMatrix3fv } } { mat3x4-uniform { [ dim 0 ] dip 3 4 >uniform-matrix-array glUniformMatrix3x4fv } } { mat4x2-uniform { [ dim 0 ] dip 4 2 >uniform-matrix-array glUniformMatrix4x2fv } } { mat4x3-uniform { [ dim 0 ] dip 4 3 >uniform-matrix-array glUniformMatrix4x3fv } } { mat4-uniform { [ dim 0 ] dip 4 4 >uniform-matrix-array glUniformMatrix4fv } } { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } } } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot type uniform-type-texture-units dim * texture-unit + pre-quot value-quot append ; :: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot ) { name uniform-index } >quotation :> index-quot { index-quot value>>-quot bi* } >quotation :> pre-quot type H{ { bool-uniform [ >c-bool glUniform1i ] } { int-uniform [ glUniform1i ] } { uint-uniform [ glUniform1ui ] } { float-uniform [ glUniform1f ] } { bvec2-uniform [ bind-uniform-bvec2 ] } { ivec2-uniform [ bind-uniform-ivec2 ] } { uvec2-uniform [ bind-uniform-uvec2 ] } { vec2-uniform [ bind-uniform-vec2 ] } { bvec3-uniform [ bind-uniform-bvec3 ] } { ivec3-uniform [ bind-uniform-ivec3 ] } { uvec3-uniform [ bind-uniform-uvec3 ] } { vec3-uniform [ bind-uniform-vec3 ] } { bvec4-uniform [ bind-uniform-bvec4 ] } { ivec4-uniform [ bind-uniform-ivec4 ] } { uvec4-uniform [ bind-uniform-uvec4 ] } { vec4-uniform [ bind-uniform-vec4 ] } { mat2-uniform [ [ 1 0 ] dip 2 2 >uniform-matrix glUniformMatrix2fv ] } { mat2x3-uniform [ [ 1 0 ] dip 2 3 >uniform-matrix glUniformMatrix2x3fv ] } { mat2x4-uniform [ [ 1 0 ] dip 2 4 >uniform-matrix glUniformMatrix2x4fv ] } { mat3x2-uniform [ [ 1 0 ] dip 3 2 >uniform-matrix glUniformMatrix3x2fv ] } { mat3-uniform [ [ 1 0 ] dip 3 3 >uniform-matrix glUniformMatrix3fv ] } { mat3x4-uniform [ [ 1 0 ] dip 3 4 >uniform-matrix glUniformMatrix3x4fv ] } { mat4x2-uniform [ [ 1 0 ] dip 4 2 >uniform-matrix glUniformMatrix4x2fv ] } { mat4x3-uniform [ [ 1 0 ] dip 4 3 >uniform-matrix glUniformMatrix4x3fv ] } { mat4-uniform [ [ 1 0 ] dip 4 4 >uniform-matrix glUniformMatrix4fv ] } { texture-uniform { drop texture-unit glUniform1i } } } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot type uniform-type-texture-units texture-unit + pre-quot value-quot append ; :: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot ) dim [ iota [ [ [ swap nth ] swap prefix ] map ] [ [ number>string name "[" append "]." surround ] map ] bi ] [ { [ ] } name "." append 1array ] if* :> ( quot-prefixes name-prefixes ) type all-uniform-tuple-slots :> uniforms texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix | uniforms name-prefix [bind-uniform-tuple] quot-prefix prepend ] 2map :> ( texture-unit' value-cleave ) texture-unit' value>>-quot { value-cleave 2cleave } append ; :: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot ) prefix uniform name>> append hyphens>underscores :> name uniform uniform-type>> :> type uniform dim>> :> dim uniform name>> reader-word 1quotation :> value>>-quot value>>-quot type texture-unit name { { [ type uniform-type? dim and ] [ dim [bind-uniform-array] ] } { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] } [ dim [bind-uniform-struct] ] } cond ; :: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot ) texture-unit uniforms [ prefix [bind-uniform] ] map :> ( texture-unit' uniforms-cleave ) texture-unit' { uniforms-cleave 2cleave } >quotation ; :: [bind-uniforms] ( superclass uniforms -- quot ) superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit superclass \ (bind-uniforms) method :> next-method first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot { 2dup next-method } bind-quot [ ] append-as ; : define-uniform-tuple-methods ( class superclass uniforms -- ) [ 2drop [ \ (bind-uniform-textures) create-method-in ] [ [bind-uniform-textures] ] bi define ] [ [ \ (bind-uniforms) create-method-in ] 2dip [bind-uniforms] define ] 3bi ; : parse-uniform-tuple-definition ( -- class superclass uniforms ) CREATE-CLASS scan { { ";" [ uniform-tuple f ] } { "<" [ scan-word parse-definition [ first3 uniform boa ] map ] } { "{" [ uniform-tuple \ } parse-until parse-definition swap prefix [ first3 uniform boa ] map ] } } case ; : (define-uniform-tuple) ( class superclass uniforms -- ) { [ [ uniform>slot ] map define-tuple-class ] [ [ uniform-type-texture-units ] [ [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ] [ + ] map-reduce ] bi* + "uniform-tuple-texture-units" set-word-prop ] [ nip "uniform-tuple-slots" set-word-prop ] [ define-uniform-tuple-methods ] } 3cleave ; : true-subclasses ( class -- seq ) [ subclasses ] keep [ = not ] curry filter ; PRIVATE> : define-uniform-tuple ( class superclass uniforms -- ) (define-uniform-tuple) ; inline SYNTAX: UNIFORM-TUPLE: parse-uniform-tuple-definition define-uniform-tuple ; int-array ] bi glDrawBuffers ] if ; : bind-named-output-attachments ( program-instance framebuffer attachments -- ) rot '[ first _ swap output-index ] sort-with [ second ] map bind-unnamed-output-attachments ; : bind-output-attachments ( program-instance framebuffer attachments -- ) dup first sequence? [ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ; GENERIC: bind-transform-feedback-output ( output -- ) M: buffer bind-transform-feedback-output [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip handle>> glBindBufferBase ; inline M: buffer-range bind-transform-feedback-output [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip [ handle>> ] [ offset>> ] [ size>> ] tri glBindBufferRange ; inline M: buffer-ptr bind-transform-feedback-output buffer-ptr>range bind-transform-feedback-output ; inline : gl-feedback-primitive-mode ( primitive-mode -- gl-mode ) { { points-mode [ GL_POINTS ] } { lines-mode [ GL_LINES ] } { line-strip-mode [ GL_LINES ] } { line-loop-mode [ GL_LINES ] } { triangles-mode [ GL_TRIANGLES ] } { triangle-strip-mode [ GL_TRIANGLES ] } { triangle-fan-mode [ GL_TRIANGLES ] } } case ; PRIVATE> UNION: ?any-framebuffer any-framebuffer POSTPONE: f ; UNION: transform-feedback-output buffer buffer-range POSTPONE: f ; TUPLE: render-set { primitive-mode primitive-mode read-only } { vertex-array vertex-array initial: T{ vertex-array-collection } read-only } { uniforms uniform-tuple read-only } { indexes vertex-indexes initial: T{ index-range } read-only } { instances ?integer initial: f read-only } { framebuffer ?any-framebuffer initial: system-framebuffer read-only } { output-attachments sequence initial: { default-attachment } read-only } { transform-feedback-output transform-feedback-output initial: f read-only } ; : ( x quot-assoc -- render-set ) render-set swap make-tuple ; inline : 2 ( x y quot-assoc -- render-set ) render-set swap 2make-tuple ; inline : 3 ( x y z quot-assoc -- render-set ) render-set swap 3make-tuple ; inline : bind-uniforms ( program-instance uniforms -- ) [ (bind-uniform-textures) ] [ (bind-uniforms) ] 2bi ; inline : render ( render-set -- ) { [ vertex-array>> program-instance>> handle>> glUseProgram ] [ [ vertex-array>> program-instance>> ] [ uniforms>> ] bi bind-uniforms ] [ framebuffer>> [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ] [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if* ] [ [ vertex-array>> program-instance>> ] [ framebuffer>> ] [ output-attachments>> ] tri bind-output-attachments ] [ vertex-array>> bind-vertex-array ] [ dup transform-feedback-output>> [ [ primitive-mode>> gl-feedback-primitive-mode glBeginTransformFeedback ] [ bind-transform-feedback-output ] bi* ] [ drop ] if* ] [ [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri [ render-vertex-indexes-instanced ] [ render-vertex-indexes ] if* ] [ transform-feedback-output>> [ glEndTransformFeedback ] when ] [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ] } cleave ; inline