;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: The CLIM Transformations ;;; Created: 1998-09-29 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; $Id: $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library 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 ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;;; Changes ;;; When Who What ;;; -------------------------------------------------------------------------------------- ;;; 2001-07-16 GB added a cache for the inverse transformation ;;; nobody bothers to use the log above ;-( ;; The CLIM 2 spec says: ;; "Implementations are encouraged to allow transformations that are not ;; numerically equal due to floating-point roundoff errors to be ;; TRANSFORMATION-EQUAL. An appropriae level of 'fuzziness' is ;; single-float-epsilon, or some small multiple of single-float-epsilon." ;; Note: All the predicates like RIGID-TRANSFORMATION-P, ;; RECTILINEAR-TRANSFORMATION-P etc. inherit the "fuzziness" defined by ;; COORDINATE-EPSILON. An implementation of a medium probably invoke these ;; predicates to decide, whether the graphics primitives provided by the ;; underlying windowing system could be used; or if they have to use an own ;; implementation, which may be much slower, since individual pixels may have to ;; be transferred. So I trade speed for precision here. ;; Of course it would be better to assume some resomable maximal device ;; coordinate for instance 40" * 2400dpi. Now two transformations could be said ;; to be practically equal, if the (rounded) images of any point within that ;; range are equal. ;;;; ---------------------------------------------------------------------------------------------------- ;;;; Transformations ;;;; (define-protocol-class transformation ()) (defclass standard-transformation (transformation) () (:documentation "All CLIM transformations inherit from this. All transformations of this class should provide a method for GET-TRANSFORMATION, as this is our internal transformation protocol.")) (defclass standard-identity-transformation (standard-transformation) ()) (defclass standard-translation (standard-transformation) ((dx :type coordinate :initarg :dx) (dy :type coordinate :initarg :dy))) (defclass cached-inverse-transformation-mixin () ((inverse :type (or null standard-transformation) :initform nil :documentation "Cached inverse transformation."))) (defclass standard-hairy-transformation (standard-transformation cached-inverse-transformation-mixin) ((mxx :type coordinate :initarg :mxx) (mxy :type coordinate :initarg :mxy) (myx :type coordinate :initarg :myx) (myy :type coordinate :initarg :myy) (tx :type coordinate :initarg :tx) (ty :type coordinate :initarg :ty)) (:documentation "A transformation class which is neither the identity nor a translation.")) (defmethod print-object ((self standard-transformation) sink) (print-unreadable-object (self sink :identity nil :type t) (apply #'format sink "~S ~S ~S ~S ~S ~S" (multiple-value-list (get-transformation self))))) (defun make-transformation (mxx mxy myx myy tx ty) ;; Make a transformation, which will map a point (x,y) into ;; x' = mxx*x + mxy*y + tx ;; y' = myx*x + myy*y + ty (let ((mxx (coerce mxx 'coordinate)) (mxy (coerce mxy 'coordinate)) (myx (coerce myx 'coordinate)) (myy (coerce myy 'coordinate)) (tx (coerce tx 'coordinate)) (ty (coerce ty 'coordinate))) (cond ((and (= 1 mxx) (= 0 mxy) (= 0 myx) (= 1 myy)) (cond ((and (= 0 tx) (= 0 ty)) +identity-transformation+) (t (make-translation-transformation tx ty)))) (t (make-instance 'standard-hairy-transformation :mxx mxx :mxy mxy :tx tx :myx myx :myy myy :ty ty))))) (defgeneric get-transformation (transformation) (:documentation "Get the values of the transformation matrix as multiple values. This is not an exported function!")) (defmethod get-transformation ((transformation standard-identity-transformation)) (values 1 0 0 1 0 0)) (defmethod get-transformation ((transformation standard-translation)) (with-slots (dx dy) transformation (values 1 0 0 1 dx dy))) (defmethod get-transformation ((transformation standard-hairy-transformation)) (with-slots (mxx mxy myx myy tx ty) transformation (values mxx mxy myx myy tx ty))) (defun make-translation-transformation (translation-x translation-y) (make-instance 'standard-translation :dx translation-x :dy translation-y)) (defun make-rotation-transformation (angle &optional origin) (if origin (make-rotation-transformation* angle (point-x origin) (point-y origin)) (make-rotation-transformation* angle 0 0))) (defun make-rotation-transformation* (angle &optional origin-x origin-y) (let ((origin-x (or origin-x 0)) (origin-y (or origin-y 0))) (let ((s (coerce (sin angle) 'coordinate)) (c (coerce (cos angle) 'coordinate))) ;; This clamping should be done more sensible -- And: is this actually a good thing? (when (coordinate= s 0) (setq s 0)) (when (coordinate= c 0) (setq c 0)) (when (coordinate= s 1) (setq s 1)) (when (coordinate= c 1) (setq c 1)) (when (coordinate= s -1) (setq s -1)) (when (coordinate= c -1) (setq c -1)) ;; Wir stellen uns hier mal ganz dumm: (make-3-point-transformation* origin-x origin-y (+ origin-x 1) origin-y origin-x (+ origin-y 1) origin-x origin-y (+ origin-x c) (+ origin-y s) (- origin-x s) (+ origin-y c)) ))) (defun make-scaling-transformation (scale-x scale-y &optional origin) (make-scaling-transformation* scale-x scale-y (if origin (point-x origin) 0) (if origin (point-y origin) 0))) (defun make-scaling-transformation* (scale-x scale-y &optional origin-x origin-y) (let ((origin-x (or origin-x 0)) (origin-y (or origin-y 0))) (make-transformation scale-x 0 0 scale-y (- origin-x (* scale-x origin-x)) (- origin-y (* scale-y origin-y)))) ) (defun make-reflection-transformation (point1 point2) (make-reflection-transformation* (point-x point1) (point-y point1) (point-x point2) (point-y point2))) (defun make-reflection-transformation* (x1 y1 x2 y2) (let ((dx (- x2 x1)) (dy (- y2 y1))) (handler-case (make-3-point-transformation* x1 y1 x2 y2 (- x1 dy) (+ y1 dx) x1 y1 x2 y2 (+ x1 dy) (- y1 dx)) (transformation-underspecified (c) (error 'reflection-underspecified :why c :coords (list x1 y1 x2 y2)))))) (defun make-3-point-transformation (point-1 point-2 point-3 point-1-image point-2-image point-3-image) (make-3-point-transformation* (point-x point-1) (point-y point-1) (point-x point-2) (point-y point-2) (point-x point-3) (point-y point-3) (point-x point-1-image) (point-y point-1-image) (point-x point-2-image) (point-y point-2-image) (point-x point-3-image) (point-y point-3-image))) (defun make-3-point-transformation* (x1 y1 x2 y2 x3 y3 x1-image y1-image x2-image y2-image x3-image y3-image) ;; Find a transformation matrix, which transforms each of the three ;; points (x_i, y_i) to its image (y_i_image, y_i_image) ;; ;; Therefore, we have to solve these two linear equations: ;; ;; / x1 y1 1 \ / mxx \ / x1-image \ / myx \ / y1-image \ ;; A:= | x2 y2 1 | ; A | mxy | = | x2-image | and A | myy | = | y2-image | ; ;; \ x3 y3 1 / \ tx / \ x3-image / \ ty / \ y3-image / ;; ;; These matrices are small enough to simply calculate A^-1 = |A|^-1 (adj A). ;; (let ((det (+ (* x1 y2) (* y1 x3) (* x2 y3) (- (* y2 x3)) (- (* y1 x2)) (- (* x1 y3))))) (if (coordinate/= 0 det) (let* ((/det (/ det)) ;; a thru' i is (adj A) (a (- y2 y3)) (b (- y3 y1)) (c (- y1 y2)) (d (- x3 x2)) (e (- x1 x3)) (f (- x2 x1)) (g (- (* x2 y3) (* x3 y2))) (h (- (* x3 y1) (* x1 y3))) (i (- (* x1 y2) (* x2 y1))) ;; calculate 1/|A| * (adj A) * (x1-image x2-image x3-image)^t (mxx (* /det (+ (* a x1-image) (* b x2-image) (* c x3-image)))) (mxy (* /det (+ (* d x1-image) (* e x2-image) (* f x3-image)))) (tx (* /det (+ (* g x1-image) (* h x2-image) (* i x3-image)))) ;; finally 1/|A| * (adj A) * (y1-image y2-image y3-image)^t (myx (* /det (+ (* a y1-image) (* b y2-image) (* c y3-image)))) (myy (* /det (+ (* d y1-image) (* e y2-image) (* f y3-image)))) (ty (* /det (+ (* g y1-image) (* h y2-image) (* i y3-image))))) ;; we're done (make-transformation mxx mxy myx myy tx ty) ) ;; determinant was zero, so signal error (error 'transformation-underspecified :coords (list x1 y1 x2 y2 x3 y3 x1-image y1-image x2-image y2-image x3-image y3-image)) ))) (defparameter +identity-transformation+ (make-instance 'standard-identity-transformation)) (define-condition transformation-error (error) ()) (define-condition transformation-underspecified (transformation-error) ((coords :initarg :coords :reader transformation-error-coords)) (:report (lambda (self sink) (apply #'format sink "The three points (~D,~D), (~D,~D), and (~D,~D) are propably collinear." (subseq (transformation-error-coords self) 0 6))))) (define-condition reflection-underspecified (transformation-error) ((coords :initarg :coords :reader transformation-error-coords) (why :initarg :why :initform nil :reader transformation-error-why)) (:report (lambda (self sink) (apply #'format sink "The two points (~D,~D) and (~D,~D) are coincident." (transformation-error-coords self)) (when (transformation-error-why self) (format sink " (That was determined by the following error:~%~A)" (transformation-error-why self)))))) (define-condition singular-transformation (transformation-error) ((transformation :initarg :transformation :reader transformation-error-transformation) (why :initarg :why :initform nil :reader transformation-error-why)) (:report (lambda (self sink) (format sink "Attempt to invert the probably singular transformation ~S." (transformation-error-transformation self)) (when (transformation-error-why self) (format sink "~%Another error occurred while computing the inverse:~% ~A" (transformation-error-why self)))))) (define-condition rectangle-transformation-error (transformation-error) ((transformation :initarg :transformation :reader transformation-error-transformation) (rect :initarg :rect :reader transformation-error-rect)) (:report (lambda (self sink) (format sink "Attempt to transform the rectangle ~S through the non-rectilinear transformation ~S." (transformation-error-rect self) (transformation-error-transformation self))))) (defmethod transformation-equal ((transformation1 standard-transformation) (transformation2 standard-transformation)) (every #'coordinate= (multiple-value-list (get-transformation transformation1)) (multiple-value-list (get-transformation transformation2)))) ;; make-transformation always returns +identity-transformation+, if ;; the transformation to be build would be the identity. So we ;; IDENTITY-TRANSFORMATION-P can just specialize on ;; STANDARD-IDENTITY-TRANSFORMATION. (defmethod identity-transformation-p ((transformation standard-identity-transformation)) t) (defmethod identity-transformation-p ((transformation standard-transformation)) nil) ;; Same for translations, but +identity-transformation+ is a translation too. (defmethod translation-transformation-p ((transformation standard-translation)) t) (defmethod translation-transformation-p ((transformation standard-identity-transformation)) t) (defmethod translation-transformation-p ((transformation standard-transformation)) nil) (defun transformation-determinant (tr) (multiple-value-bind (mxx mxy myx myy) (get-transformation tr) (- (* mxx myy) (* mxy myx)))) (defmethod invertible-transformation-p ((transformation standard-transformation)) (coordinate/= 0 (transformation-determinant transformation))) (defmethod reflection-transformation-p ((transformation standard-transformation)) (< (transformation-determinant transformation) 0)) (defmethod rigid-transformation-p ((transformation standard-transformation)) (multiple-value-bind (a b c d) (get-transformation transformation) (and (coordinate= 1 (+ (* a a) (* c c))) ; |A(1,0)| = 1 (coordinate= 1 (+ (* b b) (* d d))) ; |A(0,1)| = 1 (coordinate= 0 (+ (* a b) (* c d)))))) ; (A(1,0))(A(0,1)) = 0 (defmethod even-scaling-transformation-p ((transformation standard-transformation)) (and (scaling-transformation-p transformation) (multiple-value-bind (mxx myx mxy myy) (get-transformation transformation) (declare (ignore mxy myx)) (coordinate= (abs mxx) (abs myy))))) (defmethod scaling-transformation-p ((transformation standard-transformation)) ;; Q: was ist mit dem translationsanteil? ;; what gives (scaling-transformation-p (make-translation-transformation 17 42)) ;; I think it would be strange if (s-t-p (make-s-t* 2 1 1 0)) is not T. -- APD (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (declare (ignore tx ty)) (and (coordinate= 0 mxy) (coordinate= 0 myx) (coordinate/= 0 mxx) (coordinate/= 0 myy)))) ; ? (defmethod rectilinear-transformation-p ((transformation standard-transformation)) ;; Das testen wir einfach ganz brutal ;;; ist das auch richtig? (multiple-value-bind (mxx mxy myx myy) (get-transformation transformation) (or (and (coordinate= mxx 0) (coordinate/= mxy 0) (coordinate/= myx 0) (coordinate= myy 0)) (and (coordinate/= mxx 0) (coordinate= mxy 0) (coordinate= myx 0) (coordinate/= myy 0))))) (defmethod y-inverting-transformation-p ((transformation standard-transformation)) (multiple-value-bind (mxx mxy myx myy) (get-transformation transformation) (and (coordinate= mxx 1) (coordinate= mxy 0) (coordinate= myx 0) (coordinate= myy -1)))) (defmethod compose-transformations ((transformation2 standard-transformation) (transformation1 standard-transformation)) ;; (compose-transformations A B)x = (A o B)x = ABx (multiple-value-bind (a1 b1 d1 e1 c1 f1) (get-transformation transformation1) (multiple-value-bind (a2 b2 d2 e2 c2 f2) (get-transformation transformation2) (make-transformation (+ (* a2 a1) (* b2 d1)) (+ (* a2 b1) (* b2 e1)) (+ (* d2 a1) (* e2 d1)) (+ (* d2 b1) (* e2 e1)) (+ (* a2 c1) (* b2 f1) c2) (+ (* d2 c1) (* e2 f1) f2) )))) (defmethod invert-transformation :around ((transformation cached-inverse-transformation-mixin)) (with-slots (inverse) transformation (or inverse (let ((computed-inverse (call-next-method))) (when (typep computed-inverse 'cached-inverse-transformation-mixin) (setf (slot-value computed-inverse 'inverse) transformation)) (setf inverse computed-inverse) computed-inverse)))) (defmethod invert-transformation ((transformation standard-transformation)) (restart-case (or (handler-case (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (let ((det (- (* mxx myy) (* myx mxy)))) (if (coordinate= 0 det) nil (let ((/det (/ det))) (let ((mxx (* /det myy)) (mxy (* /det (- mxy))) (myx (* /det (- myx))) (myy (* /det mxx))) (make-transformation mxx mxy myx myy (+ (* -1 mxx tx) (* -1 mxy ty)) (+ (* -1 myx tx) (* -1 myy ty)))))))) (error (c) (error 'singular-transformation :why c :transformation transformation))) (error 'singular-transformation :transformation transformation)) (use-value (value) :report (lambda (sink) (format sink "Supply a transformation to use instead of the inverse.")) value))) (defun compose-translation-with-transformation (transformation dx dy) (compose-transformations (make-translation-transformation dx dy) transformation)) (defun compose-scaling-with-transformation (transformation sx sy &optional origin) (compose-transformations (make-scaling-transformation sx sy origin) transformation)) (defun compose-rotation-with-transformation (transformation angle &optional origin) (compose-transformations (make-rotation-transformation angle origin) transformation)) (defun compose-transformation-with-translation (transformation dx dy) (compose-transformations transformation (make-translation-transformation dx dy))) (defun compose-transformation-with-scaling (transformation sx sy &optional origin) (compose-transformations transformation (make-scaling-transformation sx sy origin))) (defun compose-transformation-with-rotation (transformation angle &optional origin) (compose-transformations transformation (make-rotation-transformation angle origin))) (defmacro with-translation ((medium dx dy) &body body) `(with-drawing-options (,medium :transformation (make-translation-transformation ,dx ,dy)) ,@body)) (defmacro with-scaling ((medium sx &optional sy origin) &body body) (if sy `(with-drawing-options (,medium :transformation (make-scaling-transformation ,sx ,sy ,@(if origin (list origin) nil))) ,@body) (let ((sx-var (make-symbol "SX"))) `(let* ((,sx-var ,sx)) (with-drawing-options (,medium :transformation (make-scaling-transformation ,sx-var ,sx-var)) ,@body)) ))) (defmacro with-rotation ((medium angle &optional origin) &body body) `(with-drawing-options (,medium :transformation (make-rotation-transformation ,angle ,@(if origin (list origin) nil))) ,@body)) ;;(defmacro with-local-coordinates ((medium &optional x y) &body body)) -- what are local coordinates? ;;(defmacro with-first-quadrant-coordinates ((medium &optional x y) &body body)) ;;(defgeneric transform-region (transformation region)) (defmacro with-identity-transformation ((medium) &body body) ;; I believe this should set the medium transformation to the identity ;; transformation. To use WITH-DRAWING-OPTIONS which concatenates the the ;; transformation given to the existing one we just pass the inverse. ;; ;; Further we don't use LETF since it is a pretty much broken idea in case ;; of multithreading. ;; ;; Q: Do we want a invoke-with-identity-transformation? ;; (let ((medium (stream-designator-symbol medium))) (gen-invoke-trampoline 'invoke-with-identity-transformation (list medium) nil body))) ;; invoke-with-identity-transformation is gone to graphics.lisp ;; invoke-with-identity-transformation and ;; invoke-with-first-quadrant-coordinates ;; likewise because of the with-drawing-options macro, ;; perhaps we should gather macros in a macros.lisp file? (defmacro with-local-coordinates ((medium &optional x y) &body body) (setf medium (stream-designator-symbol medium)) (gen-invoke-trampoline 'invoke-with-local-coordinates (list medium) (list x y) body)) (defmacro with-first-quadrant-coordinates ((medium &optional x y) &body body) (setf medium (stream-designator-symbol medium)) (gen-invoke-trampoline 'invoke-with-first-quadrant-coordinates (list medium) (list x y) body)) (defmethod untransform-region ((transformation transformation) region) (transform-region (invert-transformation transformation) region)) (defmethod transform-position ((transformation standard-transformation) x y) (let ((x (coordinate x)) (y (coordinate y))) (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (declare (type coordinate mxx mxy myx myy tx ty)) (values (+ (* mxx x) (* mxy y) tx) (+ (* myx x) (* myy y) ty))))) (defmethod untransform-position ((transformation transformation) x y) (transform-position (invert-transformation transformation) x y)) (defmethod transform-distance ((transformation standard-transformation) dx dy) (let ((dx (coordinate dx)) (dy (coordinate dy))) (multiple-value-bind (mxx mxy myx myy) (get-transformation transformation) (declare (type coordinate mxx mxy myx myy)) (values (+ (* mxx dx) (* mxy dy)) (+ (* myx dx) (* myy dy)))))) (defmethod untransform-distance ((transformation transformation) dx dy) (transform-distance (invert-transformation transformation) dx dy)) (defun transform-positions (transformation coord-seq) ;; Some appliations (like a function graph plotter) use a large number of ;; coordinates, therefore we bother optimizing this. We do this by testing ;; the individual elements of the transformation matrix for being 0 or +1 or ;; -1 as these are common cases as most transformations are either mere ;; translations or just scalings. ;; ;; Also: For now we always return a vector. ;; (cond ((eql transformation +identity-transformation+) coord-seq) (t (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation transformation) (declare (type coordinate mxx mxy myx myy tx ty)) (macrolet ((do-transform () `(progn (cond ((zerop mxx)) ((= mxx +1) (for-coord-seq (setf res.x x))) ((= mxx -1) (for-coord-seq (setf res.x (- x)))) (t (for-coord-seq (setf res.x (* mxx x))))) (cond ((zerop myy)) ((= myy +1) (for-coord-seq (setf res.y y))) ((= myy -1) (for-coord-seq (setf res.y (- y)))) (t (for-coord-seq (setf res.y (* myy y))))) (unless (and (zerop mxy) (zerop myx)) (for-coord-seq (incf res.x (* mxy y)) (incf res.y (* myx x)))) (unless (and (zerop tx) (zerop ty)) (for-coord-seq (incf res.x tx) (incf res.y ty)))))) (macrolet ((do-on-vector () `(let* ((n (length coord-seq)) (res (make-array n :initial-element 0))) (declare (type simple-vector res)) (macrolet ((for-coord-seq (&rest body) `(loop for i of-type fixnum below n by 2 do (let ((x (aref coord-seq i)) (y (aref coord-seq (+ i 1)))) (declare (ignorable x y)) (symbol-macrolet ((res.x (aref res i)) (res.y (aref res (+ i 1)))) ,@body))))) (do-transform)) res)) (do-on-list () `(let* ((n (length coord-seq)) (res (make-array n :initial-element 0))) (declare (type simple-vector res)) (macrolet ((for-coord-seq (&rest body) `(loop for i of-type fixnum below n by 2 for q on coord-seq by #'cddr do (let ((x (car q)) (y (cadr q))) (declare (ignorable x y)) (symbol-macrolet ((res.x (aref res i)) (res.y (aref res (+ i 1)))) ,@body))))) (do-transform)) res))) (cond ((typep coord-seq 'simple-vector) (locally (declare (type simple-vector coord-seq)) (do-on-vector))) ((typep coord-seq 'vector) (locally (declare (type simple-vector coord-seq)) (do-on-vector))) ((typep coord-seq 'list) (locally (declare (type list coord-seq)) (do-on-list))) (t (error "~S is not a sequence." coord-seq)) ))))))) (defun transform-position-sequence (seq-type transformation coord-seq) (cond ((subtypep seq-type 'vector) (transform-positions transformation coord-seq)) (t (map-repeated-sequence seq-type 2 (lambda (x y) (transform-position transformation x y)) coord-seq)))) (defmethod transform-rectangle* ((transformation transformation) x1 y1 x2 y2) (if (rectilinear-transformation-p transformation) (multiple-value-bind (x1 y1) (transform-position transformation x1 y1) (multiple-value-bind (x2 y2) (transform-position transformation x2 y2) (values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))) (error 'rectangle-transformation-error :transformation transformation :rect (list x1 y2 x2 y2)))) (defmethod untransform-rectangle* ((transformation transformation) x1 y1 x2 y2) (transform-rectangle* (invert-transformation transformation) x1 y1 x2 y2)) (defmethod transformation-transformator ((transformation standard-transformation) &optional (input-type 'real)) ;; returns a function, which transforms its arguments (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (labels ((s* (x y) (cond ((coordinate= 0 x) nil) ((coordinate= 1 x) (list y)) ((coordinate= -1 x) (list `(- ,y))) ((list `(* ,x ,y))))) (s+ (args) (cond ((null args) (coerce 0 'coordinate)) ((null (cdr args)) (car args)) (t `(+ .,args))))) (compile nil `(lambda (x y) (declare (ignorable x y) (type ,input-type x y) (optimize (speed 3) (space 0) (safety 0))) (values ,(s+ (nconc (s* mxx 'x) (s* mxy 'y) (if (coordinate/= 0 tx) (list tx) nil))) ,(s+ (nconc (s* myx 'x) (s* myy 'y) (if (coordinate/= 0 ty) (list ty) nil))))) )))) (defmethod transformation-transformator ((transformation transformation) &optional (input-type 'real)) (declare (ignore input-type)) #'(lambda (x y) (transform-position transformation x y))) (defun atan* (x y) ;; atan so, wie wir es brauchen. ;; Bei uns ist phi=0 entlang der x-axis und Winkel sind immer zwischen 0 und 2pi. (let ((r (atan y x))) (if (< r 0) (+ r (* 2 pi)) r))) (defun correct-angle (a phi) (if (< a phi) (+ a (* 2 pi)) a)) (defun transform-angle (transformation phi) (multiple-value-bind (rotations remainder) (ffloor phi (* 2 pi)) (when (reflection-transformation-p transformation) (setq rotations (ffloor (- phi) (* 2 pi)))) (multiple-value-bind (ix iy) (transform-distance transformation (cos remainder) (sin remainder)) (multiple-value-bind (x0 y0) (transform-distance transformation 1 0) (let ((my-angle (atan* ix iy)) (null-angle (atan* x0 y0))) (+ (* rotations 2 pi) (correct-angle my-angle null-angle))))))) (defun untransform-angle (transformation phi) (multiple-value-bind (rotations remainder) (ffloor phi (* 2 pi)) (when (reflection-transformation-p transformation) (setq rotations (ffloor (- phi) (* 2 pi)))) (multiple-value-bind (ix iy) (untransform-distance transformation (cos remainder) (sin remainder)) (multiple-value-bind (x0 y0) (untransform-distance transformation 1 0) (let ((my-angle (atan* ix iy)) (null-angle (atan* x0 y0))) (+ (* rotations 2 pi) (correct-angle my-angle null-angle))))))) ;;;; Methods on special transformations for performance. (defmethod compose-transformations ((transformation2 standard-translation) (transformation1 standard-translation)) ;; (compose-transformations A B)x = (A o B)x = ABx (with-slots ((dx1 dx) (dy1 dy)) transformation1 (with-slots ((dx2 dx) (dy2 dy)) transformation2 (make-instance 'standard-translation :dx (+ dx1 dx2) :dy (+ dy1 dy2))))) (defmethod compose-transformations (transformation2 (transformation1 standard-identity-transformation)) transformation2) (defmethod compose-transformations ((transformation2 standard-identity-transformation) transformation1) transformation1) (defmethod invert-transformation ((transformation standard-identity-transformation)) transformation) (defmethod invert-transformation ((transformation standard-translation)) (with-slots (dx dy) transformation (make-translation-transformation (- dx) (- dy)))) (defmethod transform-position ((transformation standard-translation) x y) (with-slots (dx dy) transformation (let ((x (coordinate x)) (y (coordinate y))) (declare (type coordinate dx dy x y)) (values (+ x dx) (+ y dy))))) (defmethod transform-position ((transformation standard-identity-transformation) x y) (values x y)) (defmethod transform-region ((transformation standard-identity-transformation) region) region) (defun make-translation-transformation (dx dy) (make-instance 'standard-translation :dx (coordinate dx) :dy (coordinate dy))) (defmethod rectilinear-transformation-p ((tr standard-identity-transformation)) t) (defmethod rectilinear-transformation-p ((tr standard-translation)) t) (defmethod scaling-transformation-p ((tr standard-translation)) t) (defmethod scaling-transformation-p ((tr standard-identity-transformation)) t) (defmethod transformation-equal ((t1 standard-identity-transformation) (t2 standard-identity-transformation)) t) (defmethod transformation-equal ((t1 standard-identity-transformation) (t2 t)) nil) (defmethod transformation-equal ((t2 t) (t1 standard-identity-transformation)) nil) (defmethod transformation-equal ((t1 standard-translation) (t2 standard-translation)) (with-slots ((dx1 dx) (dy1 dy)) t1 (with-slots ((dx2 dx) (dy2 dy)) t2 (and (coordinate= dx1 dx2) (coordinate= dy1 dy2))))) (defmethod transformation-equal ((t1 standard-translation) (t2 t)) nil) (defmethod transformation-equal ((t2 t) (t1 standard-translation)) nil) ;; $Log: $