summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sly/render.scm4
-rw-r--r--sly/render/model.scm2
-rw-r--r--sly/render/shader.scm264
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)))))