diff options
| -rw-r--r-- | chickadee/graphics/9-patch.scm | 26 | ||||
| -rw-r--r-- | chickadee/graphics/particles.scm | 32 | ||||
| -rw-r--r-- | chickadee/graphics/path.scm | 56 | ||||
| -rw-r--r-- | chickadee/graphics/seagull.scm | 105 | ||||
| -rw-r--r-- | chickadee/graphics/sprite.scm | 36 |
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)))) |