path: root/chickadee/graphics/shader.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016, 2019, 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (chickadee graphics shader)
  #:use-module (ice-9 format)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (gl)
  #:use-module (chickadee data bytestruct)
  #: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 texture)
  #:use-module (chickadee utils)
  #:export (shader-data-type?
            bool
            int
            unsigned-int
            float
            float-vec2
            float-vec3
            float-vec4
            mat3
            mat4
            sampler-2d
            sampler-cube
            local-field
            define-shader-type
            uniform-namespace?
            uniform-namespace-ref
            uniform-namespace-for-each
            make-shader
            shader?
            null-shader
            g:shader
            current-shader
            load-shader
            strings->shader
            shader-uniform
            shader-uniforms
            shader-attributes
            shader-uniform-set!
            shader-uniform-for-each
            set-uniform-value!
            uniform?
            uniform-name
            uniform-type
            uniform-value
            attribute?
            attribute-name
            attribute-location
            attribute-type
            shader-apply
            shader-apply*
            shader-apply/instanced*
            shader-apply/instanced))


;;;
;;; Primitive Shader Data Types
;;;

(define-record-type <shader-primitive-type>
  (%make-shader-primitive-type name size validator serializer setter null)
  shader-primitive-type?
  (name shader-primitive-type-name)
  (size shader-primitive-type-size)
  (validator shader-primitive-type-validator)
  (serializer shader-primitive-type-serializer)
  (setter shader-primitive-type-setter)
  (null shader-primitive-type-null))

(define (display-shader-primitive-type type port)
  (format port "#<shader-primitive-type name: ~a size: ~d null: ~a>"
          (shader-primitive-type-name type)
          (shader-primitive-type-size type)
          (shader-primitive-type-null type)))

(set-record-type-printer! <shader-primitive-type> display-shader-primitive-type)

(define* (make-shader-primitive-type #:key name size validator serializer setter null)
  (%make-shader-primitive-type name size validator serializer setter null))

(define (shader-primitive-type-serialize type bv data)
  (let ((serialize (shader-primitive-type-serializer type)))
    (if (vector? data)
        (let ((size (shader-primitive-type-size type)))
          (for-range ((i (vector-length data)))
            (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-validate type data)
  (let ((valid? (shader-primitive-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-primitive-type var . args)
  (define var (make-shader-primitive-type . args)))

;; Primitive types:
(define-shader-primitive-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-primitive-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-primitive-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-primitive-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-primitive-type float-vec2
  #:name 'float-vec2
  #:size 8 ; 8 bytes = 2 floats = 1 vec2
  #:validator vec2?
  #:serializer
  (lambda (bv i v)
    (bytestruct-pack! <vec2> ((() v)) bv i))
  #:setter gl-uniform2fv
  #:null (vec2 0.0 0.0))

(define-shader-primitive-type float-vec3
  #:name 'float-vec3
  #:size 12 ; 12 bytes = 3 floats = 1 vec3
  #:validator vec3?
  #:serializer
  (lambda (bv i v)
    (bytestruct-pack! <vec3> ((() v)) bv i))
  #:setter gl-uniform3fv
  #:null (vec3 0.0 0.0 0.0))

(define-shader-primitive-type float-vec4
  #:name 'float-vec4
  #: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)))
    (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
  #:null (make-null-rect))

(define-shader-primitive-type mat3
  #:name 'mat3
  #:size (* 3 3 4) ; 3 rows x 3 columns x 4 byte floats
  #:validator matrix3?
  #:serializer
  (lambda (bv i m)
    (bytestruct-pack! <matrix3>  ((() m)) bv i))
  #:setter (lambda (location count ptr)
             (gl-uniform-matrix3fv location count #f ptr))
  #:null (make-identity-matrix3))

(define-shader-primitive-type mat4
  #:name 'mat4
  #:size (bytestruct-sizeof <matrix4>) ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes
  #:validator matrix4?
  #:serializer
  (lambda (bv i m)
    ;; (match m
    ;;   (($ <matrix4> src offset)
    ;;    (bytevector-copy! src offset bv i
    ;;                      (bytestruct-sizeof <matrix4>))))
    (bytestruct-pack! <matrix4> ((() m)) bv i)
    )
  #:setter (lambda (location count ptr)
             (gl-uniform-matrix4fv location count #f ptr))
  #:null (make-identity-matrix4))

(define-shader-primitive-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)

(define-shader-primitive-type sampler-cube
  #:name 'sampler-cube
  #:size 4
  #:validator integer?
  #:serializer
  (lambda (bv i texture-unit)
    (bytevector-s32-native-set! bv i texture-unit))
  #:setter gl-uniform1iv
  #:null 0)


;;;
;;; Compound Shader Data Types
;;;

;; 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 local-field (gensym "local-shader-field-"))

(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-primitive-type-validate type value))
         (error "invalid type for shader struct field" field value)))
     (cond
      ((eq? type local-field)
       #t)
      ((= size 1)
       (validate value))
      ((and (vector? value)
            (= (vector-length value) size))
       (for-range ((i (vector-length value)))
         (validate (vector-ref value i))))
      ((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 (cond
                     ((eq? type local-field)
                      #f)
                     ((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))))
                     (else
                      (shader-primitive-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
                 (if (eq? type local-field)
                     'local
                     (shader-primitive-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) ...))))


;;;
;;; Shaders
;;;

(define-record-type <shader>
  (%make-shader id attributes uniforms scratch scratch-pointer)
  shader?
  (id shader-id)
  (attributes shader-attributes)
  (uniforms shader-uniforms)
  ;; Scratch space for serializing uniform values.
  (scratch shader-scratch)
  ;; Create the pointer once and hold onto it to reduce needless
  ;; 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?
  (name uniform-name)
  (location uniform-location)
  (type uniform-type)
  (size uniform-size)
  (value uniform-value %set-uniform-value!))

(define (sampler? uniform)
  (or (eq? (uniform-type uniform) sampler-2d)
      (eq? (uniform-type uniform) sampler-cube)))

;; 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?
  (name attribute-name)
  (location attribute-location)
  (type attribute-type))

(define null-shader (%make-shader 0 (make-hash-table) (make-hash-table) #f #f))

(define (bind-shader shader)
  (gl-use-program (shader-id shader)))

(define (free-shader shader)
  (gl-delete-program (shader-id shader)))

(define-graphics-finalizer shader-finalizer
  #:predicate shader?
  #:free free-shader)

(define-graphics-state g:shader
  current-shader
  #:default null-shader
  #:bind bind-shader)

(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 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 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 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 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
    ;; are compatible with as many systems as possible.
    (let ((glsl-version (graphics-engine-glsl-version)))
      (cond
       ((string>= glsl-version "3.3")
        "#version 330
#define GLSL330
")
       ((string>= glsl-version "1.3")
        "#version 130
#define GLSL130
")
       ((string>= glsl-version "1.2")
        "#version 120
#define GLSL120
")
       (else
        (error "incompatible GLSL version" glsl-version)))))
  (define (make-shader-stage type port)
    (let ((id (gl-create-shader type))
          (source (string->utf8
                   (string-append (glsl-preprocessor-source)
                                  (get-string-all port)))))
      (gl-shader-source id 1
                        (bytevector->pointer
                         (u64vector
                          (pointer-address (bytevector->pointer source))))
                        (bytevector->pointer
                         (u32vector (bytevector-length source))))
      (gl-compile-shader id)
      (unless (shader-compiled? id)
        (let ((error-log (compilation-error id)))
          (gl-delete-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 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)
     (else
      (error "unsupported OpenGL type" type))))
  (define (camel->snake str)
    (list->string
     (let loop ((i 0))
       (if (< i (string-length str))
           (let ((c (string-ref str i)))
             (if (char-set-contains? char-set:upper-case c)
                 (cons* #\- (char-downcase c) (loop (+ i 1)))
                 (cons c (loop (+ i 1)))))
           '()))))
  (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 "[")))
       (camel->snake
        (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 (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))
          (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))
        (if (< 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-uniform 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 id name))
                     (size (u32vector-ref size-bv 0))
                     (type (parse-data-type (u32vector-ref type-bv 0)))
                     (sampler? (or (eq? type sampler-2d) (eq? type sampler-cube)))
                     (default (cond
                               (sampler?
                                texture-unit)
                               ((= size 1)
                                (shader-primitive-type-null type))
                               (else
                                (make-vector size (shader-primitive-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-primitive-type-size type))))))
            (values namespace scratch-size)))))
  (define (attribute-count id)
    (let ((bv (make-u32vector 1)))
      (gl-get-programiv id
                        (arb-shader-objects active-attributes)
                        (bytevector->pointer bv))
      (u32vector-ref bv 0)))
  (define (extract-attributes id)
    (let ((total (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 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 id name)))
            (unless (= size 1)
              (error "unsupported attribute size" name size))
            (hash-set! table name (make-attribute name location type)))))
      table))
  (assert-current-graphics-engine)
  (let ((vertex-id (make-shader-stage (version-2-0 vertex-shader)
                                      vertex-port))
        (fragment-id (make-shader-stage (version-2-0 fragment-shader)
                                        fragment-port))
        (id (gl-create-program)))
    (gl-attach-shader id vertex-id)
    (gl-attach-shader id fragment-id)
    (gl-link-program id)
    (unless (shader-linked? id)
      (let ((error-log (linking-error id)))
        (gl-delete-program id)
        (error "failed to link shader" error-log)))
    (gl-delete-shader vertex-id)
    (gl-delete-shader fragment-id)
    (call-with-values
        (lambda () (extract-uniforms id))
      (lambda (namespace scratch-size)
        (let* ((scratch (make-bytevector scratch-size))
               (scratch-ptr (bytevector->pointer scratch))
               (shader (%make-shader id (extract-attributes id) namespace
                                     scratch scratch-ptr)))
          (graphics-engine-guard! shader)
          shader)))))

(define (load-shader vertex-source-file fragment-source-file)
  "Compile the GLSL source code within VERTEX-SOURCE-FILE and
FRAGMENT-SOURCE-FILE into a GPU shader program."
  (call-with-input-file vertex-source-file
    (lambda (vertex-port)
      (call-with-input-file fragment-source-file
        (lambda (fragment-port)
          (make-shader vertex-port fragment-port))))))

(define (strings->shader vertex-source fragment-source)
  "Compile VERTEX-SOURCE, the GLSL code for the vertex shader,
and FRAGMENT-SOURCE, the GLSL code for the fragment shader, into a GPU
shader program."
  (call-with-input-string vertex-source
    (lambda (vertex-port)
      (call-with-input-string fragment-source
        (lambda (fragment-port)
          (make-shader vertex-port fragment-port))))))

(define (shader-uniform shader name)
  "Return the metadata for the uniform NAME in SHADER."
  (let ((uniform (uniform-namespace-ref (shader-uniforms shader) name)))
    (or uniform (error "no such uniform" name))))

(define (set-uniform-value! shader uniform value)
  ;; TODO: Figure out a way to avoid unnecessary uniform
  ;; 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-scratch-pointer shader))
    (%set-uniform-value! uniform value)))

(define (shader-uniform-for-each* proc shader thing)
  (cond
   ((uniform? thing)
    (proc thing))
   ((uniform-namespace? thing)
    (uniform-namespace-for-each
     (lambda (key uniform)
       (shader-uniform-for-each* proc shader uniform))
     thing))
   ((uniform-array? thing)
    (for-range ((i (uniform-array-size thing)))
      (shader-uniform-for-each* proc shader (uniform-array-namespace-ref thing i))))))

(define (shader-uniform-for-each proc shader)
  (shader-uniform-for-each* proc shader (shader-uniforms shader)))

;; TODO: This walks the entire tree every time, but it should instead
;; stop traversing once it finds the correct leaf node.
(define (%shader-uniform-set shader uniform value)
  (cond
   ;; A leaf node of the uniform tree representing a single uniform
   ;; location as determined by OpenGL.
   ((uniform? 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 value))))
      (error "vector size mismatch for uniform" uniform-name))
    (set-uniform-value! shader 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)
           ;; Samplers are opaque types and you cannot pass them
           ;; into the shader as uniform values like you can with
           ;; most other values.  In the case of samplers, they are
           ;; mapped to OpenGL's "texture units", so we need to
           ;; ignore them here.
           (unless (sampler? uniform)
             (%shader-uniform-set shader uniform
                                  (shader-struct-ref value key))))
         uniform)
        (error "expected shader struct" value)))
   ;; 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)))
          (for-range ((i size))
            (%shader-uniform-set shader
                                 (uniform-array-namespace-ref uniform i)
                                 (vector-ref value i)))
          (error "vector size mismatch for uniform"
                 (uniform-array-name uniform)))))))

(define (shader-uniform-set! shader uniform-name x)
  ;; Walk the uniform namespace tree until we get to a leaf node or
  ;; nodes.
  (%shader-uniform-set shader (shader-uniform shader uniform-name) x))

(define-syntax uniform-apply
  (lambda (x)
    (syntax-case x ()
      ((_ shader ()) (datum->syntax x #t))
      ((_ shader (name value . rest))
       (with-syntax ((sname (datum->syntax x (keyword->symbol
                                              (syntax->datum #'name)))))
         #'(begin
             (shader-uniform-set! shader 'sname value)
             (uniform-apply shader rest)))))))

(define-syntax-rule (shader-apply** shader* vertex-array uniforms exp)
  (with-graphics-state! ((g:shader shader*))
    (uniform-apply shader* uniforms)
    ;; Sampler2D values aren't explicitly passed as uniform values via
    ;; shader-apply, so we have to bind them to the proper texture units
    ;; behind the scenes.
    (shader-uniform-for-each
     (lambda (uniform)
       (when (or (eq? (uniform-type uniform) sampler-2d)
                 (eq? (uniform-type uniform) sampler-cube))
         (set-uniform-value! shader* uniform (uniform-value uniform))))
     shader*)
    exp))

(define-syntax-rule (shader-apply* shader vertex-array offset count . uniforms)
  (shader-apply** shader vertex-array uniforms
                  (render-vertices vertex-array count offset)))

(define-syntax-rule (shader-apply shader vertex-array uniforms ...)
  (shader-apply* shader vertex-array 0 #f uniforms ...))

(define-syntax-rule (shader-apply/instanced* shader vertex-array offset count instances .
                                             uniforms)
  (shader-apply** shader vertex-array uniforms
                  (render-vertices/instanced vertex-array instances count offset)))

(define-syntax-rule (shader-apply/instanced shader vertex-array instances
                                            uniforms ...)
  (shader-apply/instanced* shader vertex-array 0 #f instances uniforms ...))