diff options
Diffstat (limited to 'chickadee/graphics/seagull/glsl.scm')
| -rw-r--r-- | chickadee/graphics/seagull/glsl.scm | 151 |
1 files changed, 151 insertions, 0 deletions
diff --git a/chickadee/graphics/seagull/glsl.scm b/chickadee/graphics/seagull/glsl.scm new file mode 100644 index 0000000..50f75d6 --- /dev/null +++ b/chickadee/graphics/seagull/glsl.scm @@ -0,0 +1,151 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; CPS to GLSL emitter. +(define-module (chickadee graphics seagull glsl) + #:use-module (chickadee graphics seagull cps) + #:use-module (chickadee graphics seagull primitives) + #:use-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 match) + #:use-module (language cps intmap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (emit-glsl)) + +(define (indent level port) + (unless (= level 0) + (display " " port) + (indent (- level 1) port))) + +(define (variable-name id) + (format #f "v~a" id)) + +(define (emit-glsl* graph k exp level port) + (define (emit-exp exp var type) + (match (pk 'emit-exp exp) + (#f #f) + (($ <cps-constant> val _) + (indent level port) + (format port "~a ~a = ~a;\n" + (type-glsl-name type) + (variable-name var) + (match val + (#t "true") + (#f "false") + (_ val)))) + (($ <cps-values> (arg)) + (indent level port) + (format port "~a ~a = ~a;\n" + (type-glsl-name type) + (variable-name var) + (variable-name arg))) + (($ <cps-assignment> from to) + (indent level port) + (format port "~a = ~a;\n" (variable-name from) (variable-name to))) + (($ <cps-primitive-call> op args _) + (let ((op* (lookup-primitive-operator op))) + (indent level port) + (format port "~a ~a = " + (type-glsl-name type) + (variable-name var)) + (if (primitive-operator-infix? op*) + (match args + ;; Infix binary operator + ((a b) + (format port "~a ~a ~a;\n" + (variable-name a) + (primitive-operator-glsl-name op*) + (variable-name b)))) + ;; Regular function call + (begin + (format port "~a(" (primitive-operator-glsl-name op*)) + (let loop ((args args)) + (match args + (() #t) + ((arg) + (display (variable-name arg) port)) + ((arg . rest) + (format port "~a, " (variable-name arg)) + (loop rest)))) + (format port ");\n"))))) + (($ <cps-function> body) + (match (intmap-ref graph body) + (($ <function-entry> _ params results start return type) + (indent level port) + (format port "function ~a(~a) {\n" + (variable-name var) + (string-join (append (map (lambda (param type) + (param-string 'in param type)) + params (function-type-parameters type)) + (map (lambda (result type) + (param-string 'out result type)) + results (function-type-returns type))) + ", ")) + (pk 'start-function-body) + (emit-glsl* graph start #f (+ level 1) port) + (pk 'done-function-body) + (indent level port) + (format port "}\n")))))) + (define (param-string qualifier var type) + (format #f "~a ~a ~a" + qualifier + (type-glsl-name type) + (variable-name var))) + (match (pk 'emit-cont (intmap-ref graph k)) + (($ <arguments> () ($ <return> ()) ()) + (indent level port) + (format port "return;\n")) + (($ <arguments> (var) ($ <return> (result)) (type)) + (emit-exp exp var type) + (indent level port) + (format port "return;\n")) + (($ <arguments> (var) ($ <return> ()) (type)) + (pk 'blah exp type) + (emit-exp exp var type) + (indent level port) + (indent level port) + (format port "return;\n")) + (($ <arguments> () ($ <continue> _ k* exp*) _) + (emit-exp exp #f #f) + (emit-glsl* graph k* exp* level port)) + (($ <arguments> (var) ($ <continue> _ k* exp*) (type)) + (emit-exp exp var type) + (emit-glsl* graph k* exp* level port)) + (($ <arguments> (var) ($ <branch> _ test k-conseq k-alt) (type)) + (emit-exp exp var type) + (indent level port) + (format port "if(~a) {\n" (variable-name test)) + (emit-glsl* graph k-conseq #f (+ level 1) port) + (format port "} else {\n") + (emit-glsl* graph k-alt #f (+ level 1) port) + (format port "}\n")))) + +(define (emit-glsl graph) + (call-with-output-string + (lambda (port) + (emit-glsl* graph 0 #f 0 port)))) + +;; (define test-cps +;; (let ((int (lookup-type 'int))) +;; (alist->intmap +;; `((0 . ,(make-arguments '() (make-continue #f 1 (make-cps-constant 1)))) +;; (1 . ,(make-arguments '(0) (make-continue #f 3 (make-cps-constant 2)))) +;; (2 . ,(make-arguments '(1) (make-continue #f 5 (make-cps-primitive-call '+ '(0 1) int)))) +;; (3 . ,(make-arguments '(3) (make-continue #f 4 (make-cps-constant 3)))) +;; (4 . ,(make-arguments '(4) (make-continue #f 2 (make-cps-primitive-call '* '(3 4) int)))) +;; (5 . ,(make-arguments '(5) (make-continue #f #f (make-cps-values '(5))))))))) + +;; (emit-glsl test-cps) |