From 0529df9a8021d09f592e0a6eef0c19e148c5336e Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 9 Feb 2014 15:09:18 -0500 Subject: Add shader module. * 2d/shader.scm: New module. * Makefile.am: Add 2d/shader.scm to SOURCES. * examples/shader.scm: New example. * examples/shaders/fragment-shader.glsl: New shader. * examples/shaders/vertex-shader.glsl: New shader. --- 2d/shader.scm | 268 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 268 insertions(+) create mode 100644 2d/shader.scm (limited to '2d') diff --git a/2d/shader.scm b/2d/shader.scm new file mode 100644 index 0000000..86fc1e2 --- /dev/null +++ b/2d/shader.scm @@ -0,0 +1,268 @@ +(define-module (2d shader) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (ice-9 rdelim) + #:use-module (figl gl) + #:use-module (figl gl low-level) + #:use-module (2d helpers) + #:use-module (2d vector2) + #:use-module (2d color) + #:export (make-shader + make-vertex-shader + make-fragment-shader + load-shader + load-vertex-shader + load-fragment-shader + shader? + shader-compiled? + shader-type + shader-id + make-shader-program + shader-program? + shader-program-linked? + with-shader-program + %uniform-setters + register-uniform-setter! + uniforms)) + +(define-syntax-rule (define-logger name length-proc log-proc) + (define (name obj) + (let ((log-length (u32vector 0))) + (length-proc obj (version-2-0 info-log-length) + (bytevector->pointer log-length)) + (let ((log (make-u8vector (1+ (u32vector-ref log-length 0))))) + (log-proc obj (u32vector-ref log-length 0) %null-pointer + (bytevector->pointer log)) + (format #t "~a\n" (utf8->string log)))))) + +(define-syntax-rule (define-status name status-proc status-name) + (define (name obj) + (let ((status (u32vector 0))) + (status-proc obj (version-2-0 status-name) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1)))) + +;;; +;;; Shaders +;;; + +(define-record-type + (%make-shader type id) + shader? + (type shader-type) + (id shader-id)) + +(define-guardian shader-guardian + (lambda (shader) + (false-if-exception + (glDeleteShader (shader-id shader))))) + +;; Reap GL shaders when their wrapper objects are GC'd. +(define-guardian shader-guardian + (lambda (shader) + (false-if-exception (glDeleteShader (shader-id shader))))) + +(define-status %shader-compiled? glGetShaderiv compile-status) + +(define (shader-compiled? shader) + (%shader-compiled? (shader-id shader))) + +(define-logger %display-compilation-error glGetShaderiv glGetShaderInfoLog) + +(define (display-compilation-error shader) + (%display-compilation-error (shader-id shader))) + +(define (compile-shader shader) + "Attempt to compiler SHADER. Compilation errors are written to +stdout." + (glCompileShader (shader-id shader)) + (unless (shader-compiled? shader) + (display "Failed to compile shader:\n") + (display-compilation-error shader))) + +(define (set-shader-source shader source) + "Use the GLSL source code in the string SOURCE for SHADER." + (let ((length (u32vector (string-length source))) + (str (u64vector (pointer-address (string->pointer source))))) + (glShaderSource (shader-id shader) 1 (bytevector->pointer str) + (bytevector->pointer length)))) + +(define (gl-shader-type type) + "Convert the symbol TYPE to the appropriate OpenGL shader constant." + (cond ((eq? type 'vertex) + (version-2-0 vertex-shader)) + ((eq? type 'fragment) + (version-2-0 fragment-shader)) + (else + (error "Invalid shader type: " type)))) + +(define (make-shader type source) + "Create a new GLSL shader of the given TYPE (vertex or fragment) and +compile the GLSL program contained in the string SOURCE." + (let* ((id (glCreateShader (gl-shader-type type))) + (shader (%make-shader type id))) + (shader-guardian shader) + (set-shader-source shader source) + (compile-shader shader) + shader)) + +(define (make-vertex-shader source) + "Create a new GLSL vertex shader and compile the GLSL program +contained in the string SOURCE." + (make-shader 'vertex source)) + +(define (make-fragment-shader source) + "Create a new GLSL fragment shader and compile the GLSL program +contained in the string SOURCE." + (make-shader 'fragment source)) + +(define (load-shader type filename) + "Create a new GLSL shader of the given TYPE (vertex or fragment) and +compile the GLSL program stored in the file FILENAME." + (make-shader type (call-with-input-file filename read-string))) + +(define (load-vertex-shader filename) + "Create a new GLSL vertex shader and compile the GLSL program stored +in the file FILENAME." + (load-shader 'vertex filename)) + +(define (load-fragment-shader filename) + "Create a new GLSL vertex shader and compile the GLSL program stored +in the file FILENAME." + (load-shader 'fragment filename)) + +;;; +;;; Programs +;;; + +(define-record-type + (%make-shader-program id) + shader-program? + (id shader-program-id)) + +(define-guardian shader-program-guardian + (lambda (shader-program) + (false-if-exception + (glDeleteProgram (shader-program-id shader-program))))) + +(define-status %shader-program-linked? glGetProgramiv link-status) + +(define (shader-program-linked? shader-program) + "Return #t if SHADER-PROGRAM has been successfully linked with +shaders or #f otherwise." + (%shader-program-linked? (shader-program-id shader-program))) + +(define-logger %display-linking-error glGetProgramiv glGetProgramInfoLog) + +(define (display-linking-error shader-program) + (%display-linking-error (shader-program-id shader-program))) + +(define (make-shader-program . shaders) + "Create a new shader program that has been linked with the given +SHADERS." + (let* ((id (glCreateProgram)) + (shader-program (%make-shader-program id))) + (shader-program-guardian shader-program) + (for-each (lambda (shader) + (glAttachShader id (shader-id shader))) + shaders) + (glLinkProgram id) + (unless (shader-program-linked? shader-program) + (display "Failed to link shader program:\n") + (display-linking-error shader-program)) + ;; Once the program has been linked, the shaders can be detached. + (for-each (lambda (shader) + (glDetachShader id (shader-id shader))) + shaders) + shader-program)) + +(define current-shader-program (make-parameter #f)) + +(define-syntax-rule (with-shader-program shader-program body ...) + "Evaluate BODY with SHADER-PROGRAM bound." + (parameterize ((current-shader-program shader-program)) + (begin + (glUseProgram (shader-program-id shader-program)) + (let ((return-value (begin body ...))) + (glUseProgram 0) + return-value)))) + +(define-record-type + (make-uniform-setter predicate proc) + uniform-setter? + (predicate uniform-setter-predicate) + (proc uniform-setter-proc)) + +(define %uniform-setters '()) + +(define (register-uniform-setter! predicate setter) + "Add a new type of uniform setter for shader programs where +PREDICATE tests the type of a given value and SETTER performs the +necessary OpenGL calls to set the uniform value in the proper +location." + (set! %uniform-setters + (cons (make-uniform-setter predicate setter) + %uniform-setters))) + +;; Built-in uniform setters for booleans, numbers, vector2s, and +;; colors. +(register-uniform-setter! boolean? + (lambda (location b) + (glUniform1i location (if b 1 0)))) + +(register-uniform-setter! number? + (lambda (location n) + (glUniform1f location n))) + +(register-uniform-setter! vector2? + (lambda (location v) + ;; Use a vec4 instead of vec2 because it + ;; seems to be a lot easier to deal with + ;; vec4s. + (glUniform4f location (vx v) (vy v) 0 0))) + +(register-uniform-setter! color? + (lambda (location c) + (glUniform4f location + (color-r c) + (color-g c) + (color-b c) + (color-a c)))) + +(define (uniform-location shader-program name) + "Retrieve the location for the uniform NAME within SHADER-PROGRAM." + (glGetUniformLocation (shader-program-id shader-program) name)) + +(define (uniform-set! shader-program name value) + "Use the appropriate setter procedure to translate VALUE into OpenGL +compatible data and assign it to the location of the uniform NAME +within SHADER-PROGRAM." + (let ((setter (find (lambda (setter) + ((uniform-setter-predicate setter) value)) + %uniform-setters)) + (location (uniform-location shader-program name))) + (if setter + ((uniform-setter-proc setter) location value) + (error "Not a valid uniform data type" value)))) + +;; Bind values to uniform variables within the current shader program +;; via a let-style syntax. The types of the given values must be +;; accounted for in the %uniform-setters list. This macro simply sets +;; uniform values and does not restore the previous values after +;; evaluating the body of the form. +;; +;; emacs: (put 'uniforms 'scheme-indent-function 1) +(define-syntax uniforms + (syntax-rules () + ((_ () body ...) + (begin body ...)) + ((_ ((name value) ...) body ...) + (begin + (uniform-set! (current-shader-program) + (symbol->string 'name) + value) + ... + body ...)))) -- cgit v1.2.3