vectometry/matrix.lisp

   1 ;;;; matrix.lisp
   2
   3 (in-package #:vecto-geometry)
   4
   5 (defclass transform-matrix ()
   6   ((x-scale
   7     :initarg :x-scale
   8     :accessor x-scale)
   9    (y-skew
  10     :initarg :y-skew
  11     :accessor y-skew)
  12    (x-skew
  13     :initarg :x-skew
  14     :accessor x-skew)
  15    (y-scale
  16     :initarg :y-scale
  17     :accessor y-scale)
  18    (x-offset
  19     :initarg :x-offset
  20     :accessor x-offset)
  21    (y-offset
  22     :initarg :y-offset
  23     :accessor y-offset))
  24   (:default-initargs
  25    :x-scale 1.0
  26    :y-skew 0.0
  27    :x-skew 0.0
  28    :y-scale 1.0
  29    :x-offset 0.0
  30    :y-offset 0.0))
  31
  32 (defmethod print-object ((matrix transform-matrix) stream)
  33   (print-unreadable-object (matrix stream :type t)
  34     (format stream "~F ~F ~F ~F ~F ~F"
  35             (x-scale matrix)
  36             (y-skew matrix)
  37             (x-skew matrix)
  38             (y-scale matrix)
  39             (x-offset matrix)
  40             (y-offset matrix))))
  41
  42 (defun transform-matrix (a b c d e f)
  43   (make-instance 'transform-matrix
  44                  :x-scale a
  45                  :y-skew b
  46                  :x-skew c
  47                  :y-scale d
  48                  :x-offset e
  49                  :y-offset f))
  50
  51 (defvar *identity-matrix* (make-instance 'transform-matrix))
  52
  53 (defmacro transform-matrix-bind (lambda-list matrix  &body body)
  54   (when (/= (length lambda-list) 6)
  55     (error "Bad lambda-list for MATRIX-BIND: 6 arguments required"))
  56   (let ((mat (gensym))
  57         (slots '(x-scale y-skew x-skew y-scale x-offset y-offset)))
  58     `(let ((,mat ,matrix))
  59        (let (,@(loop for slot in slots
  60                      for var in lambda-list
  61                      collect (list var `(,slot ,mat))))
  62          ,@body))))
  63
  64 (defgeneric transform-function (transform-matrix)
  65   (:method ((matrix transform-matrix))
  66     (transform-matrix-bind (a b c d e f)
  67         matrix
  68       (lambda (point)
  69         (let ((x (x point))
  70               (y (y point)))
  71         (point (+ (* a x) (* c y) e)
  72                (+ (* b x) (* d y) f)))))))
  73
  74 (defgeneric transform (point matrix)
  75   (:method (point (matrix transform-matrix))
  76     (funcall (transform-function matrix) point)))
  77
  78 (defmethod mul ((m1 transform-matrix) (m2 transform-matrix))
  79   (transform-matrix-bind (a b c d e f)
  80       m1
  81     (transform-matrix-bind (a* b* c* d* e* f*)
  82         m2
  83       (transform-matrix (+ (* a a*)
  84                            (* b c*))
  85                         (+ (* a b*)
  86                            (* b d*))
  87                         (+ (* c a*)
  88                            (* d c*))
  89                         (+ (* c b*)
  90                            (* d d*))
  91                         (+ (* e a*)
  92                            (* f c*)
  93                            e*)
  94                         (+ (* e b*)
  95                            (* f d*)
  96                            f*)))))
  97
  98 (defun translation-matrix (tx ty)
  99   (transform-matrix 1 0 0 1 tx ty))
 100
 101 (defun scaling-matrix (sx sy)
 102   (transform-matrix sx 0 0 sy 0 0))
 103
 104 (defun rotation-matrix (theta)
 105   (let ((cos (cos theta))
 106         (sin (sin theta)))
 107     (transform-matrix cos sin (- sin) cos 0 0)))
 108
 109 (defun skewing-matrix (alpha beta)
 110   (transform-matrix 1 (tan alpha) (tan beta) 1 0 0))