diff options
| -rw-r--r-- | 2d/shader.scm | 9 | ||||
| -rw-r--r-- | 2d/transform.scm | 169 | ||||
| -rw-r--r-- | Makefile.am | 1 |
3 files changed, 179 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)) diff --git a/Makefile.am b/Makefile.am index 0bc83eb..bcae0ac 100644 --- a/Makefile.am +++ b/Makefile.am @@ -25,6 +25,7 @@ SOURCES = \ 2d/texture.scm \ 2d/tileset.scm \ 2d/time.scm \ + 2d/transform.scm \ 2d/vector2.scm \ 2d/window.scm \ $(REPL_SOURCES) \ |