1 files changed, 135 insertions, 0 deletions
diff --git a/chickadee/render.scm b/chickadee/render.scm
new file mode 100644
index 0000000..d55c76e
--- /dev/null
+++ b/chickadee/render.scm
@@ -0,0 +1,135 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2016 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:
+;;
+;; High-level rendering API.
+;;
+;;; Code:
+
+(define-module (chickadee render)
+  #:use-module (srfi srfi-88)
+  #:use-module (chickadee math matrix)
+  #:use-module (chickadee render gpu)
+  #:use-module (chickadee render blend)
+  #:use-module (chickadee render shader)
+  #:use-module (chickadee render texture)
+  #:use-module (chickadee render vertex-buffer)
+  #:export (current-blend-mode
+            current-depth-test
+            current-texture
+            current-projection
+            with-blend-mode
+            with-depth-test
+            with-texture
+            with-projection
+            gpu-apply
+            gpu-apply*))
+
+(define *current-blend-mode* 'replace)
+(define *current-depth-test* #f)
+(define *current-texture* null-texture)
+(define *current-projection* (make-identity-matrix4))
+
+(define (current-blend-mode)
+  *current-blend-mode*)
+
+(define (current-depth-test)
+  *current-depth-test*)
+
+(define (current-texture)
+  *current-texture*)
+
+(define (current-projection)
+  *current-projection*)
+
+(define-syntax-rule (with (name value) body ...)
+  (let ((prev name))
+    (dynamic-wind
+      (lambda () (set! name value))
+      (lambda () body ...)
+      (lambda () (set! name prev)))))
+
+(define-syntax-rule (with-blend-mode blend-mode body ...)
+  (with (*current-blend-mode* blend-mode) body ...))
+
+(define-syntax-rule (with-depth-test depth-test body ...)
+  (with (*current-depth-test* depth-test) body ...))
+
+(define-syntax-rule (with-texture texture body ...)
+  (with (*current-texture* texture) body ...))
+
+(define-syntax-rule (with-shader shader body ...)
+  (with (*current-shader* shader)
+        (initialize-uniforms)
+        body ...))
+
+(define-syntax-rule (with-vertex-array vertex-array body ...)
+  (with (*current-vertex-array* vertex-array) body ...))
+
+(define-syntax-rule (with-projection matrix body ...)
+  (with (*current-projection* matrix) body ...))
+
+;; (define (initialize-uniforms)
+;;   (hash-for-each (lambda (name uniform)
+;;                    (unless (hash-get-handle *current-uniforms* name)
+;;                      (hash-set! *current-uniforms* name
+;;                                 (uniform-default-value uniform))))
+;;                  (shader-uniforms *current-shader*)))
+
+;; (define-syntax uniform-let
+;;   (syntax-rules ()
+;;     ((_ () body ...) (begin body ...))
+;;     ((_ ((name value) . rest) body ...)
+;;      (let ((uniform (shader-uniform (current-shader) name))
+;;            (prev (hash-ref *current-uniforms* name)))
+;;        (if uniform
+;;            (dynamic-wind
+;;              (lambda ()
+;;                (hash-set! *current-uniforms* name value))
+;;              (lambda ()
+;;                (uniform-let rest body ...))
+;;              (lambda ()
+;;                (hash-set! *current-uniforms* name prev)))
+;;            (error "no such uniform: " name))))))
+
+;; (define (uniform-ref name)
+;;   (uniform-value (shader-uniform (current-shader) name)))
+
+(define-syntax uniform-apply
+  (lambda (x)
+    (syntax-case x ()
+      ((_ shader ()) (datum->syntax x #t))
+      ((_ shader (name value . rest))
+       (with-syntax ((sname (datum->syntax x (keyword->string
+                                              (syntax->datum #'name)))))
+         #'(begin
+             (set-uniform-value! (shader-uniform shader sname) value)
+             (uniform-apply shader rest)))))))
+
+(define-syntax-rule (gpu-apply* shader vertex-array count . uniforms)
+  (begin
+    (gpu-state-set! *blend-mode-state* (current-blend-mode))
+    (gpu-state-set! *depth-test-state* (current-depth-test))
+    (gpu-state-set! *texture-state* (current-texture))
+    (gpu-state-set! *shader-state* shader)
+    (gpu-state-set! *vertex-array-state* vertex-array)
+    (uniform-apply shader uniforms)
+    (render-vertices count)))
+
+(define-syntax-rule (gpu-apply shader vertex-array uniforms ...)
+  (gpu-apply* shader vertex-array #f uniforms ...))