diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | chickadee/graphics/sglsl.scm | 339 | ||||
| -rw-r--r-- | tests/sglsl.scm | 99 |
3 files changed, 441 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index 7b38f9d..6e23ada 100644 --- a/Makefile.am +++ b/Makefile.am @@ -77,6 +77,7 @@ SOURCES = \ chickadee/graphics/buffer.scm \ chickadee/graphics/pixbuf.scm \ chickadee/graphics/texture.scm \ + chickadee/graphics/sglsl.scm \ chickadee/graphics/shader.scm \ chickadee/graphics/viewport.scm \ chickadee/graphics/framebuffer.scm \ @@ -109,7 +110,8 @@ TESTS = \ tests/array-list.scm \ tests/heap.scm \ tests/quadtree.scm \ - tests/queue.scm + tests/queue.scm \ + tests/sglsl.scm TEST_EXTENSIONS = .scm SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE) diff --git a/chickadee/graphics/sglsl.scm b/chickadee/graphics/sglsl.scm new file mode 100644 index 0000000..3a94d2f --- /dev/null +++ b/chickadee/graphics/sglsl.scm @@ -0,0 +1,339 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2022 David Thompson <davet@gnu.org> +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; SGLSL: The Seagull Shading Language +;; +;;; Code: + +(define-module (chickadee graphics sglsl) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics gl) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee utils) + #:use-module (gl) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (%glsl-shims + %glsl-vertex-shims + %glsl-fragment-shims + sglsl->glsl + shader-primitive-type? + shader-primitive-type-null + shader-primitive-type-size + shader-primitive-type-serialize + shader-primitive-type-apply-uniform + bool + int + unsigned-int + float + float-vec2 + float-vec3 + float-vec4 + mat3 + mat4 + sampler-2d + sampler-cube + shader-struct? + shader-struct-ref + local-field + define-shader-type + uniform-namespace? + uniform-namespace-ref + uniform-namespace-for-each + make-top-level-vertex-shader-environment + make-top-level-fragment-shader-environment + shader-quote + compile-shader)) + +;; Preprocessor macros to make newer keywords work for older versions +;; of GLSL so our serializer can target just one version of the +;; syntax. Users of SGLSL should prepend these shims to the shader +;; code generated by sglsl->glsl before sending the shader code to the +;; GPU. +(define %glsl-shims + "#ifdef GLSL120 +#define in attribute +#define out varying +#endif +") + +(define %glsl-vertex-shims "") + +(define %glsl-fragment-shims + "#ifndef GLSL330 +vec4 texture(sampler2D tex,vec2 coord){return texture2D(tex, coord);} +vec4 texture(samplerCube tex,vec3 coord){return textureCube(tex, coord);} +#endif +") + +;; According to +;; http://learnwebgl.brown37.net/12_shader_language/glsl_control_structures.html +;; the only looping construct we're guaranteed to have is the for +;; loop, so SGLSL does not support while/do-while loops. Is that the +;; right call? +(define* (sglsl->glsl exp #:optional (port (current-output-port))) + (define (assert-valid-identifier sym) + (let ((str (symbol->string sym))) + (string-for-each-index + (lambda (i) + (let ((c (string-ref str i))) + (unless (if (= i 0) + ;; The first character can be a letter or an + ;; underscore. + (or (char-set-contains? char-set:letter c) + (eqv? c #\_)) + ;; Every other character can be a letter, number, + ;; or underscore. + (or (char-set-contains? char-set:letter c) + (char-set-contains? char-set:digit c) + (eqv? c #\_))) + (error "invaid SGLSL identifier" sym)))) + str)) + sym) + (define (sequence exps) + (for-each (lambda (exp) + (sglsl->glsl exp port) + (display ";" port)) + exps)) + (match exp + (() #t) ; done! + ;; Booleans + (#true + (display "true" port)) + (#false + (display "false" port)) + ;; Integer + ((? exact-integer? n) + (display n port)) + ;; Floating point number + ((and (? number?) (? inexact? n)) + (display n port)) + ((? number? n) ; fractions or other exact non-integers + (display (exact->inexact n) port)) + ;; Variable reference + ((? symbol? sym) + (display (assert-valid-identifier sym) port)) + ;; Struct dereference + (('-> subexp (? symbol? names) ...) + (sglsl->glsl subexp port) + (for-each (lambda (name) + (display ".") + (display (assert-valid-identifier name) port)) + names)) + ;; Array dereference + (('@ subexp indices ...) + (sglsl->glsl subexp port) + (for-each (lambda (index) + (display "[" port) + (sglsl->glsl index port) + (display "]" port)) + indices)) + ;; Infix operators + (((and (or '+ '- '* '/ '= '+= '-= '*= '/= '== '!= '> '>= '< '<= '|| '&& '^^) op) left right) + (display "(" port) + (sglsl->glsl left port) + (display op port) + (sglsl->glsl right port) + (display ")" port)) + ;; Post-increment/decrement + (((and (or '++ '--) op) subexp) + (sglsl->glsl subexp port) + (display op port)) + ;; Pre-increment/decrement + (('pre++ subexp) + (display "++" port) + (sglsl->glsl subexp port)) + (('pre-- subexp) + (display "--" port) + (sglsl->glsl subexp port)) + ;; Negation + (('! subexp) + (display "!" port) + (sglsl->glsl subexp port)) + ;; If/else + (('if condition consequent alternate) + (display "if(" port) + (sglsl->glsl condition port) + (display "){" port) + (sglsl->glsl consequent port) + (display "}else{" port) + (sglsl->glsl alternate port) + (display "}" port)) + ;; If (no else) + (('if condition consequent) + (display "if(" port) + (sglsl->glsl condition port) + (display "){" port) + (sglsl->glsl consequent port) + (display "}" port)) + ;; Ternary (AKA the good "if" that returns a value) + (('? condition consequent alternate) + (display "(" port) + (sglsl->glsl condition port) + (display "?" port) + (sglsl->glsl consequent port) + (display ":" port) + (sglsl->glsl alternate port) + (display ")" port)) + ;; For loop + (('for (init test increment) body ...) + (display "for(" port) + (sglsl->glsl init port) + (display ";" port) + (sglsl->glsl test port) + (display ";" port) + (sglsl->glsl increment port) + (display "){" port) + (sequence body) + (display "}" port)) + ;; Break/continue/discard + ((or 'break 'continue 'discard) + (display exp port)) + ;; Return + (('return) + (display "return" port)) + (('return subexp) + (display "return " port) + (sglsl->glsl subexp port)) + ;; Function definition + (('function (return-type name params ...) body ...) + (display (assert-valid-identifier return-type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (display "(" port) + (let loop ((params params) + (first? #t)) + (match params + (() #t) + ;; Implicit "in" parameter qualifier + ((((? symbol? type) (? symbol? name)) . rest) + (unless first? (display "," port)) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (loop rest #f)) + ;; Explicit parameter qualifier + ((((and (or 'in 'out 'inout) qualifier) (? symbol? type) (? symbol? name)) . rest) + (unless first? (display "," port)) + (display qualifier port) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (loop rest #f)) + (spec + (error "invalid SGLSL function parameter specification" spec)))) + (display "){" port) + (sglsl->glsl body port) + (display "}" port)) + ;; Variable definition with initial value + (('var (? symbol? type) (? symbol? name) value) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (display "=" port) + (sglsl->glsl value port)) + ;; Variable definition with undefined initial value + (('var type (? symbol? name)) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port)) + ;; Variable definition (array variant) + (('var (? symbol? type) ((? symbol? name) (? exact-integer? dimensions) ...)) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (for-each (lambda (dimension) + (display "[" port) + (display (number->string dimension) port) + (display "]" port)) + dimensions)) + ;; Constant definition + (('const (? symbol? type) (? symbol? name) value) + (display "const " port) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (display "=" port) + (sglsl->glsl value port)) + ;; Uniform declaration + (('uniform (? symbol? type) (? symbol? name)) + (display "uniform " port) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port)) + ;; Uniform declaration (array variant) + (('uniform (? symbol? type) ((? symbol? name) (? exact-integer? dimensions) ...)) + (display "uniform " port) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (for-each (lambda (dimension) + (display "[" port) + (display (number->string dimension) port) + (display "]" port)) + dimensions)) + ;; Input declaration + (('in (? symbol? type) (? symbol? name)) + (display "in " port) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port)) + ;; Output declaration + (('out (? symbol? type) (? symbol? name)) + (display "out " port) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port)) + ;; Struct definition + (('struct (? symbol? name) (((? symbol? types) (? symbol? names)) ...)) + (display "struct " port) + (display (assert-valid-identifier name) port) + (display "{" port) + (for-each (lambda (type name) + (display (assert-valid-identifier type) port) + (display " " port) + (display (assert-valid-identifier name) port) + (display ";" port)) + types names) + (display "}" port)) + ;; Function call + (((? symbol? function) args ...) + (display (assert-valid-identifier function) port) + (display "(" port) + (let loop ((args args)) + (match args + (() #t) + ((last-arg) + (sglsl->glsl last-arg port)) + ((arg . rest) + (sglsl->glsl arg port) + (display "," port) + (loop rest)))) + (display ")" port)) + ;; Sequence of expressions + ((exps ...) + (sequence exps)) + (unknown + (error "invalid SGLSL expression" unknown)))) diff --git a/tests/sglsl.scm b/tests/sglsl.scm new file mode 100644 index 0000000..fa41b1c --- /dev/null +++ b/tests/sglsl.scm @@ -0,0 +1,99 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2022 David Thompson <davet@gnu.org> +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (tests sglsl) + #:use-module (tests utils) + #:use-module (srfi srfi-64) + #:use-module (chickadee graphics sglsl)) + +(define* (test-glsl name exp expected) + (test-equal name + (with-output-to-string (lambda () (sglsl->glsl exp))) + expected)) + +(with-tests "sglsl" + (test-glsl "true" #true "true") + (test-glsl "false" #false "false") + (test-glsl "integers" 4 "4") + (test-glsl "floats" 4.5 "4.5") + (test-glsl "rationals->floats" 1/2 "0.5") + (test-glsl "+" '(+ 1 2) "(1+2)") + (test-glsl "-" '(- 2 1) "(2-1)") + (test-glsl "*" '(* 2 2) "(2*2)") + (test-glsl "/" '(/ 4 2) "(4/2)") + (test-glsl "=" '(= foo 1) "(foo=1)") + (test-glsl "+=" '(+= foo 2) "(foo+=2)") + (test-glsl "-=" '(-= foo 2) "(foo-=2)") + (test-glsl "*=" '(*= foo 2) "(foo*=2)") + (test-glsl "/=" '(/= foo 2) "(foo/=2)") + (test-glsl "==" '(== foo 1) "(foo==1)") + (test-glsl "!=" '(!= foo 1) "(foo!=1)") + (test-glsl ">" '(> foo 1) "(foo>1)") + (test-glsl ">=" '(>= foo 1) "(foo>=1)") + (test-glsl "<" '(< foo 1) "(foo<1)") + (test-glsl "<=" '(<= foo 1) "(foo<=1)") + (test-glsl "||" '(|| foo bar) "(foo||bar)") + (test-glsl "&&" '(&& foo bar) "(foo&&bar)") + (test-glsl "++" '(++ foo) "foo++") + (test-glsl "--" '(-- foo) "foo--") + (test-glsl "pre++" '(pre++ foo) "++foo") + (test-glsl "pre--" '(pre-- foo) "--foo") + (test-glsl "negation" '(! (|| foo bar)) "!(foo||bar)") + (test-glsl "break" 'break "break") + (test-glsl "continue" 'continue "continue") + (test-glsl "discard" 'discard "discard") + (test-glsl "if" '(if (== foo bar) 1) + "if((foo==bar)){1}") + (test-glsl "if/else" '(if (== foo bar) 1 2) + "if((foo==bar)){1}else{2}") + (test-glsl "ternary" '(? (== foo bar) 1 2) + "((foo==bar)?1:2)") + (test-glsl "for loop" '(for ((= i 0) (< i 10) (++ i)) (= (@ foo i) 0)) + "for((i=0);(i<10);i++){(foo[i]=0);}") + (test-glsl "variable reference" 'foo "foo") + (test-glsl "struct dereference" '(-> foo bar baz) "foo.bar.baz") + (test-glsl "array dereference" '(@ foo 1 2) "foo[1][2]") + (test-glsl "struct+array dereference" '(@ (-> foo bar) 0) "foo.bar[0]") + (test-glsl "variable definition with initial value" + '(var float foo 1.2) + "float foo=1.2") + (test-glsl "variable definition with undefined value" + '(var float foo) + "float foo") + (test-glsl "variable definition with array dimensions" + '(var float (foo 4 4)) + "float foo[4][4]") + (test-glsl "function definition" + '(function (float square (float x)) (return (* x x))) + "float square(float x){return (x*x);}") + (test-glsl "struct definition" + '(struct Light ((vec3 position) (vec3 direction))) + "struct Light{vec3 position;vec3 direction;}") + (test-glsl "constant definition" '(const float pi 3.14159) + "const float pi=3.14159") + (test-glsl "uniform declaration" '(uniform vec3 position) + "uniform vec3 position") + (test-glsl "uniform declaration with array dimensions" + '(uniform vec3 (position 2 3)) + "uniform vec3 position[2][3]") + (test-glsl "input declaration" '(in vec3 position) + "in vec3 position") + (test-glsl "output declaration" '(out vec3 position) + "out vec3 position") + (test-glsl "function call" '(vec4 1 2 3 4) "vec4(1,2,3,4)") + (test-glsl "multiple expressions" '((++ foo) (-- bar)) + "foo++;bar--;")) |