Re-export WITH-GRAPHICS-STATE in vectometry.
[vecto.git] / transform-matrix.lisp
blob59dbae88effb953aa815d22cf3f78cd0194a15d9
1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
2 ;;;
3 ;;; Redistribution and use in source and binary forms, with or without
4 ;;; modification, are permitted provided that the following conditions
5 ;;; are met:
6 ;;;
7 ;;; * Redistributions of source code must retain the above copyright
8 ;;; notice, this list of conditions and the following disclaimer.
9 ;;;
10 ;;; * Redistributions in binary form must reproduce the above
11 ;;; copyright notice, this list of conditions and the following
12 ;;; disclaimer in the documentation and/or other materials
13 ;;; provided with the distribution.
14 ;;;
15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
26 ;;;
27 ;;; $Id: transform-matrix.lisp,v 1.6 2007/09/28 20:35:08 xach Exp $
29 (in-package #:vecto)
31 (defstruct (transform-matrix (:type vector))
32 (x-scale 1.0)
33 (y-skew 0.0)
34 (x-skew 0.0)
35 (y-scale 1.0)
36 (x-offset 0.0)
37 (y-offset 0.0))
39 (defmacro matrix-bind (lambda-list vector &body body)
40 (when (/= (length lambda-list) 6)
41 (error "Bad lambda-list for MATRIX-BIND: 6 arguments required"))
42 (let ((vec (gensym)))
43 `(let ((,vec ,vector))
44 (let (,@(loop for i from 0 below 6
45 for var in lambda-list
46 collect (list var `(aref ,vec ,i))))
47 ,@body))))
49 (defun matrix (a b c d e f)
50 (vector a b c d e f))
52 (defun make-transform-function (transform-matrix)
53 (matrix-bind (a b c d e f)
54 transform-matrix
55 (lambda (x y)
56 (values (+ (* a x) (* c y) e)
57 (+ (* b x) (* d y) f)))))
59 (defun transform-coordinates (x y transform-matrix)
60 (matrix-bind (a b c d e f)
61 transform-matrix
62 (values (+ (* a x) (* c y) e)
63 (+ (* b x) (* d y) f))))
66 ;;; Multiplication:
67 ;;;
68 ;;; a b 0 a*b*0
69 ;;; c d 0 x c*d*0
70 ;;; e f 1 e*f*1
72 (defun mult (m1 m2)
73 (matrix-bind (a b c d e f)
75 (matrix-bind (a* b* c* d* e* f*)
77 (matrix (+ (* a a*)
78 (* b c*))
79 (+ (* a b*)
80 (* b d*))
81 (+ (* c a*)
82 (* d c*))
83 (+ (* c b*)
84 (* d d*))
85 (+ (* e a*)
86 (* f c*)
87 e*)
88 (+ (* e b*)
89 (* f d*)
90 f*)))))
92 (defun nmult (m1 m2)
93 "Destructive MULT; M2 is modified to hold the result of multiplication."
94 (matrix-bind (a b c d e f)
96 (matrix-bind (a* b* c* d* e* f*)
98 (setf (aref m2 0)
99 (+ (* a a*)
100 (* b c*))
101 (aref m2 1)
102 (+ (* a b*)
103 (* b d*))
104 (aref m2 2)
105 (+ (* c a*)
106 (* d c*))
107 (aref m2 3)
108 (+ (* c b*)
109 (* d d*))
110 (aref m2 4)
111 (+ (* e a*)
112 (* f c*)
114 (aref m2 5)
115 (+ (* e b*)
116 (* f d*)
117 f*))
118 m2)))
120 (defun translation-matrix (tx ty)
121 (matrix 1 0 0 1 tx ty))
123 (defun scaling-matrix (sx sy)
124 (matrix sx 0 0 sy 0 0))
126 (defun rotation-matrix (theta)
127 (let ((cos (cos theta))
128 (sin (sin theta)))
129 (matrix cos sin (- sin) cos 0 0)))
131 (defun skewing-matrix (alpha beta)
132 (matrix 1 (tan alpha) (tan beta) 1 0 0))
134 (defun identity-matrix ()
135 (matrix 1.0 0.0 0.0 1.0 0.0 0.0))
138 ;; From http://www.dr-lex.be/random/matrix_inv.html via Raymond Toy
140 (defun invert-matrix (matrix)
141 (matrix-bind (a11 a12 a21 a22 a31 a32)
142 matrix
143 (let ((a13 0)
144 (a23 0)
145 (a33 1))
146 (let* ((a33a22 (* a33 a22))
147 (a32a23 (* a32 a23))
148 (a33a12 (* a33 a12))
149 (a32a13 (* a32 a13))
150 (a23a12 (* a23 a12))
151 (a22a13 (* a22 a13))
152 (determinant
153 ;; a11(a33a22-a32a23)-a21(a33a12-a32a13)+a31(a23a12-a22a13)
154 (- (* a11 (- a33a22 a32a23))
155 (+ (* a21 (- a33a12 a32a13))
156 (* a31 (- a23a12 a22a13))))))
157 ;; a33a22-a32a23 -(a33a12-a32a13)
158 ;; -(a33a21-a31a23) a33a11-a31a13
159 ;; a32a21-a31a22 -(a32a11-a31a12)
160 (let ((a (- a33a22 a32a23))
161 (b (- (- a33a12 a32a13)))
162 (c (- (- (* a33 a21) (* a31 a23))))
163 (d (- (* a33 a11) (* a31 a13)))
164 (e (- (* a32 a21) (* a31 a22)))
165 (f (- (- (* a32 a11) (* a31 a12)))))
166 (matrix (/ a determinant)
167 (/ b determinant)
168 (/ c determinant)
169 (/ d determinant)
170 (/ e determinant)
171 (/ f determinant)))))))