From a64baea5802351750668633b5318f70d55376d5a Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Fri, 15 Aug 2014 22:36:44 -0400
Subject: Add camera module.

* Makefile.am (SOURCES): Add it.
* sly/camera.scm: New file.
---
 Makefile.am    |  1 +
 sly/camera.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 100 insertions(+)
 create mode 100644 sly/camera.scm

diff --git a/Makefile.am b/Makefile.am
index 468c42f..2790eea 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -24,6 +24,7 @@ SOURCES = 					\
   sly/agenda.scm 				\
   sly/animation.scm				\
   sly/audio.scm					\
+  sly/camera.scm				\
   sly/color.scm					\
   sly/config.scm					\
   sly/coroutine.scm				\
diff --git a/sly/camera.scm b/sly/camera.scm
new file mode 100644
index 0000000..8992acf
--- /dev/null
+++ b/sly/camera.scm
@@ -0,0 +1,99 @@
+;;; Sly
+;;; Copyright (C) 2014 David Thompson <davet@gnu.org>
+;;;
+;;; Sly 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.
+;;;
+;;; Sly 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:
+;;
+;; A view to a scene graph.
+;;
+;;; Code:
+
+(define-module (sly camera)
+  #:use-module (srfi srfi-9)
+  #:use-module (gl)
+  #:use-module (sly wrappers gl)
+  #:use-module (sly color)
+  #:use-module (sly rect)
+  #:use-module (sly scene)
+  #:use-module (sly signal)
+  #:use-module (sly transform)
+  #:export (make-camera
+            camera?
+            camera-scene
+            camera-location
+            camera-projection
+            camera-viewport
+            camera-clear-flags
+            camera-clear-color
+            draw-camera))
+
+(define-record-type <camera>
+  (%make-camera scene location projection viewport clear-flags clear-color)
+  camera?
+  (scene camera-scene)
+  (location camera-location)
+  (projection camera-projection)
+  (viewport camera-viewport)
+  (clear-flags camera-clear-flags)
+  (clear-color camera-clear-color))
+
+(define* (make-camera scene location projection viewport
+                      #:optional #:key
+                      (clear-flags '(color-buffer depth-buffer))
+                      (clear-color black))
+  (%make-camera scene location projection viewport clear-flags clear-color))
+
+;; guile-opengl's clear-buffer-mask does not work with symbols, only
+;; syntax.
+(define (clear-buffer-mask . flags)
+  (apply logior
+   (map (lambda (flag)
+          (assq-ref '((depth-buffer . 256)
+                      (accum-buffer . 512)
+                      (stencil-buffer . 1024)
+                      (color-buffer . 16384)
+                      (coverage-buffer-bit-nv . 32768))
+                    flag))
+        flags)))
+
+(define (clear-camera camera)
+  "Define viewport and clear it."
+  (let ((vp (camera-viewport camera))
+        (c (camera-clear-color camera)))
+    (gl-viewport (rect-x vp)
+                 (rect-y vp)
+                 (rect-width vp)
+                 (rect-height vp))
+    ;; Restrict gl-clear to the viewport.
+    (gl-scissor (rect-x vp)
+                (rect-y vp)
+                (rect-width vp)
+                (rect-height vp))
+    (gl-clear-color (color-r c)
+                    (color-g c)
+                    (color-b c)
+                    (color-a c))
+    (gl-clear (apply clear-buffer-mask (camera-clear-flags camera)))))
+
+(define (draw-camera camera alpha)
+  "Draw SCENE from the perspective of CAMERA with interpolation factor
+ALPHA."
+  (clear-camera camera)
+  (draw-scene-node (camera-scene camera)
+                   alpha
+                   (transform*
+                    (signal-ref-maybe (camera-projection camera))
+                    (signal-ref-maybe (camera-location camera)))))
-- 
cgit v1.2.3