diff options
Diffstat (limited to 'chickadee/graphics/shader.scm')
| -rw-r--r-- | chickadee/graphics/shader.scm | 1782 |
1 files changed, 912 insertions, 870 deletions
diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm index ab0a8cf..4990487 100644 --- a/chickadee/graphics/shader.scm +++ b/chickadee/graphics/shader.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2019, 2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2016-2023 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. @@ -25,881 +25,923 @@ #: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 graphics backend) #:prefix gpu:) + ;; #:use-module (chickadee graphics buffer) + ;; #:use-module (chickadee graphics color) + ;; #: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 + #:export (make-shader + destroy-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 - (lambda (bv i x) - ;; 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? x) - (bytestruct-pack! <rect> ((() x)) bv i) - (bytestruct-pack! <color> ((() x)) bv i))) - #: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 -;;; + shader-vertex + shader-fragment + shader-destroyed? + + ;; 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 + )) (define-record-type <shader> - (%make-shader id attributes uniforms scratch scratch-pointer) + (%make-shader gpu handle name state) 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 ...)) + (gpu shader-gpu) + (handle shader-handle) + (name shader-name) + (state shader-state set-shader-state!)) + +(define (print-shader shader port) + (match shader + (($ <shader> _ _ name) + (format #t "#<shader name: ~s>" name)))) + +(set-record-type-printer! <shader> print-shader) + +(define (shader-available? shader) + (eq? (shader-state shader) 'available)) + +(define (shader-destroyed? shader) + (eq? (shader-state shader) 'destroyed)) + +(define* (make-shader source #:key name) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-shader gpu source))) + (%make-shader gpu handle name 'available))) + +(define (destroy-shader module) + (unless (shader-destroyed? module) + (gpu:destroy-shader (shader-gpu module) (shader-handle module)) + (set-shader-state! module 'destroyed))) + +;; +;; ;;; +;; ;;; 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 +;; (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-primitive-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-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 +;; (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)) +;; #:null (make-identity-matrix3)) + +;; (define-shader-primitive-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-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 ...)) |