diff options
| -rw-r--r-- | chickadee/render/shader.scm | 217 |
1 files changed, 109 insertions, 108 deletions
diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm index 52dfc30..bdbd08a 100644 --- a/chickadee/render/shader.scm +++ b/chickadee/render/shader.scm @@ -45,7 +45,6 @@ uniform-name uniform-type uniform-value - uniform-default-value set-uniform-value! attribute? attribute-name @@ -53,6 +52,95 @@ attribute-type *shader-state*)) + +;;; +;;; Data Types +;;; + +(define-record-type <shader-data-type> + (%make-shader-data-type name setter null) + shader-data-type? + (name shader-data-type-name) + (setter shader-data-type-setter) + (null shader-data-type-null)) + +(define* (make-shader-data-type #:key name setter null) + (%make-shader-data-type name setter null)) + +;; Primitive types: +(define %bool + (make-shader-data-type + #:name 'bool + #:setter (lambda (location bool) + (gl-uniform1i location (if bool 1 0))) + #:null #false)) + +(define %int + (make-shader-data-type + #:name 'int + #:setter (lambda (location n) + (gl-uniform1i location n)) + #:null 0)) + +(define %unsigned-int + (make-shader-data-type + #:name 'unsigned-int + #:setter (lambda (location u) + (gl-uniform1ui location u)) + #:null 0)) + +(define %float + (make-shader-data-type + #:name 'float + #:setter (lambda (location f) + (gl-uniform1f location f)) + #:null 0.0)) + +(define %float-vec2 + (make-shader-data-type + #:name 'float-vec2 + #:setter (lambda (location v) + (gl-uniform2fv location 1 (vec2->pointer v))) + #:null (vec2 0.0 0.0))) + +(define %float-vec3 + (make-shader-data-type + #:name 'float-vec3 + #:setter (lambda (location v) + (gl-uniform3fv location 1 (vec3->pointer v))) + #:null (vec3 0.0 0.0 0.0))) + +(define %float-vec4 + (make-shader-data-type + #:name 'float-vec4 + #:setter (lambda (location v) + (gl-uniform4f location + (color-r v) + (color-g v) + (color-b v) + (color-a v))) + #:null (color 0.0 0.0 0.0 0.0))) + +(define %mat4 + (make-shader-data-type + #:name 'mat4 + #:setter (let ((matrix4-ptr (@@ (chickadee math matrix) matrix4-ptr))) + (lambda (location m) + (gl-uniform-matrix4fv location 1 #f (matrix4-ptr m)))) + #:null (make-identity-matrix4))) + +(define %sampler-2d + (make-shader-data-type + #:name 'sampler-2d + #:setter (lambda (location texture-unit) + (gl-uniform1i location texture-unit)) + #:null 0)) + + +;;; +;;; Shaders +;;; + (define-record-type <shader> (%make-shader id attributes uniforms) shader? @@ -61,13 +149,12 @@ (uniforms shader-uniforms)) (define-record-type <uniform> - (make-uniform name location type value setter) + (make-uniform name location type value) uniform? (name uniform-name) (location uniform-location) (type uniform-type) - (value uniform-value %set-uniform-value!) - (setter uniform-setter)) + (value uniform-value %set-uniform-value!)) (define-record-type <attribute> (make-attribute name location type) @@ -129,100 +216,20 @@ (bytevector-copy! bv 0 bv* 0 length) (utf8->string bv*))) -(define (set-boolean-uniform! location bool) - (gl-uniform1i location (if bool 1 0))) - -(define (set-integer-uniform! location n) - (gl-uniform1i location n)) - -(define (set-unsigned-integer-uniform! location n) - (gl-uniform1ui location n)) - -(define (set-float-uniform! location n) - (gl-uniform1f location n)) - -(define (set-float-vector2-uniform! location v) - (gl-uniform2fv location 1 (vec2->pointer v))) - -(define (set-float-vector3-uniform! location v) - (gl-uniform3fv location 1 (vec3->pointer v))) - -(define (set-float-vector4-uniform! location v) - (if (color? v) - (gl-uniform4f location - (color-r v) - (color-g v) - (color-b v) - (color-a v)) - #f - ;; (gl-uniform4f location (vx v) (vy v) (vz v) (vw v)) - )) - -;; (define (set-integer-vector2-uniform! location v) -;; (gl-uniform2i location (vx v) (vy v))) - -;; (define (set-integer-vector3-uniform! location v) -;; (gl-uniform3i location (vx v) (vy v) (vz v))) - -;; (define (set-integer-vector4-uniform! location v) -;; (gl-uniform4i location (vx v) (vy v) (vz v) (vw v))) - -(define (set-float-matrix4-uniform! location m) - (gl-uniform-matrix4fv location 1 #f - ((@@ (chickadee math matrix) matrix4-ptr) m))) - -(define (set-sampler-2d-uniform! location texture-unit) - (gl-uniform1i location texture-unit)) - -(define (gl-type->symbol type) +(define (parse-data-type type) (cond - ((= type (version-2-0 bool)) 'bool) - ((= type (data-type int)) 'int) - ((= type (data-type unsigned-int)) 'unsigned-int) - ((= type (data-type float)) 'float) - ((= type (version-2-0 float-vec2)) 'float-vec2) - ((= type (version-2-0 float-vec3)) 'float-vec3) - ((= type (version-2-0 float-vec4)) 'float-vec4) - ;; ((= type (version-2-0 int-vec2)) 'int-vec2) - ;; ((= type (version-2-0 int-vec3)) 'int-vec3) - ;; ((= type (version-2-0 int-vec4)) 'int-vec4) - ((= type (version-2-0 float-mat4)) 'mat4) - ((= type (version-2-0 sampler-2d)) 'sampler-2d) + ((= type (version-2-0 bool)) %bool) + ((= type (data-type int)) %int) + ((= type (data-type unsigned-int)) %unsigned-int) + ((= type (data-type float)) %float) + ((= type (version-2-0 float-vec2)) %float-vec2) + ((= type (version-2-0 float-vec3)) %float-vec3) + ((= type (version-2-0 float-vec4)) %float-vec4) + ((= type (version-2-0 float-mat4)) %mat4) + ((= type (version-2-0 sampler-2d)) %sampler-2d) (else (error "unsupported OpenGL type" type)))) -(define %default-mat4 (make-identity-matrix4)) - -(define (default-uniform-value type) - (match type - ('bool #f) - ('int 0) - ('unsigned-int 0) - ('float 0.0) - ('float-vec2 #v(0.0 0.0)) - ('float-vec3 #v(0.0 0.0 0.0)) - ('float-vec4 (make-color 0.0 0.0 0.0 0.0)) - ;; ('int-vec2 (vector2 0 0)) - ;; ('int-vec3 (vector3 0 0 0)) - ;; ('int-vec4 (vector4 0 0 0 0)) - ('mat4 %default-mat4))) - -(define (uniform-setter-for-type type) - ;; TODO: Handle more data types, notably matrices. - (match type - ('bool set-boolean-uniform!) - ('int set-integer-uniform!) - ('unsigned-int set-unsigned-integer-uniform!) - ('float set-float-uniform!) - ('float-vec2 set-float-vector2-uniform!) - ('float-vec3 set-float-vector3-uniform!) - ('float-vec4 set-float-vector4-uniform!) - ;; ('int-vec2 set-integer-vector2-uniform!) - ;; ('int-vec3 set-integer-vector3-uniform!) - ;; ('int-vec4 set-integer-vector4-uniform!) - ('mat4 set-float-matrix4-uniform!) - ('sampler-2d set-sampler-2d-uniform!))) - (define (extract-uniforms id) (let ((total (uniform-count id)) (table (make-hash-table))) @@ -239,23 +246,21 @@ (bytevector->pointer size-bv) (bytevector->pointer type-bv) (bytevector->pointer name-bv)) - (let* ((length (u32vector-ref length-bv 0)) - (name (utf8->string* name-bv length)) + (let* ((name-length (u32vector-ref length-bv 0)) + (name (utf8->string* name-bv name-length)) (location (gl-get-uniform-location id name)) (size (u32vector-ref size-bv 0)) - (type (gl-type->symbol (u32vector-ref type-bv 0))) - (sampler? (eq? type 'sampler-2d)) + (type (parse-data-type (u32vector-ref type-bv 0))) + (sampler? (eq? type %sampler-2d)) (default (if sampler? texture-unit - (default-uniform-value type))) - (setter (uniform-setter-for-type type))) + (shader-data-type-null type)))) ;; TODO: Handle uniform arrays. (unless (= size 1) (error "unsupported uniform size" name size)) - (hash-set! table name - (make-uniform name location type default setter)) + (make-uniform name location type default)) (loop (1+ i) (if sampler? (1+ texture-unit) @@ -287,7 +292,7 @@ (let* ((length (u32vector-ref length-bv 0)) (name (utf8->string* name-bv length)) (size (u32vector-ref size-bv 0)) - (type (gl-type->symbol (u32vector-ref type-bv 0))) + (type (parse-data-type (u32vector-ref type-bv 0))) (location (gl-get-attrib-location id name))) (unless (= size 1) (error "unsupported attribute size" name size)) @@ -360,9 +365,5 @@ shader program." shader where UNIFORM is defined is currently bound in the OpenGL context. The behavior of this procedure under any other circumstance is undefined." - ((uniform-setter uniform) (uniform-location uniform) x) + ((shader-data-type-setter (uniform-type uniform)) (uniform-location uniform) x) (%set-uniform-value! uniform x)) - -(define (uniform-default-value uniform) - "Return the default value of UNIFORM." - (default-uniform-value (uniform-type uniform))) |