;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-

;;; Reason: Changed :new-window, :pan, :set-scales, :after :set-transform & :zoom methods
;;; in w:graphics-mixin to use EQUALP instead of EQUAL which is never true for
;;; different arrays since EQUAL is really EQ for arrays.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 05/22/89 13:52:45 by MARKY,
;;; while running on LIBRA from band LODA
;;; With Experimental REL6H 6.18, SYSTEM 6.2, Experimental VIRTUAL-MEMORY 6.0, Experimental EH 6.0,
;;;  Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0, Experimental LOCAL-FILE 6.0,
;;;  Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0, Experimental BASIC-NAMESPACE 6.0,
;;;  Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0, Experimental DISK-LABEL 6.0,
;;;  Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0, Experimental NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.1, TV 6.3, Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0,
;;;  Experimental MEMORY-AUX 6.0, Experimental NVRAM 6.0, Experimental SYSLOG 6.0,
;;;  Experimental STREAMER-TAPE 6.0, Experimental CLEH 1.0, Experimental UCL 6.0,
;;;  Experimental INPUT-EDITOR 6.0, Experimental METER 6.0, Experimental ZWEI 6.0,
;;;  Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0, Experimental NETWORK-SERVICE 6.0,
;;;  DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0, Experimental SERIAL 6.0,
;;;  Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0, Experimental PRINTER-TYPES 6.0,
;;;  Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0, MAIL-DAEMON 6.2, Experimental MAIL-READER 6.0,
;;;  Experimental TELNET 6.0, Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0,
;;;  PROFILE 6.1, VISIDOC 6.0, Experimental TI-CLOS 17.6, Experimental CLX 5.0, Experimental CLUE 20.0,
;;;  Experimental X11M 3.0, RPC 6.0, Experimental NFS 6.0, Experimental BUG 11.5,
;;;  IP 3.45, MMON 1.0,  microcode 419, Band Name: 6.0 sle 5/3 mmon


#!C
; From file TRANSFORM.LISP#> WINDOW; SYS:
#10R W#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; TRANSFORM.#"


(DEFMETHOD (transform-mixin :new-window) (x y dx dy)
  "This changes the tranform to fit a specified rectangular area  in the window.
The x and y scales are made equal to avoid weird stretching, so the rectangle is
expanded to a square. Nil is returned if the transform was not changed."
  (DECLARE (VALUES transform-changed?))
  (SETQ dx (COND ((= dx 0) 0.01)
		 (t	   (FLOAT (ABS dx)))))
  (SETQ dy (COND ((= dy 0) 0.01)
		 (t	   (FLOAT (ABS dy)))))
  (LET ((left		    (MIN x (+ x dx)))
	(top		    (MIN y (+ y dy)))
	(s		    (MIN (/ (sheet-inside-width)  dx)
				 (/ (sheet-inside-height) dy)))
	(transform-changed? nil))
    (UNLESS (= (AREF transform 0 0) (SETF (AREF transform 0 0) s))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 0 1) (SETF (AREF transform 0 1) 0))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 0 2) (SETF (AREF transform 0 2) 0))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 1 0) (SETF (AREF transform 1 0) 0))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 1 1) (SETF (AREF transform 1 1) s))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 1 2) (SETF (AREF transform 1 2) 0))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 2 0) (SETF (AREF transform 2 0) (- (* left s))))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 2 1) (SETF (AREF transform 2 1) (- (* top s))))
      (SETQ transform-changed? t))
    (UNLESS (= (AREF transform 2 2) (SETF (AREF transform 2 2) 1))
      (SETQ transform-changed? t))
    (SETQ identity? (EQUALp transform identity-array))	;; may 05/22/89 was EQUAL
    transform-changed?))


(DEFMETHOD (transform-mixin :pan) (dx dy)
  "This changes the transform by translating both horizontally and vertically."
  (INCF (AREF transform 2 0) dx)
  (INCF (AREF transform 2 1) dy)
  (SETQ identity? (EQUALp transform identity-array))) 	;; may 05/22/89 was EQUAL


(DEFMETHOD (transform-mixin :set-scales) (x-scale &optional (y-scale x-scale))
  "This sets the scale values in the transformation for the cache window.
It also makes sure that any global data that is derived from the transform is
updated."
  (SETF (AREF transform 0 0) x-scale)
  (SETF (AREF transform 1 1) y-scale)
  (SETQ identity? (EQUALp transform identity-array)))	;; may 05/22/89 was EQUAL

(DEFMETHOD (transform-mixin :after :set-transform) (IGNORE)
  "This updates the identity transform flag after a new transform has been set."
  (SETQ identity? (EQUALp transform identity-array)))	;; may 05/22/89 was EQUAL

(DEFMETHOD (transform-mixin :zoom) (sx sy)
  "This changes the transform by scaling both horizontally and vertically.
The center of the window is kept the same world location."
  (UNLESS (AND (= sx 1) (= sy 1))
    (scalef (AREF transform 0 0) sx)
    (scalef (AREF transform 1 1) sy)
    (scalef (AREF transform 2 0) sx)
    (INCF (AREF transform 2 0)
	  (* 0.5 (- 1 sx) (- (sheet-inside-right) (sheet-inside-left))))
    (scalef (AREF transform 2 1) sy)
    (INCF (AREF transform 2 1)
	  (* 0.5 (- 1 sy) (- (sheet-inside-bottom) (sheet-inside-top))))
    (SETQ identity? (EQUALp transform identity-array))))	;; may 05/22/89 was EQUAL


))
;; may 05/22/89
;; This is necessary to make the changes take effect
;; but is NOT done since this patch will be disk saved in band
;; and the windows disk-saved will ONLY be scaled to 1:1.
;(dolist (s tv:all-the-screens)
;  (unless (typep s 'tv:who-line-screen) 
;    (dolist (w (send s :inferiors))
;      (when (and (typep w 'w:graphics-mixin)
;		 (not (send w :identity?)))
;	(multiple-value-bind (dx dy)
;	    (send w :get-scaling-factors)
;	  (when (equalp w:identity-array (send w :transform))
;	    (format t "~% Correcting :identity? in ~s" w)
;	    (send w :set-scales dx dy)))))))