diff options
| -rw-r--r-- | chickadee/render.scm | 13 | ||||
| -rw-r--r-- | chickadee/render/shader.scm | 624 |
2 files changed, 490 insertions, 147 deletions
diff --git a/chickadee/render.scm b/chickadee/render.scm index b898cb5..edf21f7 100644 --- a/chickadee/render.scm +++ b/chickadee/render.scm @@ -133,10 +133,10 @@ (syntax-case x () ((_ shader ()) (datum->syntax x #t)) ((_ shader (name value . rest)) - (with-syntax ((sname (datum->syntax x (keyword->string + (with-syntax ((sname (datum->syntax x (keyword->symbol (syntax->datum #'name))))) #'(begin - (shader-uniform-set! shader sname value) + (shader-uniform-set! shader 'sname value) (uniform-apply shader rest))))))) (define-syntax-rule (gpu-prepare shader vertex-array uniforms) @@ -157,10 +157,11 @@ ;; Sampler2D values aren't explicitly passed as uniform values via ;; gpu-apply, so we have to set their values correctly behind the ;; scenes. - (hash-for-each (lambda (name uniform) - (when (eq? 'sampler-2d (uniform-type uniform)) - (shader-uniform-set! shader (uniform-name uniform) (uniform-value uniform)))) - (shader-uniforms shader)))) + (uniform-namespace-for-each + (lambda (name uniform) + (when (and (uniform? uniform) (eq? 'sampler-2d (uniform-type uniform))) + (shader-uniform-set! shader (uniform-name uniform) (uniform-value uniform)))) + (shader-uniforms shader)))) (define-syntax-rule (gpu-apply* shader vertex-array count . uniforms) (begin diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm index e3b80c9..19f1f3c 100644 --- a/chickadee/render/shader.scm +++ b/chickadee/render/shader.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016 David Thompson <davet@gnu.org> +;;; Copyright © 2016, 2019 David Thompson <davet@gnu.org> ;;; ;;; Chickadee is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published @@ -16,8 +16,11 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (chickadee render shader) + #:use-module (ice-9 format) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 regex) #:use-module (oop goops) #:use-module (system foreign) #:use-module (rnrs bytevectors) @@ -33,7 +36,21 @@ #:use-module (chickadee render gl) #:use-module (chickadee render gpu) #:use-module (chickadee render texture) - #:export (make-shader + #:export (shader-data-type? + bool + int + unsigned-int + float + float-vec2 + float-vec3 + float-vec4 + mat4 + sampler-2d + uniform-namespace? + uniform-namespace-ref + uniform-namespace-for-each + define-shader-type + make-shader shader? null-shader load-shader @@ -58,16 +75,25 @@ ;;; (define-record-type <shader-data-type> - (%make-shader-data-type name size serializer setter null) + (%make-shader-data-type name size validator serializer setter null) shader-data-type? (name shader-data-type-name) (size shader-data-type-size) + (validator shader-data-type-validator) (serializer shader-data-type-serializer) (setter shader-data-type-setter) (null shader-data-type-null)) -(define* (make-shader-data-type #:key name size serializer setter null) - (%make-shader-data-type name size serializer setter null)) +(define (display-shader-data-type type port) + (format port "#<shader-data-type name: ~a size: ~d null: ~a>" + (shader-data-type-name type) + (shader-data-type-size type) + (shader-data-type-null type))) + +(set-record-type-printer! <shader-data-type> display-shader-data-type) + +(define* (make-shader-data-type #:key name size validator serializer setter null) + (%make-shader-data-type name size validator serializer setter null)) (define (shader-data-type-serialize type bv data) (let ((serialize (shader-data-type-serializer type))) @@ -82,107 +108,262 @@ (define (shader-data-type-apply-uniform type location count pointer) ((shader-data-type-setter type) location count pointer)) +(define (shader-data-type-validate type data) + (let ((valid? (shader-data-type-validator type))) + (if (vector? data) + (let loop ((i 0)) + (if (and (< i (vector-length data)) + (valid? (vector-ref data i))) + (loop (+ i 1)) + #t)) + (valid? data)))) + +(define-syntax-rule (define-shader-data-type var . args) + (define var (make-shader-data-type . args))) + ;; Primitive types: -(define %bool - (make-shader-data-type - #:name 'bool - #:size 4 - #:serializer - (lambda (bv i bool) - (bytevector-s32-native-set! bv i (if bool 1 0))) - #:setter gl-uniform1iv - #:null #false)) - -(define %int - (make-shader-data-type - #:name 'int - #:size 4 - #:serializer - (lambda (bv i n) - (bytevector-s32-native-set! bv i n)) - #:setter gl-uniform1iv - #:null 0)) - -(define %unsigned-int - (make-shader-data-type - #:name 'unsigned-int - #:size 4 - #:serializer - (lambda (bv i u) - (bytevector-u32-native-set! bv i u)) - #:setter gl-uniform1uiv - #:null 0)) - -(define %float - (make-shader-data-type - #:name 'float - #:size 4 - #:serializer - (lambda (bv i f) - (bytevector-ieee-single-native-set! bv i f)) - #:setter gl-uniform1fv - #:null 0.0)) - -(define %float-vec2 - (make-shader-data-type - #:name 'float-vec2 - #:size 8 ; 8 bytes = 2 floats = 1 vec2 - #:serializer - (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2))) - (lambda (bv i v) - (bytevector-copy! (unwrap-vec2 v) 0 bv i 8))) - #:setter gl-uniform2fv - #:null (vec2 0.0 0.0))) - -(define %float-vec3 - (make-shader-data-type - #:name 'float-vec3 - #:size 12 ; 12 bytes = 3 floats = 1 vec3 - #:serializer - (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3))) - (lambda (bv i v) - (bytevector-copy! (unwrap-vec3 v) 0 bv i 12))) - #:setter gl-uniform3fv - #:null (vec3 0.0 0.0 0.0))) - -(define %float-vec4 - (make-shader-data-type - #:name 'float-vec4 - #:size 16 ; 16 bytes = 4 floats = 1 vec4 - #:serializer - (lambda (bv i v) - ;; As of now, there is no vec4 Scheme type, but we do want to - ;; accept colors as vec4s since there is no special color type in - ;; GLSL. - (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 - #:null (color 0.0 0.0 0.0 0.0))) - -(define %mat4 - (make-shader-data-type - #:name 'mat4 - #:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes - #:serializer - (let ((matrix4-bv (@@ (chickadee math matrix) matrix4-bv))) - (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)) - #:null (make-identity-matrix4))) - -(define %sampler-2d - (make-shader-data-type - #:name 'sampler-2d - #:size 4 - #:serializer - (lambda (bv i texture-unit) - (bytevector-s32-native-set! bv i texture-unit)) - #:setter gl-uniform1iv - #:null 0)) +(define-shader-data-type bool + #:name 'bool + #:size 4 + #:validator boolean? + #:serializer + (lambda (bv i bool) + (bytevector-s32-native-set! bv i (if bool 1 0))) + #:setter gl-uniform1iv + #:null #false) + +(define-shader-data-type int + #:name 'int + #:size 4 + #:validator integer? + #:serializer + (lambda (bv i n) + (bytevector-s32-native-set! bv i n)) + #:setter gl-uniform1iv + #:null 0) + +(define-shader-data-type unsigned-int + #:name 'unsigned-int + #:size 4 + #:validator + (lambda (i) + (and (integer? i) (>= i 0))) + #:serializer + (lambda (bv i u) + (bytevector-u32-native-set! bv i u)) + #:setter gl-uniform1uiv + #:null 0) + +(define-shader-data-type float + #:name 'float + #:size 4 + #:validator number? + #:serializer + (lambda (bv i f) + (bytevector-ieee-single-native-set! bv i f)) + #:setter gl-uniform1fv + #:null 0.0) + +(define-shader-data-type float-vec2 + #:name 'float-vec2 + #:size 8 ; 8 bytes = 2 floats = 1 vec2 + #:validator vec2? + #:serializer + (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2))) + (lambda (bv i v) + (bytevector-copy! (unwrap-vec2 v) 0 bv i 8))) + #:setter gl-uniform2fv + #:null (vec2 0.0 0.0)) + +(define-shader-data-type float-vec3 + #:name 'float-vec3 + #:size 12 ; 12 bytes = 3 floats = 1 vec3 + #:validator vec3? + #:serializer + (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3))) + (lambda (bv i v) + (bytevector-copy! (unwrap-vec3 v) 0 bv i 12))) + #:setter gl-uniform3fv + #:null (vec3 0.0 0.0 0.0)) + +(define-shader-data-type float-vec4 + #:name 'float-vec4 + #:size 16 ; 16 bytes = 4 floats = 1 vec4 + #:validator color? + #:serializer + (lambda (bv i v) + ;; As of now, there is no vec4 Scheme type, but we do want to + ;; accept colors as vec4s since there is no special color type in + ;; GLSL. + (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 + #:null (color 0.0 0.0 0.0 0.0)) + +(define-shader-data-type mat4 + #:name 'mat4 + #:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes + #:validator matrix4? + #:serializer + (let ((matrix4-bv (@@ (chickadee math matrix) matrix4-bv))) + (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)) + #:null (make-identity-matrix4)) + +(define-shader-data-type sampler-2d + #:name 'sampler-2d + #:size 4 + #:validator integer? + #:serializer + (lambda (bv i texture-unit) + (bytevector-s32-native-set! bv i texture-unit)) + #:setter gl-uniform1iv + #:null 0) + + +;;; +;;; Shader Structs +;;; + +;; A meta-vtable that has two additional slots: one for the struct +;; name, and another for the lookup table that maps struct field names +;; to their respective struct index and shader data type. +(define <shader-struct> + (make-vtable (string-append standard-vtable-fields "pwpw") + (lambda (vt port) + (format port "#<shader-struct ~a>" + (shader-struct-fields vt))))) + +(define (shader-struct? struct) + (eq? (struct-vtable (struct-vtable struct)) <shader-struct>)) + +(define shader-struct-name-index vtable-offset-user) +(define shader-struct-fields-index (+ vtable-offset-user 1)) + +(define (shader-struct-name vtable) + (struct-ref vtable shader-struct-name-index)) + +(define (shader-struct-fields vtable) + (struct-ref vtable shader-struct-fields-index)) + +(define (shader-struct-type-check vtable field value) + (match (assq-ref (shader-struct-fields vtable) field) + ((_ type size) + (define (validate value) + (unless (or (and (struct? value) (eq? (struct-vtable value) type)) + (shader-data-type-validate type value)) + (error "invalid type for shader struct field" field value))) + (cond + ((= size 1) + (validate value)) + ((and (vector? value) + (= (vector-length value) size)) + (let loop ((i 0)) + (when (< i (vector-length value)) + (validate (vector-ref value i)) + (loop (+ i 1))))) + ((vector? value) + (error "incorrect vector size" value)) + (else + (error "expected vector, got" value)))))) + +(define (shader-struct-default vtable field) + (match (assq-ref (shader-struct-fields vtable) field) + ((_ type size) + (let ((default (if (eq? (struct-vtable type) <shader-struct>) + (apply make-struct/no-tail type + (map (match-lambda + ((sub-field _ _ _) + (shader-struct-default type sub-field))) + (shader-struct-fields type))) + (shader-data-type-null type)))) + (if (= size 1) + default + (make-vector size default)))))) + +(define (make-shader-struct-field-table fields+types) + ;; Map field names to their struct indices and shader types. + (let loop ((i 0) + (fields+types fields+types)) + (match fields+types + (() '()) + (((name #(type size)) . rest) + (cons (list name i type size) + (loop (+ i 1) rest))) + (((name type) . rest) + (cons (list name i type 1) + (loop (+ i 1) rest)))))) + +(define (display-shader-struct-instance obj port) + (let ((vtable (struct-vtable obj))) + (format port "#<~a" (shader-struct-name vtable)) + (let loop ((fields (shader-struct-fields vtable))) + (match fields + (() #f) + (((name index type size) . rest) + (format port " ~a[~d ~a]: ~a" + name size (shader-data-type-name type) (struct-ref obj index)) + (loop rest)))) + (display ">" port))) + +(define (make-display-name sym) + (let ((str (symbol->string sym))) + (if (and (string-prefix? "<" str) + (string-suffix? ">" str)) + (substring str 1 (- (string-length str) 1)) + str))) + +(define (make-shader-struct name fields+types) + (make-struct/no-tail <shader-struct> + (make-struct-layout + (string-concatenate + (map (const "pw") fields+types))) + display-shader-struct-instance + (make-display-name name) + (make-shader-struct-field-table fields+types))) + +(define (shader-struct-ref struct field) + (match (assq-ref (shader-struct-fields (struct-vtable struct)) field) + (#f + (error "unknown struct field" field)) + ((index _ _) + (struct-ref struct index)))) + +(define-syntax define-accessors + (syntax-rules () + ((_ <struct> field getter) + (define getter + (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field) + ((i _ _) i)))) + (lambda (obj) + (struct-ref obj index))))) + ((_ <struct> field getter setter) + (begin + (define-accessors <struct> field getter) + (define setter + (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field) + ((i _ _) i)))) + (lambda (obj value) + (shader-struct-type-check <struct> 'field value) + (struct-set! obj index value)))))))) + +(define-syntax define-shader-type + (syntax-rules () + ((_ <name> constructor predicate (field-type field-name . field-rest) ...) + (begin + (define <name> + (make-shader-struct '<name> (list (list 'field-name field-type) ...))) + (define* (constructor #:key (field-name (shader-struct-default <name> 'field-name)) ...) + (shader-struct-type-check <name> 'field-name field-name) ... + (make-struct/no-tail <name> field-name ...)) + (define (predicate obj) + (and (struct? obj) (eq? (struct-vtable obj) <name>))) + (define-accessors <name> field-name . field-rest) ...)))) ;;; @@ -201,6 +382,7 @@ ;; garbage creation. (scratch-pointer shader-scratch-pointer)) +;; Represents a single active uniform location in a shader program. (define-record-type <uniform> (make-uniform name location type size value) uniform? @@ -210,6 +392,61 @@ (size uniform-size) (value uniform-value %set-uniform-value!)) +;; variable name -> {uniform, namespace, uniform array} map +(define-record-type <uniform-namespace> + (make-uniform-namespace name members) + uniform-namespace? + (name uniform-namespace-name) + (members uniform-namespace-members)) + +(define (fresh-uniform-namespace name) + (make-uniform-namespace name (make-hash-table))) + +(define (uniform-namespace-set! namespace name value) + (hashq-set! (uniform-namespace-members namespace) name value)) + +(define (uniform-namespace-ref namespace name) + (hashq-ref (uniform-namespace-members namespace) name)) + +(define (uniform-namespace-ref-or-create-namespace namespace name) + (or (uniform-namespace-ref namespace name) + (let ((new-ns (fresh-uniform-namespace name))) + (uniform-namespace-set! namespace name new-ns) + new-ns))) + +(define (uniform-namespace-ref-or-create-array namespace name) + (or (uniform-namespace-ref namespace name) + (let ((new-arr (fresh-uniform-array name))) + (uniform-namespace-set! namespace name new-arr) + new-arr))) + +(define (uniform-namespace-for-each proc namespace) + (hash-for-each proc (uniform-namespace-members namespace))) + +;; variable name -> {uniform, namespace} map +(define-record-type <uniform-array> + (make-uniform-array name namespaces size) + uniform-array? + (name uniform-array-name) + (namespaces uniform-array-namespaces) + (size uniform-array-size set-uniform-array-size!)) + +(define (fresh-uniform-array name) + (make-uniform-array name (make-hash-table) 0)) + +(define (uniform-array-namespace-ref array i) + (hashv-ref (uniform-array-namespaces array) i)) + +(define (uniform-array-namespace-add! array i) + (let ((ns (fresh-uniform-namespace (uniform-array-name array)))) + (hashv-set! (uniform-array-namespaces array) i ns) + (set-uniform-array-size! array (max (uniform-array-size array) (+ i 1))) + ns)) + +(define (uniform-array-ref-or-create array i) + (or (uniform-array-namespace-ref array i) + (uniform-array-namespace-add! array i))) + (define-record-type <attribute> (make-attribute name location type) attribute? @@ -285,26 +522,83 @@ them into a GPU shader program." (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-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 (parse-name name) - ;; Primitive array uniform names have a suffix of "[0]" that needs - ;; to be removed to produce the actual uniform variable name. - (if (string-suffix? "[0]" name) - (substring name 0 (- (string-length name) 3)) - name)) + (define (uniform-name->symbol name) + ;; array uniform names have a suffix like "[0]" that needs to be + ;; removed to produce the actual uniform variable name that our + ;; shader interface will recognize. + (string->symbol + (let ((i (string-contains name "["))) + (if i (substring name 0 i) name)))) + (define (parse-array-index name) + (let* ((start (string-contains name "[")) + (end (- (string-length name) 1))) + (and start (string->number (substring name (+ start 1) end))))) + (define (struct? name) + (string-contains name ".")) + (define (namespace->alist table) + (hash-map->list + (lambda (key value) + (cons key + (cond + ((uniform-namespace? value) + (namespace->alist value)) + ((uniform-array? value) + (hash-map->list (lambda (key value) + (cons key (namespace->alist value))) + (uniform-array-namespaces value))) + (else + (list (uniform-location value) + (shader-data-type-name (uniform-type value)) + (uniform-size value)))))) + (uniform-namespace-members table))) + (define (parse-struct name uniform namespace) + ;; Deconstruct the uniform name to produce a path through the + ;; namespace tree, follow it to the end and add the uniform as a + ;; leaf node in the tree. + (let inner ((path (string-split name #\.)) + (namespace namespace)) + (match path + ;; Yay, we're done! + ((leaf) + (uniform-namespace-set! namespace (uniform-name->symbol leaf) uniform)) + ((branch . rest) + (let ((new-name (uniform-name->symbol branch)) + (index (parse-array-index branch))) + ;; If there is an index included in the branch name like + ;; "[1]" then that means we have a nested array of structs + ;; within the struct. Otherwise, it's just a single nested + ;; struct. + (if index + (let ((new-namespace + (uniform-array-ref-or-create + (uniform-namespace-ref-or-create-array namespace + new-name) + index))) + (inner rest new-namespace)) + (let ((new-namespace + (uniform-namespace-ref-or-create-namespace namespace + new-name))) + (inner rest new-namespace)))))))) (define (extract-uniforms id) (let ((total (uniform-count id)) - (table (make-hash-table))) + (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 + ;; then be parsed and turned into a data structure that can be + ;; used to translate Scheme data (either primitives or compound + ;; structures) to the GPU when it comes time to actually render + ;; something with the shader. (let loop ((i 0) (texture-unit 0) (scratch-size 0)) @@ -324,21 +618,37 @@ them into a GPU shader program." (location (gl-get-uniform-location id name)) (size (u32vector-ref size-bv 0)) (type (parse-data-type (u32vector-ref type-bv 0))) - (sampler? (eq? type %sampler-2d)) - (default (if sampler? - texture-unit - (shader-data-type-null type)))) - (hash-set! table - (parse-name name) - (make-uniform name location type size default)) + (sampler? (eq? type sampler-2d)) + (default (cond + (sampler? + texture-unit) + ((= size 1) + (shader-data-type-null type)) + (else + (make-vector size (shader-data-type-null type))))) + (uniform (make-uniform name location type size default))) + (if (struct? name) + ;; The complicated path: Parse struct name and + ;; build a branch of a tree structure. + (parse-struct name uniform namespace) + ;; The easy path: A top-level primitive. + (uniform-namespace-set! namespace + (uniform-name->symbol name) + uniform)) (loop (1+ i) + ;; A sampler uniform uses up one texture unit, + ;; so move on to the next one in that case. (if sampler? (1+ texture-unit) texture-unit) + ;; Ensure we have enough space to serialize the + ;; largest bit of data we send to the shader. (max scratch-size (* size (shader-data-type-size type)))))) - (values table scratch-size))))) + (begin + (pretty-print (namespace->alist namespace)) + (values namespace scratch-size)))))) (define (attribute-count id) (let ((bv (make-u32vector 1))) (gl-get-programiv id @@ -386,10 +696,10 @@ them into a GPU shader program." (gl-delete-shader fragment-id) (call-with-values (lambda () (extract-uniforms id)) - (lambda (uniforms scratch-size) + (lambda (namespace scratch-size) (let ((scratch (make-bytevector scratch-size))) (gpu-guard - (%make-shader id (extract-attributes id) uniforms + (%make-shader id (extract-attributes id) namespace scratch (bytevector->pointer scratch)))))))) (define (load-shader vertex-source-file fragment-source-file) @@ -413,16 +723,48 @@ shader program." (define (shader-uniform shader name) "Return the metadata for the uniform NAME in SHADER." - (let ((uniform (hash-ref (shader-uniforms shader) name))) + (let ((uniform (uniform-namespace-ref (shader-uniforms shader) name))) (or uniform (error "no such uniform" name)))) (define (shader-uniform-set! shader uniform-name x) - (let* ((uniform (shader-uniform shader uniform-name)) - (type (uniform-type uniform))) - (when (and (> (uniform-size uniform) 1) - (not (= (uniform-size uniform) (vector-length x)))) - (error "vector size mismatch for uniform" uniform-name)) - ;; TODO: Figure out a way to avoid unnecessary uniform updates. - (shader-data-type-serialize type (shader-scratch shader) x) - (shader-data-type-apply-uniform type (uniform-location uniform) 1 (shader-scratch-pointer shader)) - (%set-uniform-value! uniform x))) + (define (traverse uniform value) + (cond + ;; A leaf node of the uniform tree representing a single uniform + ;; location as determined by OpenGL. + ((uniform? uniform) + (let ((type (uniform-type uniform))) + ;; A vector of a primitive type must be the exact size that + ;; the shader expects. + (when (and (> (uniform-size uniform) 1) + (not (= (uniform-size uniform) (vector-length x)))) + (error "vector size mismatch for uniform" uniform-name)) + ;; TODO: Figure out a way to avoid unnecessary uniform + ;; updates. Maybe UBOs would help address this? + (shader-data-type-serialize type (shader-scratch shader) value) + (shader-data-type-apply-uniform type (uniform-location uniform) 1 + (shader-scratch-pointer shader)) + (%set-uniform-value! uniform value))) + ;; A nested namespace indicates that this must be a struct. + ((uniform-namespace? uniform) + (if (shader-struct? value) + (uniform-namespace-for-each + (lambda (key uniform) + (traverse uniform (shader-struct-ref value key))) + uniform) + (error "expected shader struct" x))) + ;; A nested array namespace indicates that this must be an array + ;; of structs. + ((uniform-array? uniform) + (let ((size (uniform-array-size uniform))) + ;; Vector size must match what the shader expects. + (if (and (vector? value) + (= size (vector-length value))) + (let loop ((i 0)) + (when (< i size) + (traverse (uniform-array-namespace-ref uniform i) + (vector-ref value i)))) + (error "vector size mismatch for uniform" + (uniform-array-name uniform))))))) + ;; Walk the uniform namespace tree until we get to a leaf node or + ;; nodes. + (traverse (shader-uniform shader uniform-name) x)) |