diff options
| -rw-r--r-- | sly/render.scm | 4 | ||||
| -rw-r--r-- | sly/render/model.scm | 2 | ||||
| -rw-r--r-- | sly/render/shader.scm | 264 |
3 files changed, 124 insertions, 146 deletions
diff --git a/sly/render.scm b/sly/render.scm index 47aa862..b6dd3fb 100644 --- a/sly/render.scm +++ b/sly/render.scm @@ -206,7 +206,7 @@ (graphics-uniform-set! gfx (uniform-name uniform) (uniform-default uniform))) - (shader-program-uniforms shader))) + (shader-uniforms shader))) (define (make-context-switcher getter setter switch) (lambda* (gfx x #:optional force) @@ -234,7 +234,7 @@ (define set-graphics-shader! (make-context-switcher graphics-shader switch-shader - apply-shader-program)) + apply-shader)) (define set-graphics-mesh! (make-context-switcher graphics-mesh diff --git a/sly/render/model.scm b/sly/render/model.scm index d18ace5..0eb07c0 100644 --- a/sly/render/model.scm +++ b/sly/render/model.scm @@ -109,7 +109,7 @@ changing the fields specified in KWARGS." fields field-indices)))))) (define null-model - (make-model #:shader null-shader-program)) + (make-model #:shader null-shader)) (define (model-null? model) "Return #t if MODEL has no mesh and no children." diff --git a/sly/render/shader.scm b/sly/render/shader.scm index fe2eddd..556d626 100644 --- a/sly/render/shader.scm +++ b/sly/render/shader.scm @@ -32,30 +32,17 @@ #:use-module (sly config) #:use-module (sly wrappers gl) #:export (make-shader - make-vertex-shader - make-fragment-shader - load-shader - load-vertex-shader - load-fragment-shader shader? - vertex-shader? - fragment-shader? - shader-compiled? - shader-type - shader-id - make-shader-program - shader-program? - load-shader-program + load-shader + load-default-shader vertex-position-location vertex-texture-location - shader-program-uniform-location - shader-program-id - shader-program-uniforms - shader-program-linked? - null-shader-program - apply-shader-program - with-shader-program - load-default-shader + shader-uniform-location + shader-id + shader-uniforms + shader-linked? + null-shader + apply-shader %uniform-setters register-uniform-setter! uniform? @@ -86,53 +73,51 @@ ;;; Shaders ;;; -(define-record-type <shader> - (%make-shader type id) - shader? - (type shader-type) - (id shader-id)) - -(define (vertex-shader? shader) - "Return #t if SHADER is a vertex shader, #f otherwise." - (eq? (shader-type shader) 'vertex)) +(define-record-type <shader-stage> + (%make-shader-stage type id) + shader-stage? + (type shader-stage-type) + (id shader-stage-id)) -(define (fragment-shader? shader) - "Return #t if SHADER is a fragment shader, #f otherwise." - (eq? (shader-type shader) 'fragment)) +(define (vertex-shader-stage? stage) + "Return #t if STAGE is a vertex shader, #f otherwise." + (eq? (shader-stage-type stage) 'vertex)) -(define-guardian shader-guardian - (lambda (shader) - (false-if-exception - (glDeleteShader (shader-id shader))))) +(define (fragment-shader-stage? stage) + "Return #t if STAGE is a fragment shader, #f otherwise." + (eq? (shader-stage-type stage) 'fragment)) ;; Reap GL shaders when their wrapper objects are GC'd. -(define-guardian shader-guardian - (lambda (shader) - (false-if-exception (glDeleteShader (shader-id shader))))) +(define-guardian shader-stage-guardian + (lambda (stage) + (false-if-exception + (glDeleteShader (shader-stage-id stage))))) -(define-status %shader-compiled? glGetShaderiv compile-status) +(define-status %shader-stage-compiled? glGetShaderiv compile-status) -(define (shader-compiled? shader) - (%shader-compiled? (shader-id shader))) +(define (shader-stage-compiled? stage) + "Return #t if STAGE has been compiled already." + (%shader-stage-compiled? (shader-stage-id stage))) (define-logger %display-compilation-error glGetShaderiv glGetShaderInfoLog) -(define (display-compilation-error shader) - (%display-compilation-error (shader-id shader))) +(define (display-compilation-error stage) + (%display-compilation-error (shader-stage-id stage))) -(define (compile-shader shader) - "Attempt to compiler SHADER. Compilation errors are written to +(define (compile-shader-stage stage) + "Attempt to compile STAGE. Compilation errors are written to stdout." - (glCompileShader (shader-id shader)) - (unless (shader-compiled? shader) + (glCompileShader (shader-stage-id stage)) + (unless (shader-stage-compiled? stage) (display "Failed to compile shader:\n") - (display-compilation-error shader))) + (display-compilation-error stage))) -(define (set-shader-source shader source) - "Use the GLSL source code in the string SOURCE for SHADER." +(define (set-shader-stage-source stage source) + "Use the GLSL source code in the string SOURCE for the shader +STAGE." (let ((length (u32vector (string-length source))) (str (u64vector (pointer-address (string->pointer source))))) - (glShaderSource (shader-id shader) 1 (bytevector->pointer str) + (glShaderSource (shader-stage-id stage) 1 (bytevector->pointer str) (bytevector->pointer length)))) (define (gl-shader-type type) @@ -144,42 +129,44 @@ stdout." (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." +(define (make-shader-stage type source) + "Create a new GLSL shader stage of the given TYPE (either '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 + (stage (%make-shader-stage type id))) + (shader-stage-guardian stage) + (set-shader-stage-source stage source) + (compile-shader-stage stage) + stage)) + +(define (make-vertex-shader-stage source) + "Create a new GLSL vertex shader stage 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." - (if (file-exists? filename) - (make-shader type (call-with-input-file filename read-string)) - (error "File not found!" filename))) - -(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)) + (make-shader-stage 'vertex source)) + +(define (make-fragment-shader-stage source) + "Create a new GLSL fragment shader stage and compile the GLSL +program contained in the string SOURCE." + (make-shader-stage 'fragment source)) + +(define (load-shader-stage type file-name) + "Create a new GLSL shader stage of the given TYPE (either 'vertex' +or 'fragment') and compile the GLSL program stored in the file +FILE-NAME." + (if (file-exists? file-name) + (make-shader-stage type (call-with-input-file file-name read-string)) + (error "File not found!" file-name))) + +(define (load-vertex-shader file-name) + "Create a new GLSL vertex shader stage and compile the GLSL program +stored in the file FILE-NAME." + (load-shader-stage 'vertex file-name)) + +(define (load-fragment-shader file-name) + "Create a new GLSL vertex shader stage and compile the GLSL program +stored in the file FILE-NAME." + (load-shader-stage 'fragment file-name)) ;;; ;;; Shader Programs @@ -199,49 +186,49 @@ in the file FILENAME." (name attribute-name) (location attribute-location)) -(define-record-type <shader-program> - (%make-shader-program id uniforms) - shader-program? - (id shader-program-id) - (uniforms shader-program-uniforms)) +(define-record-type <shader> + (%make-shader id uniforms) + shader? + (id shader-id) + (uniforms shader-uniforms)) ;; Hard-coded vertex attribute locations. These are fixed so that all ;; Sly shaders abide by the same interface. (define vertex-position-location 0) (define vertex-texture-location 1) -(define (shader-program-uniform-location shader-program name) +(define (shader-uniform-location shader name) (let ((uniform (find (lambda (uniform) (eq? (uniform-name uniform) name)) - (shader-program-uniforms shader-program)))) + (shader-uniforms shader)))) (if uniform (uniform-location uniform) (error "Uniform not found: " name)))) -(define-guardian shader-program-guardian - (lambda (shader-program) +(define-guardian shader-guardian + (lambda (shader) (false-if-exception - (glDeleteProgram (shader-program-id shader-program))))) + (glDeleteProgram (shader-id shader))))) -(define-status shader-program-linked? glGetProgramiv link-status) +(define-status shader-linked? glGetProgramiv link-status) (define-logger display-linking-error glGetProgramiv glGetProgramInfoLog) -(define (make-shader-program vertex-shader fragment-shader uniforms) +(define (make-shader vertex-stage fragment-stage uniforms) "Create a new shader program that has been linked with the given -VERTEX-SHADER and FRAGMENT-SHADER." - (unless (and (vertex-shader? vertex-shader) - (fragment-shader? fragment-shader)) - (error "Expected a vertex shader and fragment shader" - vertex-shader fragment-shader)) +VERTEX-STAGE and FRAGMENT-STAGE." + (unless (and (vertex-shader-stage? vertex-stage) + (fragment-shader-stage? fragment-stage)) + (error "Expected vertex and fragment shader stages" + vertex-stage fragment-stage)) (let ((id (glCreateProgram)) - (shaders (list vertex-shader fragment-shader))) + (stages (list vertex-stage fragment-stage))) (define build-uniform (match-lambda - ((name gl-name default) - (let ((location (glGetUniformLocation id gl-name))) - (if (= location -1) - (error "Uniform not found: " gl-name) - (make-uniform name gl-name location default)))))) + ((name gl-name default) + (let ((location (glGetUniformLocation id gl-name))) + (if (= location -1) + (error "Uniform not found: " gl-name) + (make-uniform name gl-name location default)))))) (define (string->attribute attribute-name) (let ((location (glGetAttribLocation id attribute-name))) @@ -251,49 +238,40 @@ VERTEX-SHADER and FRAGMENT-SHADER." (catch #t (lambda () - (for-each (lambda (shader) - (glAttachShader id (shader-id shader))) - shaders) + (for-each (lambda (stage) + (glAttachShader id (shader-stage-id stage))) + stages) ;; Bind attribute locations (glBindAttribLocation id vertex-position-location "position") (glBindAttribLocation id vertex-texture-location "tex") (glLinkProgram id) - (unless (shader-program-linked? id) + (unless (shader-linked? id) (display "Failed to link shader program:\n") (display-linking-error id)) ;; Once the program has been linked, the shaders can be detached. - (for-each (lambda (shader) - (glDetachShader id (shader-id shader))) - shaders) + (for-each (lambda (stage) + (glDetachShader id (shader-stage-id stage))) + stages) (let* ((uniforms (map build-uniform uniforms)) - (shader-program (%make-shader-program id uniforms))) - (shader-program-guardian shader-program) - shader-program)) + (shader (%make-shader id uniforms))) + (shader-guardian shader) + shader)) throw (lambda _ ;; Make sure to delete program in case linking fails. (glDeleteProgram id))))) -(define* (load-shader-program #:key vertex-source fragment-source - uniforms) - (make-shader-program (load-vertex-shader vertex-source) - (load-fragment-shader fragment-source) - uniforms)) - -(define null-shader-program - (%make-shader-program 0 '())) +(define* (load-shader #:key vertex-source fragment-source + uniforms) + (make-shader (load-vertex-shader vertex-source) + (load-fragment-shader fragment-source) + uniforms)) -(define (apply-shader-program shader-program) - (glUseProgram (shader-program-id shader-program))) +(define null-shader + (%make-shader 0 '())) -(define-syntax-rule (with-shader-program shader-program body ...) - "Evaluate BODY with SHADER-PROGRAM bound." - (parameterize ((current-shader-program shader-program)) - (begin - (apply-shader-program shader-program) - (let ((return-value (begin body ...))) - (glUseProgram 0) - return-value)))) +(define (apply-shader shader) + (glUseProgram (shader-id shader))) ;;; ;;; Uniforms @@ -352,14 +330,14 @@ location." (color-b c) (color-a c)))) -(define (uniform-set! shader-program name value) +(define (uniform-set! shader 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." +within SHADER." (let ((setter (find (lambda (setter) ((uniform-setter-predicate setter) value)) %uniform-setters)) - (location (shader-program-uniform-location shader-program name))) + (location (shader-uniform-location shader name))) (if setter ((uniform-setter-proc setter) location value) (error "Not a valid uniform data type" value)))) @@ -372,9 +350,9 @@ within SHADER-PROGRAM." ;; an OpenGL context available. (define %default-shader (delay - (load-shader-program + (load-shader #:vertex-source (scope-datadir "/shaders/default-vertex.glsl") - #:fragment-source (scopre-datadir "/shaders/default-fragment.glsl") + #:fragment-source (scope-datadir "/shaders/default-fragment.glsl") #:uniforms `((mvp "mvp" ,identity-transform) (color "color" ,white) (texture? "use_texture" #f))))) |