summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/9-patch.scm26
-rw-r--r--chickadee/graphics/particles.scm32
-rw-r--r--chickadee/graphics/path.scm56
-rw-r--r--chickadee/graphics/seagull.scm105
-rw-r--r--chickadee/graphics/sprite.scm36
5 files changed, 127 insertions, 128 deletions
diff --git a/chickadee/graphics/9-patch.scm b/chickadee/graphics/9-patch.scm
index 308cd65..21a5c18 100644
--- a/chickadee/graphics/9-patch.scm
+++ b/chickadee/graphics/9-patch.scm
@@ -42,24 +42,24 @@
(define-graphics-variable 9-patch-margins (make-null-rect))
(define-vertex-shader 9-patch-vertex
- ((in vec2 position)
- (in vec2 distance)
- (out vec2 frag-distance)
- (uniform mat4 mvp))
+ (in vec2 position)
+ (in vec2 distance)
+ (out vec2 frag-distance)
+ (uniform mat4 mvp)
(outputs
(vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
(frag-distance distance)))
(define-fragment-shader 9-patch-fragment
- ((in vec2 frag-distance)
- (out vec4 frag-color)
- (uniform vec4 subtexture)
- (uniform vec4 margins)
- (uniform float width)
- (uniform float height)
- (uniform sampler-2d color-texture)
- (uniform vec4 tint)
- (uniform int mode))
+ (in vec2 frag-distance)
+ (out vec4 frag-color)
+ (uniform vec4 subtexture)
+ (uniform vec4 margins)
+ (uniform float width)
+ (uniform float height)
+ (uniform sampler-2d color-texture)
+ (uniform vec4 tint)
+ (uniform int mode)
(define (patch d m0 m1 length tex-length)
(cond
;; Inside the left/bottom margin.
diff --git a/chickadee/graphics/particles.scm b/chickadee/graphics/particles.scm
index c9dd532..cd627bd 100644
--- a/chickadee/graphics/particles.scm
+++ b/chickadee/graphics/particles.scm
@@ -93,16 +93,16 @@ indefinitely."
(acceleration vec2))
(define-vertex-shader particles-vertex
- ((in vec2 position)
- (in vec2 tex)
- (in vec2 offset)
- (in float life)
- (out vec2 frag-tex)
- (out float frag-t)
- (uniform mat4 mvp)
- (uniform int lifetime)
- (uniform int animation-rows)
- (uniform int animation-columns))
+ (in vec2 position)
+ (in vec2 tex)
+ (in vec2 offset)
+ (in float life)
+ (out vec2 frag-tex)
+ (out float frag-t)
+ (uniform mat4 mvp)
+ (uniform int lifetime)
+ (uniform int animation-rows)
+ (uniform int animation-columns)
(let* ((p (+ position offset))
(t (/ life lifetime))
(num-tiles (* animation-rows animation-columns))
@@ -119,12 +119,12 @@ indefinitely."
(frag-t t))))
(define-fragment-shader particles-fragment
- ((in vec2 frag-tex)
- (in float frag-t)
- (out vec4 frag-color)
- (uniform sampler-2d color-texture)
- (uniform vec4 start-color)
- (uniform vec4 end-color))
+ (in vec2 frag-tex)
+ (in float frag-t)
+ (out vec4 frag-color)
+ (uniform sampler-2d color-texture)
+ (uniform vec4 start-color)
+ (uniform vec4 end-color)
(outputs
(frag-color (* (mix end-color start-color frag-t)
(texture color-texture frag-tex)))))
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
index 9c177b5..679995e 100644
--- a/chickadee/graphics/path.scm
+++ b/chickadee/graphics/path.scm
@@ -1222,13 +1222,13 @@
;;;
(define-vertex-shader stroke-vertex
- ((in vec2 position)
- (in vec2 tex)
- (in float stroke-length)
- (out vec2 frag-tex)
- (out float frag-stroke-length)
- (uniform mat4 mvp)
- (uniform vec4 color))
+ (in vec2 position)
+ (in vec2 tex)
+ (in float stroke-length)
+ (out vec2 frag-tex)
+ (out float frag-stroke-length)
+ (uniform mat4 mvp)
+ (uniform vec4 color)
;; Short-circuit because the fragments will just be discarded
;; anyway.
(if (<= (-> color w) 0.0)
@@ -1240,15 +1240,15 @@
(frag-stroke-length stroke-length))))
(define-fragment-shader stroke-fragment
- ((in vec2 frag-tex)
- (in float frag-stroke-length)
- (out vec4 frag-color)
- (uniform vec4 color)
- (uniform float feather)
- (uniform int stroke-closed)
- (uniform float stroke-width)
- (uniform int stroke-cap)
- (uniform float stroke-miter-limit))
+ (in vec2 frag-tex)
+ (in float frag-stroke-length)
+ (out vec4 frag-color)
+ (uniform vec4 color)
+ (uniform float feather)
+ (uniform int stroke-closed)
+ (uniform float stroke-width)
+ (uniform int stroke-cap)
+ (uniform float stroke-miter-limit)
(if (<= (-> color w) 0.0)
(discard)
(let* ((infinity (/ 1.0 0.0))
@@ -1291,11 +1291,11 @@
(compile-shader stroke-vertex stroke-fragment))
(define-vertex-shader fill-vertex
- ((in vec2 position)
- (out vec2 frag-position)
- (uniform mat4 mvp)
- (uniform vec4 color)
- (uniform mat3 gradient-matrix))
+ (in vec2 position)
+ (out vec2 frag-position)
+ (uniform mat4 mvp)
+ (uniform vec4 color)
+ (uniform mat3 gradient-matrix)
;; Short-circuit because the fragments will just be discarded
;; anyway.
(if (<= (-> color w) 0.0)
@@ -1309,13 +1309,13 @@
(frag-position (vec2 (-> fp x) (-> fp y)))))))
(define-fragment-shader fill-fragment
- ((in vec2 frag-position)
- (out vec4 frag-color)
- (uniform int mode)
- (uniform vec4 color)
- (uniform vec4 end-color)
- (uniform vec2 gradient-range)
- (uniform float radial-gradient-ratio))
+ (in vec2 frag-position)
+ (out vec4 frag-color)
+ (uniform int mode)
+ (uniform vec4 color)
+ (uniform vec4 end-color)
+ (uniform vec2 gradient-range)
+ (uniform float radial-gradient-ratio)
(define (gradient-mix x)
(let* ((start (-> gradient-range x))
(end (-> gradient-range y))
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 23cb7af..0434db3 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -339,24 +339,28 @@
(loop `(array-ref ,prev ,(expand j stage env))
rest)))))))
-(define (expand:begin definitions body stage env)
- (define bindings
- (map (match-lambda
- (('define (proc-name (? symbol? params) ...) body)
- (list proc-name (expand `(lambda ,params ,body) stage env)))
- (('define (? symbol? var-name) val)
- (list var-name (expand val stage env)))
- (invalid
- (seagull-syntax-error "invalid definition" invalid expand:begin)))
- definitions))
- (define names (map first bindings))
- (define env* (compose-envs (alpha-convert names) env))
- (let loop ((bindings bindings))
- (match bindings
- (()
- (expand body stage env*))
- (((name value) . rest)
- `(let ((,(lookup name env*) ,value)) ,(loop rest))))))
+(define (expand:begin body stage env)
+ (match body
+ (((and ('define _ ...) definitions) ... body)
+ (define bindings
+ (map (match-lambda
+ (('define (proc-name (? symbol? params) ...) body)
+ (list proc-name (expand `(lambda ,params ,body) stage env)))
+ (('define (? symbol? var-name) val)
+ (list var-name (expand val stage env)))
+ (invalid
+ (seagull-syntax-error "invalid definition" invalid expand:begin)))
+ definitions))
+ (define names (map first bindings))
+ (define env* (compose-envs (alpha-convert names) env))
+ (let loop ((bindings bindings))
+ (match bindings
+ (()
+ (expand body stage env*))
+ (((name value) . rest)
+ `(let ((,(lookup name env*) ,value)) ,(loop rest))))))
+ (_
+ (seagull-syntax-error "invalid begin form" `(begin ,@body) expand:begin))))
;; Arithmetic operators, in true Lisp fashion, can accept many
;; arguments. + and * accept 0 or more. - and / accept one or more.
@@ -509,8 +513,8 @@
(expand:-> exp members stage env))
(('@ exp indices ...)
(expand:@ exp indices stage env))
- (('begin (and ('define _ ...) definitions) ... body)
- (expand:begin definitions body stage env))
+ (('begin body ...)
+ (expand:begin body stage env))
(('let* (bindings ...) body)
(expand:let* bindings body stage env))
(('+ args ...)
@@ -2719,33 +2723,14 @@
(define (seagull-module-fragment? module)
(eq? (seagull-module-stage module) 'fragment))
-(define (group-by-qualifier specs)
- (let loop ((specs specs)
- (inputs '())
- (outputs '())
- (uniforms '()))
- (match specs
- (()
- `((inputs . ,(reverse inputs))
- (outputs . ,(reverse outputs))
- (uniforms . ,(reverse uniforms))))
- ((spec . rest)
- (match spec
- (('in type-desc name)
- (loop rest (cons spec inputs) outputs uniforms))
- (('out type-desc name)
- (loop rest inputs (cons spec outputs) uniforms))
- (('uniform type-desc name)
- (loop rest inputs outputs (cons spec uniforms))))))))
-
-(define* (compile-seagull #:key stage source
+(define* (compile-seagull #:key stage body
(inputs '()) (outputs '()) (uniforms '()))
(unless (memq stage '(vertex fragment))
(error "invalid shader stage" stage))
(parameterize ((unique-identifier-counter 0)
(unique-variable-type-counter 0))
(let ((source* `(top-level ,(append inputs outputs uniforms)
- ,source)))
+ ,body)))
(define-values (expanded global-map)
(expand source* stage (top-level-env)))
(let* ((simplified (simplify-exp expanded (empty-env)))
@@ -2760,39 +2745,53 @@
(make-seagull-global qualifier type-desc name)))
specs))
+(define (partition-globals exps)
+ (let loop ((exps exps)
+ (inputs '())
+ (outputs '())
+ (uniforms '()))
+ (match exps
+ (((and ('in _ _) spec) . rest)
+ (loop rest (cons spec inputs) outputs uniforms))
+ (((and ('out _ _) spec) . rest)
+ (loop rest inputs (cons spec outputs) uniforms))
+ (((and ('uniform _ _) spec) . rest)
+ (loop rest inputs outputs (cons spec uniforms)))
+ ((body ...)
+ (values (reverse inputs)
+ (reverse outputs)
+ (reverse uniforms)
+ `(begin ,@body))))))
+
;; Using syntax-case allows us to compile shaders to their fully typed
;; intermediate form at compile time, leaving only GLSL emission for
;; runtime.
(define-syntax define-shader-stage
(lambda (x)
(syntax-case x ()
- ((_ name stage ((qualifier type var) ...) source ...)
- (let* ((globals (group-by-qualifier
- (syntax->datum
- #'((qualifier type var) ...))))
- (inputs (assq-ref globals 'inputs))
- (outputs (assq-ref globals 'outputs))
- (uniforms (assq-ref globals 'uniforms))
- (source* #'(begin source ...)))
+ ((_ name stage body ...)
+ (let*-values (((inputs outputs uniforms body)
+ (partition-globals
+ (syntax->datum #'(body ...)))))
(define-values (compiled global-map max-id)
(compile-seagull #:stage (syntax->datum #'stage)
- #:source (syntax->datum source*)
#:inputs inputs
#:outputs outputs
- #:uniforms uniforms))
+ #:uniforms uniforms
+ #:body body))
(with-syntax ((inputs (datum->syntax x inputs))
(outputs (datum->syntax x outputs))
(uniforms (datum->syntax x uniforms))
(compiled (datum->syntax x compiled))
(global-map (datum->syntax x global-map))
(max-id (datum->syntax x max-id))
- (source (datum->syntax x source*)))
+ (body (datum->syntax x body)))
#'(define name
(make-seagull-module #:stage 'stage
#:inputs (specs->globals 'inputs)
#:outputs (specs->globals 'outputs)
#:uniforms (specs->globals 'uniforms)
- #:source 'source
+ #:source 'body
#:compiled 'compiled
#:global-map 'global-map
#:max-id max-id))))))))
diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm
index 118c572..414738d 100644
--- a/chickadee/graphics/sprite.scm
+++ b/chickadee/graphics/sprite.scm
@@ -58,19 +58,19 @@
(define-graphics-variable sprite-mvp-matrix (make-null-matrix4))
(define-vertex-shader sprite-vertex
- ((in vec2 position)
- (in vec2 tex)
- (out vec2 frag-tex)
- (uniform mat4 mvp))
+ (in vec2 position)
+ (in vec2 tex)
+ (out vec2 frag-tex)
+ (uniform mat4 mvp)
(outputs
(vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
(frag-tex tex)))
(define-fragment-shader sprite-fragment
- ((in vec2 frag-tex)
- (out vec4 frag-color)
- (uniform sampler-2d color-texture)
- (uniform vec4 tint))
+ (in vec2 frag-tex)
+ (out vec4 frag-color)
+ (uniform sampler-2d color-texture)
+ (uniform vec4 tint)
(outputs
(frag-color (* (texture color-texture frag-tex) tint))))
@@ -165,22 +165,22 @@ BLEND-MODE."
(tint vec4))
(define-vertex-shader sprite-batch-vertex
- ((in vec2 position)
- (in vec2 tex)
- (in vec4 tint)
- (out vec2 frag-tex)
- (out vec4 frag-tint)
- (uniform mat4 mvp))
+ (in vec2 position)
+ (in vec2 tex)
+ (in vec4 tint)
+ (out vec2 frag-tex)
+ (out vec4 frag-tint)
+ (uniform mat4 mvp)
(outputs
(vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
(frag-tex tex)
(frag-tint tint)))
(define-fragment-shader sprite-batch-fragment
- ((in vec2 frag-tex)
- (in vec4 frag-tint)
- (out vec4 frag-color)
- (uniform sampler-2d color-texture))
+ (in vec2 frag-tex)
+ (in vec4 frag-tint)
+ (out vec4 frag-color)
+ (uniform sampler-2d color-texture)
(outputs
(frag-color (* (texture color-texture frag-tex) frag-tint))))