summaryrefslogtreecommitdiff
path: root/2d
diff options
context:
space:
mode:
Diffstat (limited to '2d')
-rw-r--r--2d/shader.scm9
-rw-r--r--2d/transform.scm169
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))