summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/render/shader.scm217
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)))