transform-matrix.lisp

   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 $
  28
  29 (in-package #:vecto)
  30
  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))
  38
  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))))
  48
  49 (defun matrix (a b c d e f)
  50   (vector a b c d e f))
  51
  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)))))
  58
  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))))
  64
  65
  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
  71
  72 (defun mult (m1 m2)
  73   (matrix-bind (a b c d e f)
  74       m1
  75     (matrix-bind (a* b* c* d* e* f*)
  76         m2
  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*)))))
  91
  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)
  95       m1
  96     (matrix-bind (a* b* c* d* e* f*)
  97         m2
  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*)
 113                e*)
 114             (aref m2 5)
 115             (+ (* e b*)
 116                (* f d*)
 117                f*))
 118       m2)))
 119
 120 (defun translation-matrix (tx ty)
 121   (matrix 1 0 0 1 tx ty))
 122
 123 (defun scaling-matrix (sx sy)
 124   (matrix sx 0 0 sy 0 0))
 125
 126 (defun rotation-matrix (theta)
 127   (let ((cos (cos theta))
 128         (sin (sin theta)))
 129     (matrix cos sin (- sin) cos 0 0)))
 130
 131 (defun skewing-matrix (alpha beta)
 132   (matrix 1 (tan alpha) (tan beta) 1 0 0))
 133
 134 (defun identity-matrix ()
 135   (matrix 1.0 0.0 0.0 1.0 0.0 0.0))
 136
 137
 138 ;; From http://www.dr-lex.be/random/matrix_inv.html via Raymond Toy
 139
 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)))))))
 172