summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2022-07-13 12:09:45 -0400
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commitcc06f8302c3614390a2ea4095a39a0b444e553f3 (patch)
treec2b85ae1b6767946f85dd42daa1a04784df6eca2
parent97a628e313e020b4a1638851fcf8e98a0dc761d7 (diff)
graphics: Add SGLSL module.
-rw-r--r--Makefile.am4
-rw-r--r--chickadee/graphics/sglsl.scm339
-rw-r--r--tests/sglsl.scm99
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--;"))