transform.lisp

;;;-*- Mode:Common-Lisp; Package:PICTURES; Base:10 -*-
;;;
;;;
;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 149149
;;;			       AUSTIN, TEXAS 78714-9149
;;;
;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Authors: Delmar Hager, James Dutton, Teri Crowe
;;; Contributors: Kerry Kimbrough, Patrick Hogan, Eric Mielke

(in-package :pictures)


(defparameter  *vector-cache* nil)

;;; Transform Class Definition:

(defclass transform ()
  (
   (t11		:type     float
                :initarg  :t11
		:reader   t11
                :initform 1.0
		:documentation "Position (1,1) in transform matrix")

   (t12		:type     float
                :initarg  :t12
 		:reader   t12
		:initform 0.0
		:documentation "Position (1,2) in transform matrix")

   (t21		:type     float
                :initarg  :t21
		:reader   t21
                :initform 0.0
		:documentation "Position (2,1) in transform matrix")

   (t22		:type     float
                :initarg  :t22
		:reader   t22
                :initform 1.0
		:documentation "Position (2,2) in transform matrix")

   (t31		:type     float
                :initarg  :t31
		:reader   t31
                :initform 0.0
		:documentation "Position (3,1) in transform matrix")

   (t32		:type     float
                :initarg  :t32
		:reader   t32
                :initform 0.0
		:documentation "Position (3,2) in transform matrix")
   )
  (:documentation "Represents a 3x3 homogeneous coordinate system transform matrix"))


;Function: make-transform
;  Create a new transform object.  With no initargs, this creates an identity transform.

(defun make-transform (&rest initargs
                         &key &allow-other-keys)



  (apply #'make-instance 'transform initargs))


;Private Variable: temp-transform
;  Used in compose-transform to hold temporary result
(defvar *temp-transform* (make-transform))


;Function: compose-transform
;  Change the RESULT transform to be the product of (TRANSFORM-1 x
;  TRANSFORM-2).  If RESULT is not given, then the result replaces
;  TRANSFORM-2.  If both TRANSFORM-2 and RESULT are nil, then a new
;  transform is created to hold the result.  A nil transform represents the
;  identity transform.  The new value of RESULT is returned.

(defun compose-transform (transform-1 transform-2
                          &optional (result transform-2))
  (declare (type (or null transform) transform-1 transform-2 result))


  (cond ((null transform-1)				; T-1 is the identity
         (copy-transform transform-2 result))		;   Just use T-2
        ((null transform-2)				; T-2 is the identity
         (copy-transform transform-1 result))		;   Just use T-1
        ((eq transform-2 result)			; T2 and RESULT are the same
         (with-slots (t11 t12 t21 t22 t31 t32) transform-2
           (post-mult transform-1 t11 t12 t21 t22 t31 t32 *temp-transform*)
           (copy-transform *temp-transform* result)))	;   Use temporary result
        (t						; Otherwise, compose them
         (with-slots (t11 t12 t21 t22 t31 t32) transform-2
           (post-mult transform-1 t11 t12 t21 t22 t31 t32 result)))))


;Function: copy-transform
;  Copy transform-1 into transform-2.  Either or both can be nil.  Return the new
;  transform-2.

(defun copy-transform (transform-1 transform-2)
  (declare (type (or null transform) transform-1 transform-2))


  (cond ((eq transform-1 transform-2))			; They are already identical!
        (transform-1					; T-1 is not identity
         (unless transform-2
           (setf transform-2 (make-transform)))		;   Must make T-2 first
         (with-slots (t11 t12 t21 t22 t31 t32) transform-1
           (with-slots ((y11 t11) (y12 t12) (y21 t21) (y22 t22) (y31 t31) (y32 t32)) transform-2
             (psetf y11 t11 y12 t12 y21 t21 y22 t22 y31 t31 y32 t32))))
        (t						; T-1 is the identity
         (if transform-2
             (with-slots (t11 t12 t21 t22 t31 t32) transform-2	; Make T-2 the identity
               (psetf t11 1.0 t12 0.0 t21 0.0 t22 1.0 t31 0.0 t32 0.0))
             (setf transform-2 (make-transform)))))		; Or create one if not there yet

  transform-2)					; Return T-2


(defmethod move-transform ((transform transform) delta-x delta-y)


  (with-slots (t31 t32) transform			; Just translate the transform
    (psetq t31 (+ t31 delta-x)
           t32 (+ t32 delta-y)))
  transform)						; Return the modified transform


;Method: print-object
;   Print a transform object

(defmethod print-object :after ((transform transform) stream)

  (with-slots (t11 t12 t21 t22 t31 t32) transform
    (format stream "[|~6,2f  ~6,2f  ~6,2f||~6,2f  ~6,2f  ~6,2f||~6,2f  ~6,2f  ~6,2f|]"
            t11 t12 0.0 t21 t22 0.0 t31 t32 1.0)))


;Macro: radians
;  Convert degrees to radians using the same floating point precision

(defmacro radians (degrees)

 `(* ,degrees (/ pi  180)))


;Method: rotate-transform
;  Modify the TRANSFORM, rotating the previous transformation by the given ANGLE
;  (in radians) around the given fixed point. The new value of the TRANSFORM is
;  returned.

(defmethod rotate-transform ((transform transform) angle
                               &optional (fixed-x 0) (fixed-y 0))


  (let* ((cos-angle (cos angle))			; Implementation note:
         (sin-angle (sin angle))			;  (cis angle) is NOT faster on Explorer!
         (origin-fixed (and (zerop fixed-x) (zerop fixed-y)))
         (trans-x (if origin-fixed				; Translate only if fixed-point is not origin
                      0.0
                      (+ (* fixed-x (- 1 cos-angle)) (* fixed-y sin-angle))))
         (trans-y (if origin-fixed
                      0.0
                      (- (* fixed-y (- 1 cos-angle)) (* fixed-x sin-angle)))))

    (post-mult transform					; Translate to origin, rotate, translate back
               cos-angle	sin-angle
               (- sin-angle) 	cos-angle
               trans-x	trans-y)))


;Method: scale-transform
;  Modify the TRANSFORM, scaling the previous transformation by the given scale
;  factors around the given fixed point. The new value of the TRANSFORM is
;  returned.

(defmethod scale-transform ((transform transform) scale-x scale-y
                  &optional (fixed-x 0) (fixed-y 0))


  (let* ((origin-fixed (and (zerop fixed-x) (zerop fixed-y)))	; Translate only if fixed point is not origin
         (trans-x (if origin-fixed
                      0.0
                      (* fixed-x (- 1 scale-x))))
         (trans-y (if origin-fixed
                      0.0
                      (* fixed-y (- 1 scale-y))))
	 )
	 (post-mult transform					; Translate to origin, scale, translate back
               scale-x	0.0
               0.0	scale-y
               trans-x	trans-y)))


;Function: scale-point
;  Return the result of applying TRANSFORM to the given X-DISTANCE and Y-DISTANCE.

(defun scale-point (transform x-distance y-distance)
  (declare (type (or null transform) transform))
  (declare (type wcoord x-distance y-distance))


  (if transform							; Identity?
      (with-slots (t11 t12 t21 t22) transform				;  No,
        (let ((x-scale (sqrt (+ (* t11 t11) (* t12 t12))))		; Compute scale factors
              (y-scale (sqrt (+ (* t21 t21) (* t22 t22)))))
          (values (* x-distance x-scale)				; new-x-distance
                  (* y-distance y-scale))))				; new-y-distance
      (values x-distance y-distance)))				;  Yes, old-x, old-y



;Function: transform-point
;  Return the result of applying TRANSFORM to the given point.

(DEFMETHOD  transform-point ((transform transform) x y)
  (declare (type (or null transform) transform))
  (declare (type wcoord x y))

  (with-slots (t11 t12 t21 t22 t31 t32) transform	;  No,
    (values (+ (* x t11) (* y t21) t31)		; new-x
	    (+ (* x t12) (* y t22) t32)))	; new-y
  )						;  Yes, old-x, old-y

(DEFMETHOD  transform-point (( transform t) x y)
  ;; (declare (type (or null transform) transform))
  ;; (declare (type wcoord x y))
  ;; new-y
  (values x y))

;; Function: transform-point-seq
;; Destructively changes the point-seq by applying TRANSFORM to the
;; given points.
(defun transform-point-seq (transform  point-vector &optional (result point-vector))
  (declare (type (or null transform) transform))
  (declare (type (or null vector) point-vector ))
  (with-vector transformed-vector
	       (LET* ((vector-length (LENGTH point-vector)))	; How many pairs are there?

		 (IF   transform		; Identity transform?
		   (with-slots (t11 t12 t21 t22 t31 t32) transform	; No, transform the points
		     (let ((x11 t11)		; Store transform in local vars for efficiency
			   (x12 t12)
			   (x21 t21)
			   (x22 t22)
			   (x31 t31)
			   (x32 t32))

		       (let (x-i y-i)		; Transform the vectors
			 (IF (AND (= x11 x22 1) (= x12 x21 0))
			     (do ((i 0 (+ i 2)))
				 ((>= i  vector-length) nil)
			       (setf x-i (ELT point-vector i)	; Save next point in temporaries
				     Y-i (ELT point-vector (+ 1 i)))
			       (vector-push-extend
				 (+  x-i x31)
				 transformed-vector)
			       (vector-push-extend
				 (+  y-i  x32)
				 transformed-vector)
			       )

			     (do ((i 0 (+ i 2)))
				 ((>= i  vector-length) nil)
			       (setf x-i (ELT point-vector i)	; Save next point in temporaries
				     Y-i (ELT point-vector (+ 1 i)))
			       (vector-push-extend
				 (+ (* x-i x11) (* y-i x21) x31)
				 transformed-vector)
			       (vector-push-extend
				 (+ (* x-i x12) (* y-i x22) x32)
				 transformed-vector)
			       )))
		       )
		     (copy-to-point-seq transformed-vector result))
		   (copy-to-point-seq point-vector result)))))

(DEFUN get-global-vector ()
  "return a reusable vector from the a global *vector-cache*. If the fillpointer for a vertor is 0, it is available"
  (DOLIST (VECTOR *vector-cache*  (PROGN (PUSH (cons (make-array '(10) :adjustable t :fill-pointer 0) 1) *vector-cache*)
					 (CAAR *vector-cache*)))
    (WHEN (= (cdr vector) 0)
       (SETF (CDR vector) 1)(RETURN (car vector)))))

(DEFUN return-global-vector (avector)
  (SETF (FILL-POINTER avector) 0)
  (SETF (CDR (ASSOC avector *vector-cache*)) 0))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Private Function: post-mult
;  Change the RESULT transform to be the product of (X x Y), where Y is
;  a homogeneous matrix defined by Y11, Y12, ...  If RESULT is nil, create a new
;  transform fo the result.  The new value of RESULT is returned.

(defun post-mult (x y11 y12 y21 y22 y31 y32
                          &optional (result x))
  (declare (type transform x))
  (declare (type (or null transform) result))


  (unless result			; Create a result transform if necessary
    (setf result (make-transform)))

  (with-slots ((x11 t11) (x12 t12) (x21 t21) (x22 t22) (x31 t31) (x32 t32)) X			; X x Y = Z
      (with-slots ((z11 t11) (z12 t12) (z21 t21) (z22 t22) (z31 t31) (z32 t32)) result

      (let ((temp11 x11)				; Use temporaries in case RESULT and X are the same
            (temp21 x21)
            (temp31 x31))

        (psetq z11 (+ (* temp11 y11) (* x12 y21))	; Compute first row
               z12 (+ (* temp11 y12) (* x12 y22))

               z21 (+ (* temp21 y11) (* x22 y21))	; Compute second row
               z22 (+ (* temp21 y12) (* x22 y22))

               z31 (+ (* temp31 y11) (* x32 y21) y31)	; Compute third row
               z32 (+ (* temp31 y12) (* x32 y22) y32)))))

  result)					; Return RESULT transform