From 628e7203ceea95817a8cf2e55c49dc3c44f2752e Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Thu, 14 Sep 2023 22:13:42 -0400
Subject: graphics: Factor out GL calls in shader module.

---
 chickadee/graphics/gpu.scm    | 175 +++++++++++++++++++++++++++++++++++++++
 chickadee/graphics/shader.scm | 188 +++++++++++++-----------------------------
 2 files changed, 232 insertions(+), 131 deletions(-)

diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm
index ef12d10..66d2c31 100644
--- a/chickadee/graphics/gpu.scm
+++ b/chickadee/graphics/gpu.scm
@@ -165,12 +165,32 @@
             free-gpu-shader
             gpu-shader?
             gpu-shader-id
+            gpu-shader-compiled?
+            gpu-shader-info-log
+            set-gpu-shader-source
+            gpu-shader-compile
             gpu-shader:null
 
             fresh-gpu-program
             free-gpu-program
             gpu-program?
             gpu-program-id
+            gpu-program-linked?
+            gpu-program-attach-shader
+            gpu-program-link
+            gpu-program-info-log
+            gpu-program-uniform-count
+            gpu-program-attribute-count
+            gpu-program-uniform-ref
+            gpu-program-attribute-ref
+            set-gpu-program-uniform:signed-int
+            set-gpu-program-uniform:unsigned-int
+            set-gpu-program-uniform:float
+            set-gpu-program-uniform:vec2
+            set-gpu-program-uniform:vec3
+            set-gpu-program-uniform:vec4
+            set-gpu-program-uniform:mat3
+            set-gpu-program-uniform:mat4
             gpu-program:null
 
             make-gpu
@@ -1255,3 +1275,158 @@
                               (symbol->data-type type)
                               (offset->pointer offset)
                               instances))
+
+(define (gpu-shader-compiled? shader)
+  (let ((status (make-u32vector 1)))
+    (gl-get-shaderiv (gpu-shader-id shader)
+                     (version-2-0 compile-status)
+                     (bytevector->pointer status))
+    (= (u32vector-ref status 0) 1)))
+
+(define (set-gpu-shader-source shader source)
+  (let ((bv (string->utf8 source)))
+    (gl-shader-source (gpu-shader-id shader)
+                      1
+                      (bytevector->pointer
+                       (u64vector
+                        (pointer-address (bytevector->pointer bv))))
+                      (bytevector->pointer
+                       (u32vector (bytevector-length bv))))))
+
+(define (gpu-shader-compile shader)
+  (gl-compile-shader (gpu-shader-id shader)))
+
+(define (set-gpu-program-uniform:signed-int location ptr)
+  (gl-uniform1iv location 1 ptr))
+
+(define (set-gpu-program-uniform:unsigned-int location ptr)
+  (gl-uniform1uiv location 1 ptr))
+
+(define (set-gpu-program-uniform:float location ptr)
+  (gl-uniform1fv location 1 ptr))
+
+(define (set-gpu-program-uniform:vec2 location ptr)
+  (gl-uniform2fv location 1 ptr))
+
+(define (set-gpu-program-uniform:vec3 location ptr)
+  (gl-uniform3fv location 1 ptr))
+
+(define (set-gpu-program-uniform:vec4 location ptr)
+  (gl-uniform4fv location 1 ptr))
+
+(define (set-gpu-program-uniform:mat3 location ptr)
+  (gl-uniform-matrix3fv location 1 #f ptr))
+
+(define (set-gpu-program-uniform:mat4 location ptr)
+  (gl-uniform-matrix4fv location 1 #f ptr))
+
+(define (gpu-program-linked? program)
+  (let ((status (make-u32vector 1)))
+    (gl-get-programiv (gpu-program-id program)
+                      (version-2-0 link-status)
+                      (bytevector->pointer status))
+    (= (u32vector-ref status 0) 1)))
+
+(define (gpu-shader-info-log shader)
+    (let ((log-length-bv (make-u32vector 1)))
+      (gl-get-shaderiv (gpu-shader-id shader) (version-2-0 info-log-length)
+                       (bytevector->pointer log-length-bv))
+      (u32vector-ref log-length-bv 0)
+      ;; Add one byte to account for the null string terminator.
+      (let* ((log-length (u32vector-ref log-length-bv 0))
+             (log (make-u8vector (1+ log-length))))
+        (gl-get-shader-info-log (gpu-shader-id shader) log-length
+                                %null-pointer (bytevector->pointer log))
+        (utf8->string log))))
+
+(define (gpu-program-info-log program)
+    (let ((log-length-bv (make-u32vector 1)))
+      (gl-get-shaderiv (gpu-shader-id program) (version-2-0 info-log-length)
+                       (bytevector->pointer log-length-bv))
+      (u32vector-ref log-length-bv 0)
+      ;; Add one byte to account for the null string terminator.
+      (let* ((log-length (u32vector-ref log-length-bv 0))
+             (log (make-u8vector (1+ log-length))))
+        (gl-get-shader-info-log (gpu-shader-id program) log-length
+                                %null-pointer (bytevector->pointer log))
+        (utf8->string log))))
+
+(define (gpu-program-attach-shader program shader)
+  (gl-attach-shader (gpu-program-id program) (gpu-shader-id shader)))
+
+(define (gpu-program-link program)
+  (gl-link-program (gpu-program-id program)))
+
+(define (gpu-program-uniform-count program)
+  (let ((bv (make-u32vector 1)))
+    (gl-get-programiv (gpu-program-id program)
+                      (arb-shader-objects active-uniforms)
+                      (bytevector->pointer bv))
+    (u32vector-ref bv 0)))
+
+(define (gpu-program-attribute-count program)
+  (let ((bv (make-u32vector 1)))
+    (gl-get-programiv (gpu-program-id program)
+                      (arb-shader-objects active-attributes)
+                      (bytevector->pointer bv))
+    (u32vector-ref bv 0)))
+
+(define (utf8->string* bv length)
+  (let ((bv* (make-bytevector length)))
+    (bytevector-copy! bv 0 bv* 0 length)
+    (utf8->string bv*)))
+
+(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 float-mat3)) 'mat3)
+   ((= type (version-2-0 float-mat4)) 'mat4)
+   ((= type (version-2-0 sampler-2d)) 'sampler-2d)
+   ((= type (version-2-0 sampler-cube)) 'sampler-cube)
+   (else
+    (error "unsupported OpenGL uniform type" type))))
+
+(define (gpu-program-uniform-ref program index)
+  (let ((length-bv (make-u32vector 1))
+        (size-bv (make-u32vector 1))
+        (type-bv (make-u32vector 1))
+        (name-bv (make-bytevector 255)))
+    (gl-get-active-uniform (gpu-program-id program)
+                           index
+                           (bytevector-length name-bv)
+                           (bytevector->pointer length-bv)
+                           (bytevector->pointer size-bv)
+                           (bytevector->pointer type-bv)
+                           (bytevector->pointer name-bv))
+    (let* ((name-length (u32vector-ref length-bv 0))
+           (name (utf8->string* name-bv name-length))
+           (location (gl-get-uniform-location (gpu-program-id program) name))
+           (size (u32vector-ref size-bv 0))
+           (type (parse-data-type (u32vector-ref type-bv 0))))
+      (values name location size type))))
+
+(define (gpu-program-attribute-ref program index)
+  (let ((length-bv (make-u32vector 1))
+              (size-bv (make-u32vector 1))
+              (type-bv (make-u32vector 1))
+              (name-bv (make-bytevector 255)))
+          (gl-get-active-attrib (gpu-program-id program)
+                                index
+                                (bytevector-length name-bv)
+                                (bytevector->pointer length-bv)
+                                (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))
+                 (size (u32vector-ref size-bv 0))
+                 (type (parse-data-type (u32vector-ref type-bv 0)))
+                 (location (gl-get-attrib-location (gpu-program-id program)
+                                                   name)))
+            (values name location size type))))
diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm
index f1e930f..9974b38 100644
--- a/chickadee/graphics/shader.scm
+++ b/chickadee/graphics/shader.scm
@@ -25,14 +25,12 @@
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
-  #:use-module (gl)
   #:use-module (chickadee math matrix)
   #:use-module (chickadee math vector)
   #:use-module (chickadee math rect)
   #:use-module (chickadee graphics buffer)
   #:use-module (chickadee graphics color)
   #:use-module (chickadee graphics engine)
-  #:use-module (chickadee graphics gl)
   #:use-module (chickadee graphics gpu)
   #:use-module (chickadee graphics texture)
   #:use-module (chickadee utils)
@@ -56,7 +54,6 @@
             make-shader
             shader?
             null-shader
-            g:shader
             current-shader
             load-shader
             strings->shader
@@ -113,8 +110,8 @@
             (serialize bv (* i size) (vector-ref data i))))
         (serialize bv 0 data))))
 
-(define (shader-primitive-type-apply-uniform type location count pointer)
-  ((shader-primitive-type-setter type) location count pointer))
+(define (shader-primitive-type-apply-uniform type location pointer)
+  ((shader-primitive-type-setter type) location pointer))
 
 (define (shader-primitive-type-validate type data)
   (let ((valid? (shader-primitive-type-validator type)))
@@ -137,7 +134,7 @@
   #:serializer
   (lambda (bv i bool)
     (bytevector-s32-native-set! bv i (if bool 1 0)))
-  #:setter gl-uniform1iv
+  #:setter set-gpu-program-uniform:signed-int
   #:null #false)
 
 (define-shader-primitive-type int
@@ -147,7 +144,7 @@
   #:serializer
   (lambda (bv i n)
     (bytevector-s32-native-set! bv i n))
-  #:setter gl-uniform1iv
+  #:setter set-gpu-program-uniform:signed-int
   #:null 0)
 
 (define-shader-primitive-type unsigned-int
@@ -159,7 +156,7 @@
   #:serializer
   (lambda (bv i u)
     (bytevector-u32-native-set! bv i u))
-  #:setter gl-uniform1uiv
+  #:setter set-gpu-program-uniform:unsigned-int
   #:null 0)
 
 (define-shader-primitive-type float
@@ -169,7 +166,7 @@
   #:serializer
   (lambda (bv i f)
     (bytevector-ieee-single-native-set! bv i f))
-  #:setter gl-uniform1fv
+  #:setter set-gpu-program-uniform:float
   #:null 0.0)
 
 (define-shader-primitive-type float-vec2
@@ -180,7 +177,7 @@
   (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2)))
     (lambda (bv i v)
       (bytevector-copy! (unwrap-vec2 v) 0 bv i 8)))
-  #:setter gl-uniform2fv
+  #:setter set-gpu-program-uniform:vec2
   #:null (vec2 0.0 0.0))
 
 (define-shader-primitive-type float-vec3
@@ -191,7 +188,7 @@
   (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3)))
     (lambda (bv i v)
       (bytevector-copy! (unwrap-vec3 v) 0 bv i 12)))
-  #:setter gl-uniform3fv
+  #:setter set-gpu-program-uniform:vec3
   #:null (vec3 0.0 0.0 0.0))
 
 (define-shader-primitive-type float-vec4
@@ -199,19 +196,18 @@
   #:size 16 ; 16 bytes = 4 floats = 1 vec4
   #:validator (lambda (x) (or (rect? x) (color? x)))
   #:serializer
-  (let ((unwrap-rect (@@ (chickadee math rect) unwrap-rect)))
+  (let ((unwrap-rect (@@ (chickadee math rect) unwrap-rect))
+        (unwrap-color (@@ (chickadee graphics color) unwrap-color)))
     (lambda (bv i v)
       ;; As of now, there is no vec4 Scheme type, but we do want to
       ;; accept colors and rects as vec4s since there is no special
       ;; color or rect type in GLSL.
-      (if (rect? v)
-          (bytevector-copy! (unwrap-rect v) 0 bv i 16)
-          (begin
-            (bytevector-ieee-single-native-set! bv i (color-r v))
-            (bytevector-ieee-single-native-set! bv (+ i 4) (color-g v))
-            (bytevector-ieee-single-native-set! bv (+ i 8) (color-b v))
-            (bytevector-ieee-single-native-set! bv (+ i 12) (color-a v))))))
-  #:setter gl-uniform4fv
+      (cond
+       ((rect? v)
+        (bytevector-copy! (unwrap-rect v) 0 bv i 16))
+       ((color? v)
+        (bytevector-copy! (unwrap-color v) 0 bv i 16)))))
+  #:setter set-gpu-program-uniform:vec4
   #:null (make-null-rect))
 
 (define-shader-primitive-type mat3
@@ -222,8 +218,7 @@
   (let ((matrix3-bv (@@ (chickadee math matrix) matrix3-bv)))
     (lambda (bv i m)
       (bytevector-copy! (matrix3-bv m) 0 bv i (* 3 3 4))))
-  #:setter (lambda (location count ptr)
-             (gl-uniform-matrix3fv location count #f ptr))
+  #:setter set-gpu-program-uniform:mat3
   #:null (make-identity-matrix3))
 
 (define-shader-primitive-type mat4
@@ -235,8 +230,7 @@
     (lambda (bv i m)
       ;; 4 rows x 4 columns x 4 bytes per float = 4^3
       (bytevector-copy! (matrix4-bv m) 0 bv i (* 4 4 4))))
-  #:setter (lambda (location count ptr)
-             (gl-uniform-matrix4fv location count #f ptr))
+  #:setter set-gpu-program-uniform:mat4
   #:null (make-identity-matrix4))
 
 (define-shader-primitive-type sampler-2d
@@ -246,7 +240,7 @@
   #:serializer
   (lambda (bv i texture-unit)
     (bytevector-s32-native-set! bv i texture-unit))
-  #:setter gl-uniform1iv
+  #:setter set-gpu-program-uniform:signed-int
   #:null 0)
 
 (define-shader-primitive-type sampler-cube
@@ -256,7 +250,7 @@
   #:serializer
   (lambda (bv i texture-unit)
     (bytevector-s32-native-set! bv i texture-unit))
-  #:setter gl-uniform1iv
+  #:setter set-gpu-program-uniform:signed-int
   #:null 0)
 
 
@@ -502,38 +496,12 @@
   (location attribute-location)
   (type attribute-type))
 
-(define null-shader (%make-shader gpu-program:null (make-hash-table) (make-hash-table) #f #f))
+(define null-shader
+  (%make-shader gpu-program:null (make-hash-table) (make-hash-table) #f #f))
 
 (define (make-shader vertex-port fragment-port)
   "Read GLSL source from VERTEX-PORT and FRAGMENT-PORT and compile
 them into a GPU shader program."
-  (define (shader-compiled? id)
-    (let ((status (make-u32vector 1)))
-      (gl-get-shaderiv (gpu-shader-id id)
-                       (version-2-0 compile-status)
-                       (bytevector->pointer status))
-      (= (u32vector-ref status 0) 1)))
-  (define (shader-linked? id)
-    (let ((status (make-u32vector 1)))
-      (gl-get-programiv (gpu-program-id id)
-                        (version-2-0 link-status)
-                        (bytevector->pointer status))
-      (= (u32vector-ref status 0) 1)))
-  (define (info-log length-proc log-proc id)
-    (let ((log-length-bv (make-u32vector 1)))
-      (length-proc (gpu-shader-id id) (version-2-0 info-log-length)
-                   (bytevector->pointer log-length-bv))
-      (u32vector-ref log-length-bv 0)
-      ;; Add one byte to account for the null string terminator.
-      (let* ((log-length (u32vector-ref log-length-bv 0))
-             (log (make-u8vector (1+ log-length))))
-        (log-proc (gpu-shader-id id) log-length %null-pointer
-                  (bytevector->pointer log))
-        (utf8->string log))))
-  (define (compilation-error id)
-    (info-log gl-get-shaderiv gl-get-shader-info-log id))
-  (define (linking-error id)
-    (info-log gl-get-programiv gl-get-program-info-log id))
   (define (glsl-preprocessor-source)
     ;; Set up preprocessor directives dynamically based on the current
     ;; OpenGL context's GLSL version so that we can write shaders that
@@ -557,49 +525,32 @@ them into a GPU shader program."
         (error "incompatible GLSL version" glsl-version)))))
   (define (make-shader-stage type port)
     (let* ((gpu (current-gpu))
-           (id (fresh-gpu-shader gpu type))
-           (source (string->utf8
-                    (string-append (glsl-preprocessor-source)
-                                   (get-string-all port)))))
-      (gl-shader-source (gpu-shader-id id) 1
-                        (bytevector->pointer
-                         (u64vector
-                          (pointer-address (bytevector->pointer source))))
-                        (bytevector->pointer
-                         (u32vector (bytevector-length source))))
-      (gl-compile-shader (gpu-shader-id id))
-      (unless (shader-compiled? id)
-        (let ((error-log (compilation-error id)))
+           (id (fresh-gpu-shader gpu type)))
+      (set-gpu-shader-source id (string-append (glsl-preprocessor-source)
+                                               (get-string-all port)))
+      (gpu-shader-compile id)
+      (unless (gpu-shader-compiled? id)
+        (let ((error-log (gpu-shader-info-log id)))
           (free-gpu-shader id) ; clean up GPU resource.
           (display "shader compilation failed:\n")
           (display error-log (current-error-port))
           (error "failed to compile shader")))
       id))
-  (define (uniform-count id)
-    (let ((bv (make-u32vector 1)))
-      (gl-get-programiv (gpu-program-id id)
-                        (arb-shader-objects active-uniforms)
-                        (bytevector->pointer bv))
-      (u32vector-ref bv 0)))
-  (define (utf8->string* bv length)
-    (let ((bv* (make-bytevector length)))
-      (bytevector-copy! bv 0 bv* 0 length)
-      (utf8->string bv*)))
   (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 float-mat3)) mat3)
-     ((= type (version-2-0 float-mat4)) mat4)
-     ((= type (version-2-0 sampler-2d)) sampler-2d)
-     ((= type (version-2-0 sampler-cube)) sampler-cube)
+    (match type
+     ('bool bool)
+     ('int int)
+     ('unsigned-int unsigned-int)
+     ('float float)
+     ('float-vec2 float-vec2)
+     ('float-vec3 float-vec3)
+     ('float-vec4 float-vec4)
+     ('mat3 mat3)
+     ('mat4 mat4)
+     ('sampler-2d sampler-2d)
+     ('sampler-cube sampler-cube)
      (else
-      (error "unsupported OpenGL type" type))))
+      (error "unsupported uniform type" type))))
   (define (camel->snake str)
     (list->string
      (let loop ((i 0))
@@ -652,7 +603,7 @@ them into a GPU shader program."
                                                                  new-name)))
                  (inner rest new-namespace))))))))
   (define (extract-uniforms id)
-    (let ((total (uniform-count id))
+    (let ((total (gpu-program-uniform-count id))
           (namespace (fresh-uniform-namespace "root")))
       ;; OpenGL has an API for shader program introspection that we
       ;; use to extract all active uniforms.  This uniform data must
@@ -668,18 +619,9 @@ them into a GPU shader program."
                   (size-bv (make-u32vector 1))
                   (type-bv (make-u32vector 1))
                   (name-bv (make-bytevector 255)))
-              (gl-get-active-uniform (gpu-program-id id)
-                                     i
-                                     (bytevector-length name-bv)
-                                     (bytevector->pointer length-bv)
-                                     (bytevector->pointer size-bv)
-                                     (bytevector->pointer type-bv)
-                                     (bytevector->pointer name-bv))
-              (let* ((name-length (u32vector-ref length-bv 0))
-                     (name (utf8->string* name-bv name-length))
-                     (location (gl-get-uniform-location (gpu-program-id id) name))
-                     (size (u32vector-ref size-bv 0))
-                     (type (parse-data-type (u32vector-ref type-bv 0)))
+              (define-values (name location size %type)
+                (gpu-program-uniform-ref id i))
+              (let* ((type (parse-data-type %type))
                      (sampler? (or (eq? type sampler-2d) (eq? type sampler-cube)))
                      (default (cond
                                (sampler?
@@ -709,46 +651,30 @@ them into a GPU shader program."
                            (* size
                               (shader-primitive-type-size type))))))
             (values namespace scratch-size)))))
-  (define (attribute-count id)
-    (let ((bv (make-u32vector 1)))
-      (gl-get-programiv (gpu-program-id id)
-                        (arb-shader-objects active-attributes)
-                        (bytevector->pointer bv))
-      (u32vector-ref bv 0)))
   (define (extract-attributes id)
-    (let ((total (attribute-count id))
+    (let ((total (gpu-program-attribute-count id))
           (table (make-hash-table)))
       (for-range ((i total))
         (let ((length-bv (make-u32vector 1))
               (size-bv (make-u32vector 1))
               (type-bv (make-u32vector 1))
               (name-bv (make-bytevector 255)))
-          (gl-get-active-attrib (gpu-program-id id)
-                                i
-                                (bytevector-length name-bv)
-                                (bytevector->pointer length-bv)
-                                (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))
-                 (size (u32vector-ref size-bv 0))
-                 (type (parse-data-type (u32vector-ref type-bv 0)))
-                 (location (gl-get-attrib-location (gpu-program-id id) name)))
-            (unless (= size 1)
-              (error "unsupported attribute size" name size))
-            (hash-set! table name (make-attribute name location type)))))
+          (define-values (name location size type)
+            (gpu-program-attribute-ref id i))
+          (unless (= size 1)
+            (error "unsupported attribute size" name size))
+          (hash-set! table name (make-attribute name location type))))
       table))
   (assert-current-graphics-engine)
   (let* ((gpu (current-gpu))
          (vertex-id (make-shader-stage 'vertex vertex-port))
          (fragment-id (make-shader-stage 'fragment fragment-port))
          (id (fresh-gpu-program gpu)))
-    (gl-attach-shader (gpu-program-id id) (gpu-shader-id vertex-id))
-    (gl-attach-shader (gpu-program-id id) (gpu-shader-id fragment-id))
-    (gl-link-program (gpu-program-id id))
-    (unless (shader-linked? id)
-      (let ((error-log (linking-error id)))
+    (gpu-program-attach-shader id vertex-id)
+    (gpu-program-attach-shader id fragment-id)
+    (gpu-program-link id)
+    (unless (gpu-program-linked? id)
+      (let ((error-log (gpu-program-info-log id)))
         (free-gpu-program id)
         (error "failed to link shader" error-log)))
     (free-gpu-shader vertex-id)
@@ -791,7 +717,7 @@ shader program."
   ;; updates.  Maybe UBOs would help address this?
   (let ((type (uniform-type uniform)))
     (shader-primitive-type-serialize type (shader-scratch shader) value)
-    (shader-primitive-type-apply-uniform type (uniform-location uniform) 1
+    (shader-primitive-type-apply-uniform type (uniform-location uniform)
                                          (shader-scratch-pointer shader))
     (%set-uniform-value! uniform value)))
 
-- 
cgit v1.2.3