render: shader: Encapsulate GLSL types in <shader-data-type> records.

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)))