render: Add group and model modules.

* sly/render/model.scm: New file.
* sly/render/group.scm: New file.
* Makefile.am (SOURCES): Add them.

3 files changed, 254 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index ea11a5f..929f9ba 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -48,6 +48,8 @@ SOURCES = 					\
   sly/render/font.scm				\
   sly/render/framebuffer.scm			\
   sly/render/mesh.scm				\
+  sly/render/model.scm				\
+  sly/render/group.scm				\
   sly/render/texture.scm			\
   sly/render/scene.scm				\
   sly/render/shader.scm				\
diff --git a/sly/render/group.scm b/sly/render/group.scm
new file mode 100644
index 0000000..e3e53a3
--- /dev/null
+++ b/sly/render/group.scm
@@ -0,0 +1,126 @@
+;;; 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:
+;;
+;; Hierarchy of renderable objects using a directed acyclic graph
+;; structure.
+;;
+;;; Code:
+
+(define-module (sly render group)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (sly math transform)
+  #:use-module (sly render shader)
+  #:use-module (sly render texture)
+  #:use-module (sly render utils)
+  #:use-module (sly render camera)
+  #:use-module (sly render context)
+  #:use-module (sly render model)
+  #:export (make-group group
+            group?
+            group-transform group-visible? group-children
+            draw-group
+            move place show))
+
+;;;
+;;; Group
+;;;
+
+;; The composite object of the scene graph.  Groups have zero or more
+;; children, which may be groups or models.
+(define-record-type <group>
+  (%make-group transform visible? children)
+  group?
+  (transform group-transform)
+  (visible? group-visible?)
+  (children group-children))
+
+(define* (make-group children #:optional #:key (transform identity-transform)
+                     (visible? #t))
+  "Create a new group containing CHILDREN in which each child is
+rendered relative to TRANSFORM.  The VISIBLE? flag determines whether
+or not to render child nodes."
+  (%make-group transform visible? children))
+
+(define (%draw-group group parent-transform view context)
+  (match group
+    (($ <group> transform visible? children)
+     (when visible?
+       (with-temp-transform context world-transform
+         (transform*! world-transform transform parent-transform)
+         (for-each (lambda (child)
+                     (let ((draw (match child
+                                   ((? group? group) %draw-group)
+                                   ((? model? model) draw-model))))
+                       (draw child world-transform view context)))
+                   children))))))
+
+(define (set-transform-identity! t)
+  (let ((matrix (transform-matrix t)))
+    (array-set! matrix 1 0 0)
+    (array-set! matrix 0 0 1)
+    (array-set! matrix 0 0 2)
+    (array-set! matrix 0 0 3)
+    (array-set! matrix 0 1 0)
+    (array-set! matrix 1 1 1)
+    (array-set! matrix 0 1 2)
+    (array-set! matrix 0 1 3)
+    (array-set! matrix 0 2 0)
+    (array-set! matrix 0 2 1)
+    (array-set! matrix 1 2 2)
+    (array-set! matrix 0 2 3)
+    (array-set! matrix 0 3 0)
+    (array-set! matrix 0 3 1)
+    (array-set! matrix 0 3 2)
+    (array-set! matrix 1 3 3)))
+
+(define (draw-group group camera context)
+  "Draw the scene defined by GROUP as viewed by CAMERA, with the given
+render CONTEXT."
+  (with-temp-transform context view
+    (transform*! view
+                 (camera-location camera)
+                 (camera-projection camera))
+    (with-temp-transform context base-transform
+      (set-transform-identity! base-transform)
+      (apply-viewport (camera-viewport camera))
+      (%draw-group group base-transform view context))))
+
+;;;
+;;; Utility Procedures
+;;;
+
+(define (group . children)
+  "Create a new group containing the list of CHILDREN."
+  (make-group children))
+
+(define (move position . children)
+  "Create a new group in which the list of CHILDREN are translated by
+the vector POSITION."
+  (make-group children #:transform (translate position)))
+
+(define (place transform . children)
+  "Create a new group in which the tranformation matrices of the
+CHILDREN are multiplied by TRANSFORM."
+  (make-group children #:transform transform))
+
+(define (show visible? . children)
+  "Create a new group in which the visibility of the list of
+CHILDREN is determined by the VISIBLE? flag."
+  (make-group children #:visible? visible?))
diff --git a/sly/render/model.scm b/sly/render/model.scm
new file mode 100644
index 0000000..c766b76
--- /dev/null
+++ b/sly/render/model.scm
@@ -0,0 +1,126 @@
+;;; 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:
+;;
+;; OpenGL rendering state.
+;;
+;;; Code:
+
+(define-module (sly render model)
+  #:use-module (system foreign)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (gl)
+  #:use-module (gl low-level)
+  #:use-module (sly math transform)
+  #:use-module (sly math vector)
+  #:use-module (sly math rect)
+  #:use-module (sly render shader)
+  #:use-module (sly render texture)
+  #:use-module (sly render utils)
+  #:use-module (sly render camera)
+  #:use-module (sly render color)
+  #:use-module (sly render context)
+  #:use-module (sly render vertex-array)
+  #:export (make-model model model-inherit
+            model?
+            model-mesh model-texture model-shader model-color
+            model-blend-mode model-depth-test?
+            draw-model
+            paint blend))
+
+;; Representation of a single OpenGL render call.
+(define-record-type <model>
+  (%make-model mesh texture shader color blend-mode depth-test?)
+  model?
+  ;; This is a vertex array.
+  ;; TODO: Rename <vertex-array> to mesh and remove old mesh type.
+  (mesh model-mesh)
+  (texture model-texture)
+  (shader model-shader)
+  (color model-color)
+  (blend-mode model-blend-mode)
+  (depth-test? model-depth-test?))
+
+(define* (make-model #:optional #:key (mesh #f) (texture #f) (shader #f)
+                     (color white) (blend-mode default-blend-mode)
+                     (depth-test? #t))
+  "Create a new model from MESH and the given rendering state.  When
+rendering, TEXTURE and SHADER are bound, BLEND-MODE and DEPTH-TEST?
+are set, and the COLOR uniform variable is set."
+  (%make-model mesh texture shader color blend-mode depth-test?))
+
+(define model make-model)
+
+(define kwargs->alist
+  (match-lambda
+   (((? keyword? key) value . rest)
+    (cons (cons (keyword->symbol key) value) (kwargs->alist rest)))
+   (() '())))
+
+(define model-inherit
+  (let* ((fields (record-type-fields <model>))
+         (field-indices (iota (length fields))))
+    (lambda (original . kwargs)
+      "Create a new model based on the fields of ORIGINAL, only
+changing the fields specified in KWARGS."
+      (let ((field+value (kwargs->alist kwargs)))
+        (apply %make-model
+               (map (lambda (field index)
+                      (let ((override (find (match-lambda
+                                             ((k . v)
+                                              (eq? field k)))
+                                            field+value)))
+                        (if override
+                            (cdr override)
+                            (struct-ref original index))))
+                    fields field-indices))))))
+
+(define (draw-model model world-transform view context)
+  "Render MODEL by applying its transform (multiplied by VIEW), texture,
+shader, vertex array, uniforms, blend mode, etc. to the render
+CONTEXT."
+  (match model
+    (($ <model> mesh texture shader color blend-mode depth-test?)
+     (with-temp-transform context mvp
+       (transform*! mvp world-transform view)
+       (set-render-context-depth-test?! context depth-test?)
+       (set-render-context-blend-mode! context blend-mode)
+       (set-render-context-shader! context shader)
+       (set-render-context-vertex-array! context mesh)
+       (set-render-context-texture! context texture)
+       ;; TODO: Support user-defined uniforms.
+       (uniform-set! shader "mvp" mvp)
+       (uniform-set! shader "color" color)
+       (glDrawElements (begin-mode triangles)
+                       (vertex-array-length mesh)
+                       (data-type unsigned-int)
+                       %null-pointer)))))
+
+;;;
+;;; Utility Procedures
+;;;
+
+(define (paint color model)
+  "Create a copy of MODEL, but with a new COLOR."
+  (model-inherit model #:color color))
+
+(define (blend blend-mode model)
+  "Create a copy of MODEL, but with a new BLEND-MODE."
+  (model-inherit model #:blend-mode blend-mode))