graphics: Add SGLSL module.

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--;"))