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