Add 4x4 transformation matrix module.

* 2d/transform.scm: New module.
* 2d/shader.scm: Add uniform setter for transforms.
* Makefile.am (SOURCES): Add '2d/transform.scm'.

2 files changed, 178 insertions, 0 deletions

diff --git a/2d/shader.scm b/2d/shader.scm
index 86fc1e2..fb03439 100644
--- a/2d/shader.scm
+++ b/2d/shader.scm
@@ -8,6 +8,7 @@
   #:use-module (figl gl)
   #:use-module (figl gl low-level)
   #:use-module (2d helpers)
+  #:use-module (2d transform)
   #:use-module (2d vector2)
   #:use-module (2d color)
   #:export (make-shader
@@ -224,6 +225,14 @@ location."
                             ;; vec4s.
                             (glUniform4f location (vx v) (vy v) 0 0)))
 
+(register-uniform-setter! transform?
+                          (lambda (location t)
+                            (let ((pointer
+                                   (bytevector->pointer
+                                    (array-contents (transform-matrix t)))))
+                              (glUniformMatrix4fv location 1 #f
+                                                  pointer))))
+
 (register-uniform-setter! color?
                           (lambda (location c)
                             (glUniform4f location
diff --git a/2d/transform.scm b/2d/transform.scm
new file mode 100644
index 0000000..f449671
--- /dev/null
+++ b/2d/transform.scm
@@ -0,0 +1,169 @@
+;;; guile-2d
+;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Guile-2d is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-2d 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; 4x4 column-major transformation matrix.
+;;
+;;; Code:
+
+(define-module (2d transform)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-42)
+  #:use-module (2d vector2)
+  #:export (make-transform
+            null-transform
+            identity-transform
+            transform?
+            transform-matrix
+            transpose
+            transform-vector2
+            transform+
+            transform*
+            translate
+            scale
+            rotate
+            orthographic-projection))
+
+(define-record-type <transform>
+  (%make-transform matrix)
+  transform?
+  (matrix transform-matrix))
+
+(define (make-4x4-matrix)
+  (make-typed-array 'f32 0 4 4))
+
+(define (make-transform aa ab ac ad
+                        ba bb bc bd
+                        ca cb cc cd
+                        da db dc dd)
+  "Return a new transform initialized with the given 16 values in
+column-major format."
+  (let ((matrix (make-4x4-matrix)))
+    (array-set! matrix aa 0 0)
+    (array-set! matrix ab 0 1)
+    (array-set! matrix ac 0 2)
+    (array-set! matrix ad 0 3)
+    (array-set! matrix ba 1 0)
+    (array-set! matrix bb 1 1)
+    (array-set! matrix bc 1 2)
+    (array-set! matrix bd 1 3)
+    (array-set! matrix ca 2 0)
+    (array-set! matrix cb 2 1)
+    (array-set! matrix cc 2 2)
+    (array-set! matrix cd 2 3)
+    (array-set! matrix da 3 0)
+    (array-set! matrix db 3 1)
+    (array-set! matrix dc 3 2)
+    (array-set! matrix dd 3 3)
+    (%make-transform matrix)))
+
+(define null-transform
+  (%make-transform (make-4x4-matrix)))
+
+(define identity-transform
+  (make-transform 1 0 0 0
+                  0 1 0 0
+                  0 0 1 0
+                  0 0 0 1))
+
+(define (transpose transform)
+  "Return a transform that is the transpose of TRANSFORM."
+  (let ((m1 (transform-matrix transform))
+        (m2 (make-4x4-matrix)))
+    (do-ec (: r 4) (: c 4)
+           (array-set! m2 (array-ref m1 r c)
+                       c r))
+    (%make-transform m2)))
+
+(define (transform-vector2 transform v)
+  "Apply TRANSFORM to the vector2 V."
+  (let ((m (transform-matrix transform))
+        (x (vx v))
+        (y (vy v)))
+    (vector2 (+ (* x (array-ref m 0 0))
+                (* y (array-ref m 0 1))
+                (array-ref m 0 3))
+             (+ (* x (array-ref m 1 0))
+                (* y (array-ref m 1 1))
+                (array-ref m 1 3)))))
+
+(define (transform+ . transforms)
+  "Return the sum of all given transformation matrices.  Return
+null-transform if called without any arguments."
+  (define (add a b)
+    (let ((m1 (transform-matrix a))
+          (m2 (transform-matrix b))
+          (m3 (make-4x4-matrix)))
+      (do-ec (: r 4) (: c 4)
+             (let ((x (+ (array-ref m1 r c)
+                         (array-ref m2 r c))))
+               (array-set! m3 x r c)))
+      (%make-transform m3)))
+  (reduce add null-transform transforms))
+
+(define (transform* . transforms)
+  "Return the product of all given transformation matrices.  Return
+identity-transform if called without any arguments."
+  (define (mul a b)
+    (let ((m1 (transform-matrix a))
+          (m2 (transform-matrix b))
+          (m3 (make-4x4-matrix)))
+      (do-ec (: r 4) (: c 4)
+             (let ((x (sum-ec (: k 4)
+                              (* (array-ref m1 r k)
+                                 (array-ref m2 k c)))))
+               (array-set! m3 x r c)))
+      (%make-transform m3)))
+  (reduce mul identity-transform transforms))
+
+(define (translate v)
+  "Return a new transform that translates the x and y axes by the
+vector2 V."
+  (make-transform 1 0 0 (vx v)
+                  0 1 0 (vy v)
+                  0 0 1 0
+                  0 0 0 1))
+
+(define (scale v)
+  "Return a new transform that scales the X and Y axes by the vector2
+V."
+  (make-transform (vx v) 0      0 0
+                  0      (vy v) 0 0
+                  0      0      1 0
+                  0      0      0 1))
+
+(define (rotate angle)
+  "Return a new transform that rotates the Z axis by ANGLE radians."
+  (make-transform (cos angle) (- (sin angle)) 0 0
+                  (sin angle) (cos angle)     0 0
+                  0           0               1 0
+                  0           0               0 1))
+
+(define (orthographic-projection left right top bottom near far)
+  "Return a new transform that represents an orthographic projection
+for the vertical clipping plane LEFT and RIGHT, the horizontal
+clipping plane TOP and BOTTOM, and the depth clipping plane NEAR and
+FAR."
+  (make-transform (/ 2 (- right left)) 0 0 0
+                  0 (/ 2 (- top bottom)) 0 0
+                  0 0 (/ 2 (- far near)) 0
+                  (- (/ (+ right left) (- right left)))
+                  (- (/ (+ top bottom) (- top bottom)))
+                  (- (/ (+ far near) (- far near)))
+                  1))