;;; -*- Mode:Common-Lisp; Package:TV; Fonts:(TVFONT TR10 HL10 TR10I TR10B); Base:10 -*-
;;; *-* Last-edit: 04/03/91 00:27:32 by BONNET; *-* 


;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.  Where functionality implemented herein replicates
;;; similarly named functionality on Symbolics machines, this code was
;;; developed solely from the interface specification in the documentation
;;; or through guesswork, never by examination of Symbolics source code.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.
;;; **********************************************************************

;1;; The flavor defiinitons for basic-x-y-scrolling-window and associated flavors.*

#|
2Overview..

This flavor defines a vertically and horizotally scrolling mouse-sensitive window.  The 1logical *window is unlimited in size,
has possible negative coordinates,  starts off the same size as the 1physical *(inside of the visible) window, and expands
as required.  *"2Things*"2 (1items*) that you see on the window are instances of flavors such as scrollable-text-item
and scrollable-line-item.  As much as possible is compatible with flavor basic-mouse-sensitive-items.

The overview-mixin handles Mouse-m-*22 (same as Sh-c-mouse-m) clicks, and displays
an overview of the entire logical-window, with the physical window shown as a rectangle,
which can be moved with the mouse.


Interesting initable instance variables.

 from x-y-scroll-bars-mixin
   :scroll-bar-thickness - # of pixels, the default is 3
   :use-both-scroll-bars-p - if NON-NIL then both scroll bars will be drawn when the user invokes scrolling. Default is t.
   :hor-scroll-bar-always-displayed-p - if NON-NIL the hor-scroll-bar is continuously displayed.
   :ver-scroll-bar-always-displayed-p - ditto. Default for both is nil.

 from mouse-sensitivity
   :item-type-alist - as in basic-mouse-sensitive-items
   :mouse-sensitive-types - a list of types or the keyword :all. Default is :all.

 from x-y-scrolling-mixin
   :scrolling-speed - an positive interger which is how much the screen bitblt's by, when scrolling. Default is *32.
2                        Set to 1000 or more for ZMACS style *"2whoosh, where am I?*"2 scrolling.

 from ver-auto-scrolling-mixin
   :increment - how much to pop up by, when the cursor reaches the bottom of the screen.  Can be a pixel number
                or one of the keywords :whole :half :quarter.  The default is :half.

Methods.

    x-y-scrolling-window supports the following user-level methods.


  * :scrollable-text-item item (&key x y coordinate-type mouse-sensitive-type pre-print-item-modify-function2 *font)
2 *  2    When you want to display a scrollable item whose printed representation*
  2     is a piece of text, use this method.
       This makes an instance of scrollable-text-item, and tells the window about the new instance. It returns the
       instance, to which the user can later send a variety of messages.*
     item : item can be any lisp obje2c*t. If it is not a string then you must supply
            a pre-print-item-modify-function which takes one arg, 2item*, and returns a string.
     x    : the x position of the upper left edge of the item. If x is in physical coordinates
            (ie. relative to the inside of the window) then coordinate type should be set to
            :physical. If x is in logical coordinates then coordinate-type
            must be set to :logical2 (which is the default)*.  The default for x is the cursor position.
     y    : see x above.
     coordinate-type   : one of :physical :logical.  :2logical* is the default.
     mouse-sensitive-type   : same as type in basic-mouse-senstive-items. See the methods :set-mouse-sentitive-types
                              and :set-item-type-alist. The defualt is nil, meaning 2not * mouse sensitive.
     pre-print-item-modify-function   : a function that takes one arg, the item, and returns a string for 
                                        printing.  The default is #`identity.
     font  : The default is the current font of the window.


  :scrollable-line-item from-x from-y to-x to-y &key mouse-senstitive-type coordinate-type
2     When you want to display a scrollable item whose printed representation is a line,
     then use this method.
     It makes an instance of scrollable-line-item, tells the window about the new item instance,
     and returns the instance.*
    For a explanation of the args see scrollable-text-item above.


  :set-item-type-alist (new-alist)
     new-alist  :  an alist of the form for basic-mouse-senstitive-items.

  :set-mouse-sensitive-types (types)
     types   :  can be a subset of the types in item-type-alist or the keyword :all
                meaning all the types in the alist.  The default is :all.

2  The flavors scrollable-text-item and scrollable-line-item support the following user-level methods.*

   :delete-self
2       The instance will erase itself, and remove itself from the window's item-list.*
   :move-to args
2     The args depend on what type of instance.*
   :center-window-on-yourself
    No args.
  for 2scrollable-text-item *only
   :blink (how-fast-in-60ths)
   :dont-blink
      
Program internals

There are 4 different coordinate systems used here:
1) The screen coordinates ie. 2750 by 1024 roughly.*
   Some things in the mouse handler are in this system.

2) The outside window coordinates, which are relative to the outside left and top
   edges of the window.  cursor-x and cursor-y are in this system.  Note however
   that the args to the :set-cursorpos method are inside coordinates (#3).

3) The inside window coordinates, which are relative to the inside edges.
   The inside edges are determined by adding the margin width to the border margin
   width plus maybe the label for the bottom edge. the functions sheet-inside-left,
   sheet-inside-bottom, etc, find the inside edges.  Most higher-level text and graphic
   functions use these coordinates. (eg. :draw-line :set-cursorpos)

4) Logical coordinates, which are boundless and possibly negative.
   They look like this:          -
                                 !
                                 !
                                 !
                      -  ----------------- +
                                 !
                                 !
                                 !
                                 +
  The instance vars x-pl-offset y-pl-offset relate the 2inside* coordinate system of
  the window (which I call the physical system) to the logical system. Specifically
  physical + ?-pl-offset = logical.

|#
;;;------------------------------- 1basic-*x-y-scrolling-window -----------------------------

(defvar *mx-scroll-bar-tollerance* 10)

;;; no methods or instance vars for th1ese two flavors.

;;;Edited by h                     24 Sep 87  18:15*
(defflavor basic-x-y-scrolling-window ()
	   (basic-x-y-scrolling-mixin
	    overview-mixin
	    mouse-sensitivity-for-instances-mixin
	    ver-auto-scrolling-mixin
	    basic-mouse-sensitive-items-compatibility-mixin
	    fancy-drag-scrolling-mixin 
	    borders-mixin
	    label-mixin
	    graphics-mixin
	    stream-mixin
	    minimum-window
	    ))
  
  
1;;;Edited by h                     24 Sep 87  18:15*
(defflavor basic-x-y-scrolling-mixin ()
	   (essential-x-y-scrolling-mixin
	    some-window-extensions
	    x-y-scroll-bars-mixin))


;;;------------1-essential-x-y-scrolling-mixin -*--------------------------------------------------------

(defvar default-scrolling-speed (if (mx-p) 64 32) "governs how fast the screen scrolls by.  Set to 1000 for
                                        ZMACS style --whoosh, where am I?-- scrolling")

(defvar *default-x-y-scroll-bar-enabledness* t
"The default value used to determine whether x-y scroll windows will
 have the scroll bars switched on or not.
"
)

(defflavor essential-x-y-scrolling-mixin ((x-pl-offset 0)	;1pl* is physical to logical
						;it is the conversion between the two coordinate systems.
				                ;Can be negative.
				(y-pl-offset 0)
				(item-list nil)
				(logical-left-edge 0)
				(logical-right-edge 0)	 ;setq'd in :after :init
				(logical-top-edge 0)
				(logical-bottom-edge 0)	 ;setq'd in :after :init
				(scrolling-speed default-scrolling-speed)
				(scroll-bars-enabled-p *default-x-y-scroll-bar-enabledness*)
				)
	   ()
  (:settable-instance-variables
    item-list
    scrolling-speed
    logical-left-edge
    logical-right-edge
    logical-top-edge
    logical-bottom-edge
    scroll-bars-enabled-p)
  (:initable-instance-variables scrolling-speed scroll-bars-enabled-p)
  :Gettable-Instance-Variables
  (:Settable-Instance-Variables scroll-bars-enabled-p)
  (:default-init-plist :save-bits t
                       :blinker-p nil
		       :deexposed-typeout-action :permit
		       :more-p nil)
  (:required-flavors minimum-window)
  (:required-methods :invoke-hor-scrolling
		     :invoke-ver-scrolling
		     :invoke-hor-scrolling-mouse-handler
		     :invoke-ver-scrolling-mouse-handler)
  (:required-instance-variables hor-scrolling-in-effect
				ver-scrolling-in-effect))

(defmethod (essential-x-y-scrolling-mixin :after :init) (&rest ignore)
  (setq logical-bottom-edge (send self :inside-height))
  (setq logical-right-edge (send self :inside-width)))

(defwhopper (essential-x-y-scrolling-mixin :scroll-to) (&rest args)
;  (with-window-ops-on-bit-array (self) (lexpr-continue-whopper args))
  (lexpr-continue-whopper args)
)

(defwhopper (essential-x-y-scrolling-mixin :draw-graph) (&rest args)
;  (with-window-ops-on-bit-array (self) (lexpr-continue-whopper args))
  (lexpr-continue-whopper args)
)

(defwhopper (essential-x-y-scrolling-mixin :change-of-size-or-margins) (&rest args)
;  (with-window-ops-on-bit-array (self) (lexpr-continue-whopper args))
  (lexpr-continue-whopper args)
)

(defwhopper (essential-x-y-scrolling-mixin :set-edges) (&rest args)
;  (without-window-ops-on-bit-array (self) (lexpr-continue-whopper args))
  (lexpr-continue-whopper args)
)

(1defmethod* (essential-x-y-scrolling-mixin :edge-following-blinker) ()
  (1or* (1find-if* #'(lambda (x) (1typep* x 'following-arrow-blinker)) blinker-list)
      (4make-following-arrow-blinker* self 0 0 10 10 3 15)
  )
)

(defmethod (essential-x-y-scrolling-mixin :after :change-of-size-or-margins) (&rest ignore)
  "recalculate logical edges"
  (setq logical-bottom-edge (send self :inside-height)
        logical-right-edge (send self :inside-width)
	logical-top-edge 0
	logical-left-edge 0
	x-pl-offset 0
	y-pl-offset 0)
  (cond ((or (send self :exposed-p)
	     (and (eql (send self :deexposed-typeout-action) :permit)
		  (send self :active-p)))
	 (let ((temp item-list))
	   (send self :clear-window)
	   (setq item-list temp))
	 (dolist (item item-list)
	   (send self :expand-logical-window-maybe item))
	 (dolist (item item-list)
	   (send item :maybe-draw-self)))
	(t (dolist (item item-list)  ;else better not try to draw anything.
	     (send self :expand-logical-window-maybe item)))))

(defmethod (essential-x-y-scrolling-mixin :after :refresh) (&rest args)
  (if (and args (equal (first args) :use-old-bits))
      nil
      (dolist (item item-list)
	(send item :refreshed)
	(send item :maybe-draw-self))))

(defmethod (essential-x-y-scrolling-mixin :logical-height) ()
  (- logical-bottom-edge logical-top-edge))

(defmethod (essential-x-y-scrolling-mixin :logical-width) ()
  (- logical-right-edge logical-left-edge))

(defmethod (essential-x-y-scrolling-mixin :re-initialize) ()
  (setq item-list nil
	x-pl-offset 0
	y-pl-offset 0
	logical-left-edge 0
	logical-top-edge 0
	logical-right-edge
	  (if (equal :recompute logical-right-edge)
	      0
	      (send self :inside-width))
	logical-bottom-edge
	  (if (equal :recompute logical-bottom-edge)
	      0
	      (send self :inside-height))))


(defun remove-keys (keys from-list)
  (if keys
      (let ((index (position (first keys) from-list)))
	   (if index
	       (remove-keys
		 (rest keys)
		 (append (firstn index from-list)
			 (nthcdr (+ 2 index) from-list)
		 )
	       )
	       (remove-keys (rest keys) from-list)
	   )
      )
      from-list
  )
)

(defmethod (essential-x-y-scrolling-mixin :scrollable-item)
	   (item flavor &rest args)
 (let ((mouse-sensitive-type (or (getf args :Mouse-Sensitive-Type) nil))
       ;; the defaults below are in pixels
       ;; relative to the inside coordinate system
       (x (or (getf args :X) (- cursor-x (sheet-inside-left self))))
       (y (or (getf args :Y) (- cursor-y (sheet-inside-top self))))
       (coordinate-type (or (getf args :Coordinate-Type) :logical))
       (keys
	 (remove-keys '(:mouse-sensitive-type :X :Y :Coordinate-Type) args)
       )
      )
      (let ((logical-x (if (eql coordinate-type :physical) (+ x x-pl-offset) x))
	    (logical-y (if (eql coordinate-type :physical) (+ y y-pl-offset) y))
	   )
	   (let ((inits (getf (sys:flavor-plist (get flavor 'sys:flavor))
			      'sys:all-inittable-instance-variables
			)
		 )
		)
		(let ((item (apply 'make-instance flavor
				   :item item
				   :window self
				   :mouse-sensitive-type mouse-sensitive-type
				   (append (if (member :Logical-X inits)
					       (list :logical-x logical-x
						     :logical-y logical-y
					       )
					       nil
					   )
					   keys
				   )
			    )
		      )
		     )
		     (send item :maybe-draw-self)
		     ;; put item on list
		     (push item item-list)    
		     (send self :expand-logical-window-maybe item)
		     ;; this will do the boxing if appropriate
		     (send self :mouse-moves mouse-x mouse-y)
		     item
		)
	   )
      )
 )
)

(defmethod (essential-x-y-scrolling-mixin :scrollable-text-item)
	   (item &key
	    (mouse-sensitive-type nil)
	    ;; the defaults below are in pixels
	    ;; relative to the inside coordinate system
	    (x (- cursor-x (sheet-inside-left self)))
	    (y (- cursor-y (sheet-inside-top self)))
	    (coordinate-type :logical)
	    (font nil)
	    (pre-print-item-modify-function #'identity)
	    )
  (let ((item (make-instance 'scrollable-text-item
			     :item item
			     :mouse-sensitive-type mouse-sensitive-type
			     :font font
			     :logical-x (if (eql coordinate-type :physical)
					    (+ x x-pl-offset)
					    x)
			     :logical-y (if (eql coordinate-type :physical)
					    (+ y y-pl-offset)
					    y)
			     :window self
			     :pre-print-item-modify-function pre-print-item-modify-function)))
    (send item :maybe-draw-self)
    ;; put item on list
    (push item item-list)    
    (send self :expand-logical-window-maybe item)
    ;; this will do the boxing if appropriate
    (send self :mouse-moves mouse-x mouse-y)
    item))


(defmethod (essential-x-y-scrolling-mixin :scrollable-graphics-item)
	   (item &key
	    (mouse-sensitive-type nil)
	    ;; the defaults below are in pixels
	    ;; relative to the inside coordinate system
	    (x (- cursor-x (sheet-inside-left self)))
	    (y (- cursor-y (sheet-inside-top self)))
	    (coordinate-type :logical)
	    (bitmap-function 'bitmap-spec-from-bitmap)
	    )
  (let ((item (make-instance 'scrollable-graphics-item
			     :item item
			     :mouse-sensitive-type mouse-sensitive-type
			     :logical-x (if (eql coordinate-type :physical)
					    (+ x x-pl-offset)
					    x)
			     :logical-y (if (eql coordinate-type :physical)
					    (+ y y-pl-offset)
					    y)
			     :window self
			     :bitmap-function bitmap-function)))
    (send item :maybe-draw-self)
    ;; put item on list
    (push item item-list)    
    (send self :expand-logical-window-maybe item)
    ;; this will do the boxing if appropriate
    (send self :mouse-moves mouse-x mouse-y)
    item))  ;1return this*

(defmethod (essential-x-y-scrolling-mixin :scrollable-line-item) (from-x from-y to-x to-y)
  "2all coordinates are in logical coordinates*"
  (let ((item (make-instance 'scrollable-line-item
			     :from-x from-x
			     :from-y from-y
                             :to-x to-x
			     :to-y to-y
                             :window self)))
    (send item :maybe-draw-self)
    (push item item-list)
    (send self :expand-logical-window-maybe item)
    (send self :mouse-moves mouse-x mouse-y)
    item))  ;1return this*


(defmethod (essential-x-y-scrolling-mixin :expand-logical-window-maybe) (item)
  (1if* (1or* (1equal* :Recompute logical-right-edge)
	 (1equal* :Recompute logical-bottom-edge)
     )
     (1send* self :Re-Initialize)
     nil)
  (if (or (< (send item :left-edge) logical-left-edge)
	  (> (send item :right-edge) logical-right-edge)
	  (< (send item :top-edge) logical-top-edge)
	  (> (send item :bottom-edge) logical-bottom-edge))
      (send self :expand-logical-window item)))

(defmethod (essential-x-y-scrolling-mixin :expand-logical-window) (item)
  (setq  logical-left-edge (min (send item :left-edge) logical-left-edge))
  (setq  logical-right-edge (max (send item :right-edge) logical-right-edge))
  (setq  logical-top-edge (min (send item :top-edge) logical-top-edge))
  (setq  logical-bottom-edge (max  (send item :bottom-edge) logical-bottom-edge)))

(defmethod (essential-x-y-scrolling-mixin :after :expand-logical-window) (ignore)
  (send self :update-scroll-bars))



(defun scrolling-bitblt (window dx dy speed)
  "2special effects.
    *bitblts the inside of WINDOW 2by dx and dy*
   in increments of SPEED.
   If 2dx or dy* is positive the text moves right or down
   The uncovered space is erased."
  (assert (plusp speed) (speed) "speed cannot be negative")
  ;; if how-much is so big that we're going to scroll out into space then just
  ;; clear the window.
  (cond ((or (> (abs dx) (send window :inside-width))
	     (> (abs dy) (send window :inside-height)))
	 (sheet-clear window))			;we use sheet-clear insead of :clear-window cause it is closer
						;to bitblting, and :clear-window might have some undesirable
						; :after methods.
	(t (let* ((num-of-increments (/ (sqrt (+ (* dx dx) (* dy dy))) speed))
		  (x-increment (truncate dx num-of-increments))
		  (y-increment (truncate dy num-of-increments)))
	     (do  ((how-much-x-left-to-do dx (- how-much-x-left-to-do x-increment))
		   (how-much-y-left-to-do dy (- how-much-y-left-to-do y-increment))
		   (how-much-x-done 0 (+ how-much-x-done x-increment))
		   (how-much-y-done 0 (+ how-much-y-done y-increment)))
		  ((and (zerop how-much-x-left-to-do)(zerop how-much-y-left-to-do)))
	       
	       ;; if there's not much left, do it all in one shot.
	       (if (or (< (abs how-much-x-left-to-do) (abs (* 2 x-increment)))
		       (< (abs how-much-y-left-to-do) (abs (* 2 y-increment))))
		   (setq x-increment how-much-x-left-to-do
			 y-increment how-much-y-left-to-do))
	       (bitblt-whole-sheet window x-increment y-increment))))))

(defun bitblt-whole-sheet (sheet dx dy)
  "2bitblt sheet's inside sceen array by dx and dy, and wipe out the uncovered area*"
  (send sheet :bitblt-within-sheet alu-seta
	(if (plusp dx) -2000 2000) ;1;the 2000 will get truncated to window size*
	(if (plusp dy) -2000 2000) ;1;making the 2000 negative will change how the bitblt is done.*
	0 0 dx dy)
  ;; wipe out the uncovered area.
  (unless (zerop dx)
    (send sheet :draw-rectangle (abs dx) 2000
	  (if (plusp dx)	
	      0    ;;window going right, wipe our left edge.
	      (+ (send sheet :inside-width) dx)) ;;else window going left, wipe out right edge.
	  0
	  (sheet-erase-aluf sheet)))
  (unless (zerop dy)
    (send sheet :draw-rectangle 2000 (abs dy)
	  0
	  (if (plusp dy)	
	      0    ;;window going 1down*, wipe our 1top* edge.
	      (+ (send sheet :inside-height) dy))
	  (sheet-erase-aluf sheet))))
		   

(defmethod (essential-x-y-scrolling-mixin :scroll-relative) (x y  &optional (truncate-args-p t) (inhibit-bitblt-p nil))
    (send self :scroll-to (+ x-pl-offset x) (+ y-pl-offset y) truncate-args-p inhibit-bitblt-p))

(defmethod (essential-x-y-scrolling-mixin :scroll-to) (logical-x logical-y &optional (truncate-args-p t)
						       (inhibit-bitblt-p nil) (force-scrolling-p nil))
  (cond (truncate-args-p      ;; truncate args if necessary
	 (setq logical-x (max logical-x logical-left-edge))
	 (setq logical-x (min logical-x (- logical-right-edge (send self :inside-width))))
	 (setq logical-y (max logical-y logical-top-edge))
	 (setq logical-y (min logical-y (- logical-bottom-edge (send self :inside-height)))))
	(t ;;else expand the logical window
	 (setq logical-left-edge (min logical-left-edge logical-x))
	 (setq logical-right-edge (max logical-right-edge (+ logical-x (send self :inside-width))))
	 (setq logical-top-edge (min logical-top-edge logical-y))
	 (setq logical-bottom-edge (max logical-bottom-edge (+ logical-y (send self :inside-height))))))
  (cond ((and (1not* force-scrolling-p)
	      (= logical-x x-pl-offset)
	      (= logical-y y-pl-offset)))	;then do nothing
	(t (unless inhibit-bitblt-p
	     (scrolling-bitblt self (- x-pl-offset logical-x) (- y-pl-offset logical-y) scrolling-speed))
	   (send self :scroll-cursor (- x-pl-offset logical-x) (- y-pl-offset logical-y))
	   (setq x-pl-offset logical-x
		 y-pl-offset logical-y)
	   (dolist (item item-list)
	     (send item :maybe-draw-self)))))

(defmethod (essential-x-y-scrolling-mixin :scroll-to-literally)
	   (logical-x logical-y)
  (send self :scroll-cursor (- x-pl-offset logical-x) (- y-pl-offset logical-y))
  (setq x-pl-offset logical-x
	y-pl-offset logical-y)
  (dolist (item item-list)
    (send item :maybe-draw-self)))

(defmethod (essential-x-y-scrolling-mixin :scroll-cursor) (dx dy)
  (send self :set-cursorpos
	(+ dx (- cursor-x (sheet-inside-left self)))
	(+ dy (- cursor-y (sheet-inside-top self)))))

(defmethod (essential-x-y-scrolling-mixin :after :scroll-to) (&rest ignore)
  (send self :update-scroll-bars))
(defmethod (essential-x-y-scrolling-mixin :handle-mouse) ()
  (x-y-scrolling-mouse-handler self))

1;;;Edited by HASTINGS              13 Jun 87  2:21
;;;Edited by Reed Hastings         30 Sep 87  10:44*
(defun x-y-scrolling-mouse-handler (window 				    
				    &AUX
				    (WINDOW-X-OFFSET 0) (WINDOW-Y-OFFSET 0)
				    WINDOW-X WINDOW-Y)
  "Handles the mouse if neither scroll bar is exposed."
  ;; this code pilfered from mouse-default-handler.
  (unless (SYMBOLP WINDOW)
    (MULTIPLE-VALUE-SETQ (WINDOW-X-OFFSET WINDOW-Y-OFFSET)
      (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET)))
  
  ;; Be careful not to do the :update method when the who line documentation window
  ;; isn't there (which is the case during a window system build).
  (WHEN (AND (BOUNDP 'WHO-LINE-DOCUMENTATION-WINDOW) WHO-LINE-DOCUMENTATION-WINDOW)
    ;; Update who-line when entering new handlers.
    (send who-line-documentation-window :update))
  
  (DO ((DX) (DY) (BU) (BD) (X) (Y)
       (OLD-OWNER WINDOW-OWNING-MOUSE WINDOW-OWNING-MOUSE)
       (LEFT-OFFSET 0)
       (right-offset 0)
       (bottom-offset 0)
       (top-offset 0)
       (WAIT-FLAG NIL T)
       ;; 10 is really too fast if you have a hor scroll bar also.
       ;; If they haven't rebound this to their favorite value, do so.
       (SCROLL-BAR-MAX-SPEED (if (= SCROLL-BAR-MAX-SPEED 10) 3
				 (= SCROLL-BAR-MAX-SPEED 10))))
      (MOUSE-RECONSIDER)
    ;; Wait until the mouse moves
    (MULTIPLE-VALUE-SETQ (DX DY BD BU X Y) (MOUSE-INPUT WAIT-FLAG))
    ;; If asked to reconsider, do so immediately.
    ;; Don't bother updating blinker since it is likely to change soon, and
    ;; in any case we are going to be called back shortly.
    (when MOUSE-RECONSIDER (RETURN NIL))
    ;; Update console-idle time when buttons pushed
    (unless (ZEROP BD) (SETQ KBD-LAST-ACTIVITY-TIME (TIME)))
    ;; Approximate speed of the mouse in inches per second
    (SETQ MOUSE-SPEED (/ (ISQRT (+ (* MOUSE-X-SPEED MOUSE-X-SPEED)
                                   (* MOUSE-Y-SPEED MOUSE-Y-SPEED)))
                         100.0s0))
    ;; If the mouse is moving incredibly fast, flash up something to
    ;; help the user find it.  Thus if you can't find the mouse, you must whip it.
    (when (> MOUSE-SPEED MOUSE-FAST-MOTION-SPEED)
      (if mouse-fast-track-bitmap-mouse-p
	  (draw-bitmap-mouse-cursor mouse-speed)
	  ;;1ELSE*
	  (draw-mouse-fast-motion-cursor)))
    
    (SETQ WINDOW-X (- X WINDOW-X-OFFSET)	; X offset of mouse within window
          WINDOW-Y (- Y WINDOW-Y-OFFSET))	; Y offset of mouse within window
    ;; Consider entering the scroll bar.  [Perhaps this should be changed so that
    ;; it is in the move-handler rather than here.  Problem with that is LEFT-OFFSET.]
    ;; If there is a scroll bar and we are entering it, activate it.
    ;; However, the mouse must move at least a certain distance past the edge
    ;; of the window in order to qualify for scrolling (this is set by
    ;; the SCROLL-BAR-RELUCTANCE variable in the window).  Before entering
    ;; scroll bar, send a :MOUSE-MOVES message in order to let the window know
    ;; what's happening.

    ;; LEFT-OFFSET is how far out the left side of the window the mouse has moved,
    ;; or 0 if the mouse is inside the window.
    ;; If the window is at the left edge of the screen, MOUSE-X will not itself
    ;; move out the left edge of the window, but DX will.  When the mouse reaches
    ;; the left edge of the window, accumulate leftward motion into LEFT-OFFSET.  
    ;; RIGHT-OFFSET does the same thing for when the scroll-bar is on the right.
    (COND ((1and* (<= WINDOW-X 0)
		(typep window 'sheet)
		(1or* (1not* (send window :scroll-bar-positions))
		    (1member* :Left (send window :scroll-bar-positions))))
	   (SETQ LEFT-OFFSET  (IF (PLUSP LEFT-OFFSET)
				  (MAX (- LEFT-OFFSET DX) 1)
				  (- dx))))
	  ((and (typep window 'sheet)
		(>= window-x (sheet-width window))
		(1member* :Right (send window :scroll-bar-positions)))
	   (setq right-offset (if (plusp right-offset)
				  (max (+ right-offset dx) 1)
				  dx)))
	  (t (SETQ LEFT-OFFSET 0
		   right-offset 0)))
    ;;do the same for bottom-offset
    (cond ((1and* (<= (sheet-height window) window-y)
		(typep window 'sheet)
		(1or* (1not* (send window :scroll-bar-positions))
		    (1member* :Bottom (send window :scroll-bar-positions))))
	   (setq bottom-offset (if (plusp bottom-offset) 
				   (max (+ bottom-offset dy) 1)
				   dy)))
	  (t (setq bottom-offset 0)))
    ;;do the same for top-offset
    (cond ((1and* (<= window-y 0)
		(typep window 'sheet)
		(1or* (1not* (send window :scroll-bar-positions))
		    (1member* :Top (send window :scroll-bar-positions))))
	   (setq top-offset (if (plusp top-offset) 
				   (max (+ top-offset dy) 1)
				   (1-* dy))))
	  (t (setq top-offset 0)))
    (COND ((or old-owner window-owning-mouse (send self :dragging-screen-p)))	; These disable scroll-bar.
	  ((AND SCROLL-BAR-MAX-SPEED		;Too fast, pass right through
		(> MOUSE-SPEED SCROLL-BAR-MAX-SPEED)))
	  ((PLUSP left-OFFSET)
	   (COND ((and (1send* window :scroll-bars-enabled-p)
		       (> left-OFFSET SCROLL-BAR-RELUCTANCE)
		       (or (not (mx-p)) (< left-offset *mx-scroll-bar-tollerance*)))
		  (send window :mouse-moves window-x window-y)
		  (return (send window :Invoke-Ver-Scrolling :left)))
		 (t (setq window-x 0))))	;Don't escape the window yet
	  ((PLUSP right-OFFSET)
	   (COND ((and (1send* window :scroll-bars-enabled-p)
		       (> right-OFFSET SCROLL-BAR-RELUCTANCE)
		       (or (not (mx-p)) (< right-offset *mx-scroll-bar-tollerance*)))
		  (send window :mouse-moves window-x window-y)
		  (return (send window :Invoke-Ver-Scrolling :right)))
		 (t (setq window-x (sheet-width window)))))	;Don't escape the window yet
	  ((PLUSP bottom-offset)
	   (COND ((and (1send* window :scroll-bars-enabled-p)
		       (> bottom-offset SCROLL-BAR-RELUCTANCE))
		  (send window :mouse-moves window-x window-y)
		  (return (send window :Invoke-Hor-Scrolling :bottom)))
		 (t (setq window-y (sheet-height window)))))	;Don't escape the window yet
	  ((PLUSP top-offset)
	   (COND ((and (1send* window :scroll-bars-enabled-p)
		       (> top-offset SCROLL-BAR-RELUCTANCE))
		  (send window :mouse-moves window-x window-y)
		  (return (send window :Invoke-Hor-Scrolling :top)))
		 (t (setq window-y 0)))))	;Don't escape the window yet
    
    ;; Update the position of the mouse before checking for button clicks, so
    ;; that button clicks get processed with knowledge of where the mouse
    ;; was when the button was first clicked.  The arguments to the move handler
    ;; may be where the mouse was when the button was clicked, whereas the
    ;; mouse cursor follows MOUSE-X and MOUSE-Y, which may be different.   
    (SETQ MOUSE-WARP NIL)
    (SEND window  :mouse-moves WINDOW-X WINDOW-Y)
    ;; Check for all the ways of losing control of the mouse.
    (IF (COND ;; The move handler may have decided to warp the mouse so that it will not
	  ;; move out of the window.  This test is a crock but should work.
	  (MOUSE-WARP NIL)
	  ;; Check for mouse ceasing to be grabbed.
	  ((EQ WINDOW T)
	   (NEQ WINDOW-OWNING-MOUSE T))
	  ;; Check for window becoming grabbed.
	  ((EQ WINDOW-OWNING-MOUSE T)
	   (NEQ WINDOW T))
	  ;; Check for some other window (not above this one) being greedy.
	  (WINDOW-OWNING-MOUSE
	   (NOT (SHEET-ME-OR-MY-KID-P WINDOW WINDOW-OWNING-MOUSE)))
	  ;; Check for moving into a window when not in any
	  ((NULL WINDOW)
	   (WINDOW-OWNING-MOUSE X Y))
	  ;; Check for leaving the boundaries of the current window
	  ;; HYSTERETIC-WINDOW-MIXIN requires that we wait at least once before returning
	  ((NOT (AND (SHEET-EXPOSED-P WINDOW)
		     (>= WINDOW-X 0)
		     (<  WINDOW-X (SHEET-WIDTH WINDOW))
		     (>= WINDOW-Y 0)
		     (<  WINDOW-Y (SHEET-HEIGHT WINDOW))))
	   WAIT-FLAG)
	  ;; Check for moving into an inferior of the current window
	  ((NEQ (LOWEST-SHEET-UNDER-POINT WINDOW WINDOW-X WINDOW-Y
					  :HANDLE-MOUSE :EXPOSED)
		WINDOW)
	   T))
        ;; Return to overseer, saving any pending button click.
        (RETURN (MOUSE-DEFER-BUTTONS BU BD)))
    ;; Now process button pushes if mouse is not seized.
    (unless (OR (ZEROP BD)  OLD-OWNER)
      (FUNCALL WINDOW :mouse-buttons BD WINDOW-X WINDOW-Y))))


;1;;----------------- *fancy-drag-scrolling-mixin 1---------------------

;;;Edited by Reed Hastings         24 Sep 87  22:12*
(defflavor fancy-drag-scrolling-mixin (lx ly start-x start-y (dragging-screen-p)) () :gettable-instance-variables)

(defmethod (fancy-drag-scrolling-mixin :mouse-click) (b x y)
  "2fancy drag scrolling*"
  (when (and (= b #\mouse-m)
	     (not (send self :currently-boxed-item))
	     (= (mouse-buttons t) 2)) ;1;still holding middle*
    (setq lx x ly y start-x x start-y y dragging-screen-p t)))

(defmethod (fancy-drag-scrolling-mixin :after :mouse-moves) (x y)
  (when dragging-screen-p 
    (cond ((= (mouse-buttons t) 2)
	   (bitblt-whole-sheet self (- x lx) (- y ly))
	   (setq lx x ly y))
	  (t (setq dragging-screen-p nil)
	     (if (mx-p) ;;; This is a strange fix to compensate for the fact
		 ;;; that the µX seems to get strange values for x and y
		 ;;; for this method sometimes.  I don't know why, but
		 ;;; if you wait until both x and y are plusp, the answer
		 ;;; seems to be right.
		 (loop for for (dx dy bd bu lx ly)
		       = (multiple-value-list (mouse-input nil))
		       until (and (plusp lx) (plusp ly))
		       finally (setq x lx y ly))
		 nil)
	     (send self :scroll-relative (- start-x x) (- start-y y) nil t)))))

1;;;Edited by Reed Hastings         30 Sep 87  10:44*
(defmethod (fancy-drag-scrolling-mixin :after :handle-mouse) (&rest ignore)
  (when dragging-screen-p
    (setq dragging-screen-p nil)
    (send self :scroll-relative (- start-x lx) (- start-y ly) nil t)))

(defmethod (fancy-drag-scrolling-mixin :override :who-line-documentation-string) ()
  (unless (send self :currently-boxed-item)
    "R2: System Menu;  MH: Drag Scrolling"))

;-------------------------------------------------------------------------------

;1;;Edited by Yumi Iwasaki          3 Apr 91  0:27*
(defun find-item-with-mouse (sheet &optional (whostate "Select a vertex")
			     (mouse-sensitivity-enabled-p-function nil)
			    )
  (1let* ((old-selected 4selected-window*)
       (old-sensitivity
	 (1loop* for item in (1send* 4sheet* 3:Item-List*)
	       collect (1send* item 3:Mouse-Sensitivity-Enabled-P-Function*)
	 )
       )
      )
      (unwind-protect
        (letf-globally
	      (((symeval-in-instance sheet 'mouse-sensitive-types) '(:Vertex)))
	  (1loop* for item in (1send* 4sheet* 3:Item-List*)
	        when (1typep* item '4basic-vertex*)
		do (1send* item 3:Set-Mouse-Sensitivity-Enabled-P-Function*
			  mouse-sensitivity-enabled-p-function
		   )
	  )
	  (let ((the-process (loop for a-process in all-processes
				   when (and (typep a-process 'sys:process)
					     (equal (process-name a-process)
						    (send sheet :Name)
					     )
					)
				   return a-process
			     )
		)
		(old-selected selected-window)
	       )
	       (send sheet :clear-input)
	       (unwind-protect
		   (let ((*default-read-whostate* whostate))
			(if (not (equal old-selected sheet))
			    (send the-process :Arrest-Reason :find-item)
			    nil
			)
			(send sheet :mouse-select)
			(if old-selected
			    (send old-selected :mouse-select)
			    nil
			)
			(loop for blip = (send sheet :Any-Tyi)
			      for item
			       = (if (consp blip)
				     (case (first blip)
				       (:Mouse-Button
					  (send sheet
						:Currently-Boxed-Item
					  )
				       )
				       (:Typeout-Execute (fourth blip))
				       (otherwise nil)
				     )
				     nil
				 )
			      until item
			      finally (return item)
			)
		   )
		 (send sheet :clear-input)
		 (send the-process :Revoke-Arrest-Reason :Find-Item)
		 (1if* old-selected (send old-selected :Mouse-Select) nil)
	       )
	  )
	)
        (1loop* for item in (1send* 4sheet* 3:Item-List*)
	      for old in old-sensitivity
	      when (1typep* item '4basic-vertex*)
	      do (1send* item 3:Set-Mouse-Sensitivity-Enabled-P-Function* old)
	)
	(1if* (1typep* old-selected '4sheet*)
	    (1send* old-selected 3:Mouse-Select*)
	    nil
	)
      )
  )
)

;;;------------------- basic scrollable item -----------------------------------

1;;;Edited by Reed Hastings         28 Sep 87  5:43*
(defflavor basic-scrollable-item (item
				  (mouse-sensitive-type nil) ;nil means NOT mouse-sensitive
				   (left-edge 0)( right-edge 0)
				   (bottom-edge 0) (top-edge 0) ;1these are the dimensions of the text*
				   msr-left msr-right msr-bottom msr-top ;1these are the dimensions of the msr*
	                           4window* ;1which is Mouse Sensitive Region.*
				   (visible-p t) ;; visible when true
				   (unique-key nil) ;; uniquely identifies me
				   (linked-to nil) ;; equivalent items in other windows.
				   (mouse-sensitivity-enabled-p-function nil)
				  )
	   ()
  :gettable-instance-variables
  (3:Initable-Instance-Variables*
    mouse-sensitive-type item window visible-p unique-key linked-to)
  (3:Settable-Instance-Variables*
    item window mouse-sensitive-type visible-p unique-key linked-to
    mouse-sensitivity-enabled-p-function)
  (:required-methods :Draw-Self)
  ;;also requires an :after :init to set all the edges.
  )

(1defmethod* (2Basic-Scrollable-Item* 3:Add-Linked-To*) (item-to-link-to)
  (1without-interrupts*
    (1pushnew* item-to-link-to linked-to)
    (1pushnew* self (1send* item-to-link-to 3:Linked-To*))
  )
)

(1defmethod* (2Basic-Scrollable-Item* 3:Remove-Linked-To*) (item-to-unlink)
  (1without-interrupts*
    (1setf* linked-to (1remove* item-to-unlink linked-to))
    (1setf* (1send* item-to-unlink 3:Linked-To*)
	  (1remove* self (1send* item-to-unlink 3:Linked-To*))
    )
  )
)

(1def*method (2Basic-Scrollable-Item* :after :move-to) (&rest args)
  (without-recursion
    (1loop* for other in linked-to do (1lexpr-send* other 3:Move-To* args))
  )
)

(1defun* find-by-unique-key (key 4window*)
  (1find-if* #'(lambda (x)
	       (1eq* (1send* x 3:Unique-Key*) key)
	     )
	     (1send* window 3:Item-List*)
  )
)

(defwhopper (2Basic-Scrollable-Item* :Join-Items-With-An-Edge)
	    (to-vertex &rest args)
  (1let* ((the-edge (1lexpr-continue-whopper* to-vertex args)))
      (without-recursion
	(1loop* for other in linked-to
	      for to-other-vertex
	          = (find-by-unique-key (1send* to-vertex 3:Unique-Key*)
					(1send* other 3:Window*)
		    )
	      for linked-edge
	          = (lexpr-1send* other :Join-Items-With-An-Edge to-other-vertex
				 args
		    )
	      do (1send* the-edge :Add-Linked-To linked-edge)
	         (1send* 4window* 3:Send-If-Handles*
		        3:Perform-All-Link-Actions-For* the-edge linked-edge
		 )
	)
      )
      the-edge
  )
)

(1defun-method* draw-alu 2Basic-Scrollable-Item* ()
  (declare (special 2*Draw-Alu-To-Use**))
  (1or* 2*Draw-Alu-To-Use** (1Send* window :Char-Aluf))
)

(1defun-method* erase-alu 2Basic-Scrollable-Item* ()
  (declare (special 2*Erase-Alu-To-Use**))
  (1or* 2*Erase-Alu-To-Use** (1send* window :Erase-Aluf))
)

(1defun* print-pointer-to (object stream)
  (let ((*print-base* 8.)
	(*print-radix* nil)
	(*nopoint t)
       )
       (sys:print-fixnum (sys:%pointer object) stream)
  )
)

(eval-when (compile load eval) (load-tools '(:inspector-enhancements)))

(1defmethod* (2Basic-Scrollable-Item* :Print-Self) (1stream* ignore ignore)
  (1if* (1catch-error*
        (1if* (1boundp-in-instance* self 'item)
	    (1progn*
	      (1format* stream "#<~ ~ "
		      (1list* (1type-of* self) nil (1type-of* self))
		      (1list* item t item)
	      )
	      (2Print-Pointer-To* self stream)
	      (1format* stream ">")
	      t
	    )
	    (1progn*
	      (1format* stream "#<~ "
		      (1list* (1type-of* self) nil (1type-of* self))
	      )
	      (2Print-Pointer-To* self stream)
	      (1format* stream ">")
	      t
	    )
	)
	nil
      )
      self
      (1format* stream "Error printing...")
  )
)

(1defmethod* (2Basic-Scrollable-Item* :Maybe-Draw-Self) ()
  (declare (special 2*inhibit-draw-operations**))
  (1if* (1or* (1and* (1not* 2*inhibit-draw-operations**) visible-p
	      (1send* self :On-Screen-P)
	 )
     )
     (1send* self :Draw-Self)
     nil ; do-nothing
  )
)

(1defmethod* (2Basic-Scrollable-Item* :Maybe-Erase-Self) ()
  (declare (special 2*inhibit-draw-operations**))
  (1if* (1and* (1not* 2*inhibit-draw-operations**))
     (1send* self :Erase-Self)
     nil ; do-nothing
  )
)

(defmethod (basic-scrollable-item :draw-boxing-maybe)
	   (logical-mouse-x logical-mouse-y)
  (cond ((send self :boxing-appropriate-p logical-mouse-x logical-mouse-y)
	 ;;then get the window's item blinker, and turn it on
	 (let ((item-blinker (send window :item-blinker))
	       ;;; Fixes for µX put in because it doesn't seem able to clip
	       ;;; blinkers at the edge of windows.
	       (LEFT   (if (mx-p)
			   (max 0 (- msr-left (send window :x-pl-offset)))
			   (- msr-left (send window :x-pl-offset))))
	       (TOP    (if (mx-p)
			   (max 0 (- msr-top (send window :y-pl-offset)))
			   (- msr-top (send window :y-pl-offset))))
	       (RIGHT  (if (mx-p)
			   (min (send window :inside-width)
				(- msr-right (send window :x-pl-offset)))
			   (- msr-right (send window :x-pl-offset))))
	       (BOTTOM (if (mx-p)
			   (min (send window :inside-height)
				(-  msr-bottom (send window :y-pl-offset)))
			   (-  msr-bottom (send window :y-pl-offset))))
	       BWIDTH BHEIGHT)
	   (SETQ BWIDTH  (- RIGHT  LEFT)
		 BHEIGHT (- BOTTOM TOP))
           ;; Position the blinker to the item.
	   (BLINKER-SET-CURSORPOS ITEM-BLINKER left top)
                                ;  (- LEFT (SHEET-INSIDE-LEFT window))
				;  (- TOP  (SHEET-INSIDE-TOP window)))
           ;; Change the size of the blinker to enclose the item.
	   (BLINKER-SET-SIZE       ITEM-BLINKER BWIDTH BHEIGHT)
           ;; Turn the blinker on.
	   (BLINKER-SET-VISIBILITY ITEM-BLINKER T))
	 t)))					;return t to signify boxing is drawn


(defmethod (basic-scrollable-item :erase-boxing) ()
  "Turn the blinker off"
  (BLINKER-SET-VISIBILITY (send window :ITEM-BLINKER) NIL))
  
(defmethod (basic-scrollable-item :boxing-appropriate-p) (logical-mouse-x logical-mouse-y)
  "In order to qualify for boxing the item must be of a current-mouse-sensitive-type,
   and the mouse has to be over the msr (mouse sensitive region) of the item."
  (and visible-p
       (< msr-left logical-mouse-x msr-right)
       (< msr-top logical-mouse-y msr-bottom)
       (send window :current-mouse-sensitve-type-p mouse-sensitive-type)
       (1or* (1not* mouse-sensitivity-enabled-p-function)
	   (1funcall* mouse-sensitivity-enabled-p-function 4self*)
       )
  )
)

(defmethod (basic-scrollable-item :delete-self) ()
  "Erase self, then removes self from the window's item list"
  (send self :maybe-erase-self)
  (send window :set-item-list (delete self (1the* list (send window :item-list)) :Test #'eq)))

(defmethod (basic-scrollable-item :center-window-on-yourself) ()
  (let ((mid-x (truncate (+ left-edge right-edge) 2))
	(mid-y (truncate (+ top-edge bottom-edge) 2)))
  (send window :scroll-to
	(- mid-x (truncate (send window :inside-width) 2))
	(- mid-y (truncate (send window :inside-height) 2))
	nil)))  ;;this NIL means expand the logical window to accomodate us

1;;;Edited by Reed Hastings         8 Jul 87  1:46*
(defmethod (basic-scrollable-item :width) ()
  (- right-edge left-edge))

1;;;Edited by Reed Hastings         8 Jul 87  1:46*
(defmethod (basic-scrollable-item :height) ()
  (- bottom-edge top-edge))

;-------------------------------------------------------------------------------
;;; Load/Save graph.

(defun my-fasd-symbol-value (filename symbol &optional file-attribute-plist)
  "Write an XLD file named FILENAME containing SYMBOL's value.
Loading the file will set the symbol back to the same value."
  (let* ((compiler:fasd-package nil)
	 (outpath (fs:merge-pathname-defaults
		    filename fs:load-pathname-defaults
		    (compiler:target-binary-file-type compiler:fasd-target)))
	 (compiler:fasd-target (compiler:processor-type-for-file outpath)))
    (with-open-file
      (compiler:fasd-stream outpath
		   :characters nil :direction :output :byte-size 16.
		   :If-Exists :supersede)
      (compiler:locking-resources
	(compiler:fasd-initialize)
	(compiler:fasd-start-file)
	(compiler:fasd-attributes-list
	  (or file-attribute-plist
	      '(:package :user)))
	(compiler:inhibit-gc-flips
	  (compiler:fasd-form `(setq ,symbol ',(symbol-value symbol)) t))
	(compiler:fasd-end-whack)
	(compiler:fasd-end-file))
      (send compiler:fasd-stream :truename))))

(defun save-graph-to-file (grapher-sheet pathname)
  (let ((*temp* (4item-list-ordered-by* grapher-sheet 'edges-last)))
       (declare (special *temp*))
       (my-fasd-symbol-value pathname '*temp*)
  )
)

(defun load-graph-from-file (grapher-sheet pathname)
  (send grapher-sheet :Clear-Window)
  (let ((*window* grapher-sheet)
	(*temp* nil)
       )
       (declare (special *window* *temp*))
       (load pathname :Verbose nil)
  )
  (4reorder-item-list* grapher-sheet)
  (send grapher-sheet :Refresh)
)

(defun item-importance (item)
  (typecase item
    (graphics-vertex 0)
    (basic-edge 10)
    (basic-vertex 20)
    (otherwise 30)
  )
)

(defun edges-last (item)
  (typecase item
    (basic-edge 100)
    (otherwise 0)
  )
)

(defun item-list-ordered-by (grapher-sheet &optional (key 'item-importance))
  (sort (copy-list (symeval-in-instance grapher-sheet 'item-list))
	#'< :Key key
  )
)

(defun 2Reorder-Item-List*
       (grapher-sheet &optional (key 'item-importance) (and-linked-to-p t))
  (1if* and-linked-to-p
     (loop for (window) in (send grapher-sheet :Linked-To)
	   do (Reorder-Item-List window key nil)
     )
     nil
  )
  (setf (symeval-in-instance grapher-sheet 'item-list)
	(item-list-ordered-by grapher-sheet key)
  )
)

(defun instance-variables-of-instance (instance)
  (let ((class (clos:class-of instance)))
       (if (typep class 'ticlos:flavor-class)
	   (sys:flavor-all-instance-variables
	     (get (clos:class-name class) 'sys:flavor)
	   )
	   (let ((slotds (clos:class-slots class)))
		(loop for slotd in slotds
		      collect (clos:slot-definition-name slotd)
		)
	   )
       )
  )
)

(defun find-or-create-item (window type unique-key item-value &rest inits)
  (let ((items (send window :Item-List)))
       (or (find-if #'(lambda (x)
			(and (eq (type-of x) type)
			     (eq item-value (send x :Item))
			     (eq (send x :Unique-Key) unique-key)
			)
		      )
		      items
	   )
	   (lexpr-send window :Scrollable-Item item-value type inits)
       )
  )
)

(defmethod (basic-scrollable-item :Undumpable-Ivs) ()
  '(4window* linked-to)
)

(defmethod (basic-scrollable-item :Fasd-Form) ()
  (let ((ivs (instance-variables-of-instance self)))
       (let ((iv-sets
	       (loop for iv in ivs
		     unless (member iv (send self :Undumpable-Ivs))
		     collect `(setf (clos:slot-value object ',iv)
				  ',(clos:slot-value self iv)
			      )
	       )
	     )
	    )
	    (let ((inits (loop for init
			       in (send self :Send-If-Handles :Mandatory-Inits)
			       append
				 `(,(name:intern-as-keyword init)
				   ',(clos:slot-value self init)
				  )
			 )
		  )
		 )
	        `(let ((object (Find-Or-Create-Item
				 *window* ',(type-of self)
				 ',(send self :Unique-Key)
				 ',item
				 ,@inits
			       )
		       )
		       (setter #'(lambda (object) ,@iv-sets))
		      )
		      (1funcall* setter object)
		      (1loop* for 4link* in (1send* object 3:Linked-To*)
			    do (1funcall* setter link)
			       (1send* *window* :Perform-All-Link-Actions-For
				      object 4link*
			       )
		      )
		      object
		 )
	    )
       )
  )
)

(defun mouse-read-cursorpos (sheet)
"Returns the mouse position in internal coordinates.  Note:  This value could
 be negative if you are in a margin."
  (declare (values mouse-x mouse-y button))
  (with-mouse-grabbed-on-sheet (sheet)
    (unwind-protect
	(let ((button nil))
	     (mouse-set-blinker-definition
	       :character 4 3 :On :Set-Character #o74
	     )
	     (process-wait "Release Button"
			   #'(lambda () (zerop mouse-last-buttons))
	     )
	     (process-wait "Button"
			   #'(lambda () (not (zerop mouse-last-buttons)))
	     )
	     (setq button mouse-last-buttons)
	     (multiple-value-bind (x y) (values mouse-x mouse-y)
	       (process-wait "Release Button"
			     #'(lambda () (zerop mouse-last-buttons))
	       )
	       (values (- x (sheet-inside-left sheet))
		       (- y (sheet-inside-top  sheet))
		       button
	       )
	     )
	)
      (mouse-standard-blinker)
    )
  )
)

;;--------------------- Basic Node item ------------------------------------

(defconstant default-boxing-offset 3
  "How far away from a word to draw the boxing.")

(defflavor basic-node-item ((logical-x 0)
			    (logical-y 0)
			    (boxing-offset default-boxing-offset)
			    ;How far away from the thing to draw the boxing
			    (blinker)
			   )
	   (basic-scrollable-item)
  (:documentation  "An item whose printed representation is a string of text")
  (:gettable-instance-variables logical-x logical-y boxing-offset)
  (:settable-instance-variables logical-x logical-y boxing-offset)
  (:initable-instance-variables logical-x logical-y boxing-offset)
  (:Required-Methods :Draw-Self-With-Alu)
)

(defmethod (basic-node-item :refreshed) ()
  nil
)

(defwhopper (basic-node-item :Set-Edges) (&rest args)
  (setq left-edge logical-x)
  (setq top-edge logical-y)
  (lexpr-continue-whopper args)
  (setq msr-left (- left-edge boxing-offset)
	msr-right (+ right-edge boxing-offset)
	msr-bottom (+ bottom-edge boxing-offset)
	msr-top (- top-edge boxing-offset)
  )
)

(defwhopper (basic-node-item :init) (&rest args)
  (lexpr-continue-whopper args)
  (send self :set-edges)
)

(defmethod (basic-node-item :move-to) (x y &optional inhibit-redraw-p)
  (send self :maybe-erase-self)
  (setq logical-x x
	logical-y y)
  (send self :set-edges)
  (send window :expand-logical-window-maybe self)
  (unless inhibit-redraw-p
    (send self :maybe-draw-self)))

(defmethod (basic-node-item :blink) (&optional (how-fast-in-60ths 30))
  (let ((physical-x (- logical-x (send window :x-pl-offset)))
	(physical-y (- logical-y (send window :y-pl-offset))))
    (cond (blinker (send blinker :set-cursorpos physical-x physical-y)
		   (send blinker :set-visibility :blink)
		   (send blinker :set-deselected-visibility :blink)
		   (send blinker :set-half-period how-fast-in-60ths))
	  (t (setq blinker (make-blinker window
					 'rectangular-blinker
					 :width (- right-edge left-edge)
					 :height (- bottom-edge top-edge)
					 :deselected-visibility :blink
					 :x-pos physical-x
					 :y-pos physical-y
					 :half-period how-fast-in-60ths))
	     (send blinker :set-visibility :blink)))))

(defmethod (basic-node-item :dont-blink) ()
  (when blinker
    (send blinker :set-visibility nil)
    (send blinker :set-deselected-visibility nil)))

(defvar *track-movement-on-overview-window-p* nil)

(defmethod (basic-node-item :after :draw-self) (&rest ignore)
  (when (and blinker (send blinker :visibility))
    (let ((physical-x (- logical-x (send window :x-pl-offset)))
	  (physical-y (- logical-y (send window :y-pl-offset))))
      (send blinker :set-cursorpos physical-x physical-y)))
  (if (and *track-movement-on-overview-window-p*
	   (not (send window :Overview-Inside-P))
      )
      (send window :Show-Overview)
      nil
  )
)
  
(defmethod (basic-node-item :after :erase-self) (&rest ignore)
  (if (and *track-movement-on-overview-window-p*
	   (not (send window :Overview-Inside-P))
      )
      (send window :Show-Overview)
      nil
  )
)
(defmethod (basic-node-item :Erase-Self) ()
  (send self :draw-self-with-alu (erase-alu))
)

(defmethod (basic-node-item :Draw-Self) ()
  (send self :draw-self-with-alu (draw-alu))
)

(defmethod (basic-node-item :draw-self-shrunken) (shrink-factor overview-window)
  (1let* ((width (ceiling (* (- right-edge left-edge) shrink-factor)))
       (height (ceiling (* (- bottom-edge top-edge) shrink-factor)))
       (x (ceiling (* (- logical-x (send window :logical-left-edge)) shrink-factor)))
       (y (ceiling (* (- logical-y (send window :logical-top-edge)) shrink-factor)))
      )
      (1if* visible-p
	 (send overview-window :Draw-Filled-Rectangle x y width height)
	 (send overview-window :Draw-Rectangle x y width
	       height 1 (if (color-system-p self)
			    (tv:sheet-foreground-color self)
			    black
			)
	       w:normal 50%-gray
	 )
      )
  )
)

;;--------------------- scrollable text item ----------------------------------

(defflavor scrollable-text-item (font ;setq'd_maybe  in :after :init
				 (pre-print-item-modify-function #'identity)
				 ;must return a string. Given item.
				 (printed-representation nil) ;;; Always a string or unset.
				 (cachable-printed-representation-p t)

					    
				)
	   (basic-node-item basic-scrollable-item)
  (:documentation  "An item whose printed representation is a string of text")
  :Gettable-Instance-Variables
  :Settable-Instance-Variables
  :Initable-Instance-Variables
)


(defmethod (scrollable-text-item :Mandatory-Inits) ()
  '(pre-print-item-modify-function)
)

1;;;Edited by Guardian Demo         8 Aug 90  13:43*
(1defmethod* (2Scrollable-Text-Item* :On-Screen-P) ()
  (1or* 2*Force-On-Screen-P**
       (1send* window :vertex-on-screen-p msr-left msr-top msr-right msr-bottom)
  )
)

(1def*var *inhibit-get-printed-representation* nil)

1;;;Edited by Guardian Demo         8 Aug 90  13:44*
(1defmethod* (2Scrollable-Text-Item* :get-printed-representation) ()
  (1if* 2*Inhibit-Get-Printed-Representation**
      nil
     (1Or* (1and* cachable-printed-representation-p printed-representation)
	 (1let* ((the-printed-representation
		 (1let* ((4*dont-shift-string-streams** t))
		   (1declare* (1special* 4*dont-shift-string-streams**))
		   (funcall pre-print-item-modify-function item))))
	   (assert (stringp the-printed-representation)
		   (pre-print-item-modify-function)
		   "The pre-print-item-modify-function must result ~
                    in a string when applied to item.~
	            Currently it resuts in ~s" the-printed-representation)
	   (1if* cachable-printed-representation-p
	      (1setq* printed-representation the-printed-representation)
	      nil)
	   the-printed-representation))
  )
)

(defmethod (scrollable-text-item :after :init) (&rest ignore)
  (unless (and (variable-boundp font) font)
    (setq font (send window :current-font)))
  ;;; Coercion put in by JPR.
  (setq font
	(etypecase font
	  (font font)
	  (symbol (symbol-value font))
	  (number (aref (send window :Font-Map) font))
	)
  )
  (send self :Get-Printed-Representation)
)


(defmethod (scrollable-text-item :After :set-edges) ()
  (unless font (setq font (send window :current-font)))
  (multiple-value-bind (ignore text-height ignore text-length)
      (send window :Compute-Motion
	    (send self :Get-Printed-Representation)
	    0 nil 0 0  nil 0 nil nil nil font)
    (setq right-edge (+ logical-x text-length))
    (setq bottom-edge (+ logical-y (font-char-height font) text-height)))
)

(defmethod (scrollable-text-item :draw-self-with-alu) (alu)
    (let ((physical-x (- logical-x (send window :x-pl-offset)))
	  (physical-y (- logical-y (send window :y-pl-offset))))
      ;;since string-out-explicit goes by outside dimensions, and physical-x y are inside dimensions, do:
      (incf physical-x (sheet-inside-left window))
      (incf physical-y (sheet-inside-top window))
      (send window :string-out-explicit-within-region
	    (send self :Get-Printed-Representation) physical-x physical-y font alu)))
  
(defun place-text-item-in-grapher
       (item grapher-sheet
	&optional (x 0)
	          (y 0)
		  (print-function #'(lambda (x) (format nil "~S" x)))
       )
  (send grapher-sheet :Scrollable-Item item 'boxed-filled-vertex :X x :Y y
	:pre-print-item-modify-function print-function
	:Positioned-P t :Unique-Key (gensym)
	:Mouse-Sensitive-Type :Vertex
  )
)

;;--------------------- scrollable graphics item ------------------------------

(defflavor scrollable-graphics-item
	   ((bitmap-function 'bitmap-spec-from-bitmap)
	    ;must return a (bitmap &optional l t r b) list. Given item.
	   )
	   (basic-node-item)
  (:documentation  "An item whose printed representation is a bitmap")
  (:gettable-instance-variables bitmap-function)
  (:settable-instance-variables bitmap-function)
  (:initable-instance-variables bitmap-function)
)

(defun bitmap-spec-from-bitmap (bitmap)
  (1let* ((map (coerce-to-node bitmap)))
      (list map
	    0
	    0
	    (second (array-dimensions map))
	    (first (array-dimensions map))
      )
  )
)

(defmethod (scrollable-graphics-item :after :init) (&rest ignore)
  (assert (consp (funcall bitmap-function item)) (bitmap-function)
	  "The bitmap-function must result in a (bitmap &optional l t r b) list when applied to item.~
          Currently it resuts in ~s" (funcall bitmap-function item))
)

(defmethod (scrollable-graphics-item :After :set-edges) ()
  (destructuring-bind
    (bitmap &optional
	    (left 0)
	    (top 0)
	    (right (second (array-dimensions bitmap)))
	    (bottom (first (array-dimensions bitmap)))
    )
    (funcall bitmap-function item)
    (setq right-edge  (+ logical-x (- right left)))
    (setq bottom-edge (+ logical-y (- bottom top)))
  )
)

(1defmethod* (2Scrollable-Graphics-Item* :On-Screen-P) ()
  (1or* 2*Force-On-Screen-P**
       (1send* window :vertex-on-screen-p msr-left msr-top msr-right msr-bottom)
  )
)

(defmethod (scrollable-graphics-item :draw-self-with-alu) (alu)
  (let ((physical-x (- logical-x (send window :x-pl-offset)))
	(physical-y (- logical-y (send window :y-pl-offset))))
      ;;since bitblt goes by outside dimensions, and physical-x y are
      ;;inside dimensions, do:
      (incf physical-x (sheet-inside-left window))
      (incf physical-y (sheet-inside-top window))
      (destructuring-bind
	(bitmap &optional
		(left 0)
		(top 0)
		(right (second (array-dimensions bitmap)))
		(bottom (first (array-dimensions bitmap)))
        )
	(funcall bitmap-function item)
	(send window :Bitblt alu
	      (- right left) (- bottom top) bitmap left top
	      physical-x physical-y
	)
      )
  )
)

;;--------------------- scrollable circle item ------------------------------

(defflavor scrollable-circle-item
	   ((radius 1.0))
	   (basic-node-item)
  (:documentation  "An item whose printed representation is a circle")
  (:gettable-instance-variables radius)
  (:settable-instance-variables radius)
  (:initable-instance-variables radius)
)

(defmethod (scrollable-circle-item :After :set-edges) ()
  (setq left-edge   (- logical-x radius))
  (setq top-edge    (- logical-y radius))
  (setq right-edge  (+ logical-x radius))
  (setq bottom-edge (+ logical-y radius))
)

(defmethod (Scrollable-Circle-Item :After :Set-Radius) (to)
  (ignore to)
  (send self :Move-To logical-x logical-y)
)

(defmethod (Scrollable-Circle-Item :On-Screen-P) ()
  (or *force-on-screen-p*
      (send window :vertex-on-screen-p msr-left msr-top msr-right msr-bottom)
  )
)
  
(defmethod (scrollable-circle-item :draw-self-with-alu) (alu)
  (let ((physical-x (- logical-x (send window :x-pl-offset)))
	(physical-y (- logical-y (send window :y-pl-offset)))
       )
       (send window :Draw-Circle physical-x physical-y (round radius) alu)
  )
)


(defmethod (Scrollable-Circle-Item :Stretch-Point) ()
  (declare (values logical-x logical-y physical-x physical-y))
  (let ((physical-x (- logical-x (send window :x-pl-offset)))
	(physical-y (- logical-y (send window :y-pl-offset)))
       )
       (values (+ logical-x (round radius))  logical-y
	       (+ physical-x (round radius)) physical-y
       )
  )
)

(defmethod (Scrollable-Circle-Item :Set-Stretch-Point)
	   (x y &optional (type :logical))
  (ignore y)
  (send self :Set-Radius
	(max 1 (abs (case type
		      (:Physical
		       (- (- logical-x (send window :x-pl-offset)) x)
		      )
		      (otherwise (- logical-x x))
		    )
	       )
	)
  )
)

(defun draw-circle-on (grapher-sheet)
  (multiple-value-bind (x y button) (mouse-read-cursorpos grapher-sheet)
    (if (equal 1 button)
	(let ((item (send grapher-sheet :scrollable-item "Not specified yet"
			  'scrollable-circle-item :radius 5
			  :x (+ x (send grapher-sheet :X-Pl-Offset))
			  :y (+ y (send grapher-sheet :Y-Pl-Offset))
			  :Mouse-Sensitive-Type :Circle
			  :Visible-P nil
			  :Unique-Key (gensym)
		    )
	      )
	     )
	     (reshape-item-1 item)
	     item
	)
	(beep)
    )
  )
)

;1;;-----------------scrollable-line-item--------------------
;;;Edited by Reed Hastings         28 Sep 87  5:43*
(defflavor scrollable-line-item ((from-x 0) (from-y 0)
				 (to-x 0) (to-y 0))
	   (basic-scrollable-item)
  :settable-instance-variables
  :gettable-instance-variables
  :initable-instance-variables)

;;; Stub JPR.
(defmethod (scrollable-line-item :refreshed) ()
  nil
)

(1defmethod* (2Scrollable-Line-Item* :On-Screen-P) ()
  (1or* 2*Force-On-Screen-P**
       (1Send* window :edge-on-screen-p from-x from-y to-x to-y)
  )
)

(defmethod (scrollable-line-item :after :init) (&rest ignore)
  (unless (1boundp-in-instance* self 'item)
    (setq item (format nil "A line from (~a,~a) to (~a,~a)"
		       from-x from-y to-x to-y)))
  (send self :set-edges))

(defconstant line-box-size 8 "How big a mouse sensitive box to draw on a line")

(defmethod (scrollable-line-item :set-edges) ()
  (setq left-edge (min from-x to-x)
	right-edge (max from-x to-x)
	top-edge (min from-y to-y)
	bottom-edge (max from-y to-y))
  (let ((mid-x (truncate (+ left-edge right-edge) 2))
	(mid-y (truncate (+ top-edge bottom-edge) 2)))
    (setq msr-left (- mid-x  line-box-size)			
	  msr-right (+ mid-x line-box-size)
	  msr-top (- mid-y line-box-size)
	  msr-bottom (+ mid-y line-box-size))))

(defmethod (scrollable-line-item :draw-self) ()
  ;(format lisp "drawing ")
  (let ((physical-from-x (- from-x (send window :x-pl-offset)))
	(physical-from-y (- from-y (send window :y-pl-offset)))
	(physical-to-x (- to-x (send window :x-pl-offset)))
	(physical-to-y (- to-y (send window :y-pl-offset))))
    (send window :draw-line physical-from-x physical-from-y physical-to-x physical-to-y (2Draw-Alu*) nil)))

(defmethod (scrollable-line-item :erase-self) ()
  ;(format lisp "erasing ")
  (let ((physical-from-x (- from-x (send window :x-pl-offset)))
	(physical-from-y (- from-y (send window :y-pl-offset)))
	(physical-to-x (- to-x (send window :x-pl-offset)))
	(physical-to-y (- to-y (send window :y-pl-offset))))
    (send window :draw-line physical-from-x physical-from-y physical-to-x physical-to-y (2Erase-Alu*) nil)))

(defmethod (scrollable-line-item :move-to) (new-from-x new-from-y new-to-x new-to-y &optional inhibit-redraw-p)
  (1if* visible-p (send self :maybe-erase-self))
  (setq from-x new-from-x
	from-y new-from-y
	to-x new-to-x
	to-y new-to-y)
  (send self :set-edges)
  (send window :expand-logical-window-maybe self)
  (unless inhibit-redraw-p
    (send self :maybe-draw-self)))



;;;------------------------------ window exten1s*ions ----------------------------------------

(defflavor some-window-extensions () ())

(defmethod (some-window-extensions :mouse-warp) (x y)
  "x and y are relative to the outside of self.
2    *The pane of a frame is an inferior of the pane, so if
   you send the pane an :x-offset message you get relative to the frame.  But mouse-warp
   is relative the real tv screen.  In order to warp to a location relative to the pane, you've
   got to get the x-offset for the pane (relative to the frame) and for the frame (relative
   to the screeen). There might be N superiors."
  
    (mouse-warp (+ x (send self :real-x-offset)) (+ y (send self :real-y-offset))))

(defmethod (some-window-extensions :real-x-offset) ()
  "x and y are relative to the outside of self.
2    *The pane of a frame is an inferior of the pane, so if
   you send the pane an :x-offset message you get relative to the frame.  But mouse-warp
   is relative the real tv screen.  In order to warp to a location relative to the pane, you've
   got to get the x-offset for the pane (relative to the frame) and for the frame (relative
   to the screeen). There might be N superiors."
  (let ((real-x-offset 0))
    (do ((superior self (send superior :superior)))
	((not superior) real-x-offset)
      (incf real-x-offset (send superior :x-offset)))))

(defmethod (some-window-extensions :real-y-offset) ()
  "x and y are relative to the outside of self.
2    *The pane of a frame is an inferior of the pane, so if
   you send the pane an :x-offset message you get relative to the frame.  But mouse-warp
   is relative the real tv screen.  In order to warp to a location relative to the pane, you've
   got to get the x-offset for the pane (relative to the frame) and for the frame (relative
   to the screeen). There might be N superiors."
  (let ((real-y-offset 0))
    (do ((superior self (send superior :superior)))
	((not superior) real-y-offset)
      (incf real-y-offset (send superior :y-offset)))))


(DEFMETHOD (some-window-extensions :STRING-OUT-EXPLICIT-within-region)
	   (STRING START-X START-Y FONT ALU 
	    &OPTIONAL
	    (min-x (sheet-inside-left self))
	    (min-y (sheet-inside-top self))
	    (max-x (sheet-inside-right self))
	    (max-y (sheet-inside-bottom self))	      
	    (START 0) END (MULTI-LINE-LINE-HEIGHT (+ 2 (font-char-height font))))
  "Similar to :string-out-explicit except that this will only draw the chars
   if they are in the region defined by min-x min-y max-x max-y.  Basically
   this is a generalization of :string-out-explicit's x-limit y-limit."
  ;1;if the text is right of, on top of, or below the region then stop here*
  (when (and (<= start-x max-x)
	     (<= start-y max-y)
	     (>= start-y min-y))
    (SHEET-STRING-OUT-EXPLICIT-within-region-1 SELF STRING START-X START-Y
					       min-x min-y max-x max-y
					       FONT ALU
					       START END MULTI-LINE-LINE-HEIGHT)))

(1defvar* backwards-XR-SPECIAL-CHARACTER-NAMES
        (1mapcar* #'(lambda (x) (1cons* (1rest* x) (1first* x)))
		 SI:XR-SPECIAL-CHARACTER-NAMES
        )
"So that we can assq."
)

(DEFUN SHEET-STRING-OUT-EXPLICIT-within-region-1
       (SHEET STRING START-X Y
	min-x min-y
	XLIM YLIM FONT ALU
				    &OPTIONAL (START 0) (END NIL)
				    MULTI-LINE-LINE-HEIGHT
				    &AUX FIT FWT LKT
				    (X START-X))
  "Output STRING on SHEET without using SHEET's cursor, font, etc.
   Output starts at cursor position START-X, Y if both are greater than
   min-x min-y. SHEET's cursor is not moved. 
   Output stops if x-position XLIM or y-position YLIM is reached.

   Font FONT is used, and alu-function ALU.
   START and END specify a portion of STRING to be used.
   MULTI-LINE-LINE-HEIGHT is how far to move down for Return
   characters; Return also moves back to x-position START-X.
   NIL means output <Return> with a lozenge.

  All position arguments are relative to SHEET's outside edges."
  
  (DECLARE (values FINAL-X FINAL-Y FINAL-INDEX))
  (COERCE-FONT FONT SHEET)
  (SETQ FIT (FONT-INDEXING-TABLE   FONT)
	FWT (FONT-CHAR-WIDTH-TABLE FONT)
	LKT (FONT-LEFT-KERN-TABLE  FONT))
  (OR XLIM (SETQ XLIM (SHEET-WIDTH SHEET)))
  (PREPARE-SHEET (SHEET)
    (DO ((I START (1+ I))
	 (N (OR END (ARRAY-ACTIVE-LENGTH STRING)))
	 (WIDTH (FONT-CHAR-WIDTH FONT))
	 (CH))
	((>= I N) (VALUES X Y I))
      (SETQ CH (AREF STRING I))
      (COND ((AND MULTI-LINE-LINE-HEIGHT (member CH '(#\newline #\RETURN) :test #'char-equal))
	     (SETQ X START-X
                   Y (+ Y MULTI-LINE-LINE-HEIGHT))
	     (IF (AND YLIM (> (+ Y MULTI-LINE-LINE-HEIGHT) YLIM))
		 (RETURN X Y I)))
	    ((>= CH 200)
	     (LET* ((STRING (STRING
                              (OR
                                (CAR (ASSOC CH 2Backwards-Xr-Special-Character-Names* :Test #'eq))
                                ;; If there is no name for the character
                                ;; then print out its octal character
                                ;; number.
                                (FORMAT NIL "~3O" CH))))
		    (NX (+ X (LOZENGED-STRING-geometry STRING))))
	       (IF (> NX XLIM) (RETURN X Y I))
	       (SHEET-DISPLAY-LOZENGED-STRING-INTERNAL SHEET STRING
						       X (1+ Y) XLIM ALU)
	       (SETQ X NX)))
	    (T (IF FWT (SETQ WIDTH (or (AREF FWT CH) (FONT-CHAR-WIDTH FONT))))
	       (IF (> (+ X WIDTH) XLIM) (RETURN X Y I))
	       (when (and (<= min-x x)		;This extra "when", and the lambda list, are the only things
			  (<= min-y y)		;different from SHEET-STRING-OUT-EXPLICIT-1
			  (>= ylim (+ y (font-char-height font))))
		 (DRAW-CHAR FONT CH
			    (IF LKT
				(- X (AREF LKT CH))
				;;ELSE
				X)
			    Y ALU SHEET))
	       (SETQ X (+ X WIDTH)))))))



;;;
;;;   Reed Hastings     Hastings@sumex.stanford.edu     January 1987
;;;
;;;   The flavor defs and methods for flavor x-y-scroll-bars-mixin.
;;;   This flavor sets up horizontal and vertical scroll bars.
;;;  
;;;   Mix this in with a window if that window:
;;;   
;;;   a) has a mouse handler that sends self :invoke-ver-scrolling and :invoke-hor-scrolling when appropriate;
;;;   b) has the required methods and instance variables below.  They are mostly
;;;      used to calculate the correct scroll bar length and position;
;;;   c) handles the :scroll-to message which has two args: new-x-position and new-y-position, which are
;;;      in pixels on the logical screen, and might be negative;  the handler should truncate args into range.
;;;   d) handles the :scroll-relative message which has two args: how-many-pixels and direction.
;;;   
;;;   
;;;   Overwiew.
;;;   
;;;   a typical (vertical) scrolling action would go like this:  the window's mouse handler would notice that the mouse
;;;   is requesting scrolling (by slowly leaving the top probably). It sends an :invoke-ver-scrolling
;;;   message.  The method below would draw the scroll bar, alter the mouse cursor character, and
;;;   call the ver-scrolling-mouse-handler.  This handler will keep the mouse in the correct region, sending
;;;   :mouse-moves-scroll  and :mouse-buttons-scroll messages as appropriate. After sending each :mouse-buttons-scroll
;;;   message it will redraw the scroll bar to reflect the (possibly) new situation.  This mouse handler will
;;;   return when the mouse legally moves out of the scroll bar region, or when the mouse is seized (like by
;;;   some other window covering our scrolling window.)  After the mouse handler returns, the 
;;;   :invoke-ver-scrolling method will erase the scroll bar, and reset the mouse cursor character, before
;;;   returning (presumably to the window's regular mouse handler).
;;;
;;;
;;;   Notes.
;;;
;;;   The code in capitals was pinched from the TI system code. Mostly from the mouse-default-handler.
;;;
;;;

(defconstant  default-scroll-bar-thickness 3)
							   
(defflavor 2X-Y-Scroll-Bars-Mixin*
	   ((hor-scrolling-in-effect nil) ;a flag for general use
	    (ver-scrolling-in-effect nil)	;a flag for general use
	    (ver-scroll-bar nil)	;a record of the scroll bar dimensions, nil if not drawn.
	    (hor-scroll-bar nil)	;a record of the scroll bar dimensions, nil if not drawn.
	    (scroll-bar-thickness default-scroll-bar-thickness)
	    (use-both-scroll-bars-p t) ;if t, both scroll bars are drawn when scrolling invoked.	
	    (hor-scroll-bar-always-displayed-p nil)
	    (ver-scroll-bar-always-displayed-p nil)
	    (Scroll-Bar-Positions '(:Left :Bottom))
	   )
	   ()
  (:required-instance-variables logical-left-edge x-pl-offset logical-top-edge y-pl-offset logical-bottom-edge)
  (:required-methods :scroll-relative :scroll-to :logical-width :logical-height :inside-width :inside-height)
  (:required-flavors minimum-window)
  (:initable-instance-variables Scroll-Bar-Positions
				scroll-bar-thickness
				use-both-scroll-bars-p
				ver-scroll-bar-always-displayed-p
				hor-scroll-bar-always-displayed-p)
  (:settable-instance-variables scroll-bar-thickness
				hor-scrolling-in-effect
				ver-scrolling-in-effect
				use-both-scroll-bars-p
				ver-scroll-bar-always-displayed-p
				hor-scroll-bar-always-displayed-p)) 


(defmethod (x-y-scroll-bars-mixin :after :init) (&rest ignore)
  "give room for scroll bars on left and top edges."
  (1send* self :Validate-Scroll-Bar-Positions)
  (send self :set-border-margin-width (+ scroll-bar-thickness 1)))

(1defmethod* (2X-Y-Scroll-Bars-Mixin* :Validate-Scroll-Bar-Positions) ()
  (1assert* (1and* (1listp* Scroll-Bar-Positions)
	      (1not* (1set-difference*
		     Scroll-Bar-Positions
		     '(:Left :Right :Top :Bottom)
		   )
	      )
	 )
	 (Scroll-Bar-Positions)
	 "The scroll bar positions must be in the set: '(:Left :Right :Top :Bottom)"
  )
)

(1defmethod* (2X-Y-Scroll-Bars-Mixin* :Scroll-Bar-Positions) ()
  Scroll-Bar-Positions
)

(1defmethod* (2X-Y-Scroll-Bars-Mixin* :Set-Scroll-Bar-Positions) (to)
  (1setq* Scroll-Bar-Positions to)
  (1send* self :Validate-Scroll-Bar-Positions)
  scroll-bar-positions
)

(1defmethod* (2X-Y-Scroll-Bars-Mixin* :Hor-Scroll-Bar-Positions) ()
  (1set-difference* (1send* self :Scroll-Bar-Positions) '(:Left :Right))
)

(1defmethod* (2X-Y-Scroll-Bars-Mixin* :Ver-Scroll-Bar-Positions) ()
  (1set-difference* (1send* self :Scroll-Bar-Positions) '(:Top : Bottom))
)

(defmethod (x-y-scroll-bars-mixin :after :expose) (&rest ignore)
  (when hor-scroll-bar-always-displayed-p
    (1loop* for pos in (1send* self :Hor-Scroll-Bar-Positions)
	  do (send self :Draw-Hor-Scroll-Bar pos)))
  (when ver-scroll-bar-always-displayed-p
    (1loop* for pos in (1send* self :Ver-Scroll-Bar-Positions)
	  do (send self :Draw-Ver-Scroll-Bar pos))))

(defmethod (x-y-scroll-bars-mixin :before :change-of-size-or-margins) (&rest ignore)
  "We have to get rid of them because they will change in length upredictably,
   and we won't know how to erase them."
  (1loop* for pos in (1send* self :Hor-Scroll-Bar-Positions)
        do (send self :Erase-Hor-Scroll-Bar pos))
  (1loop* for pos in (1send* self :Ver-Scroll-Bar-Positions)
        do (send self :Erase-Ver-Scroll-Bar pos)))


(defmethod (x-y-scroll-bars-mixin :override :who-line-documentation-string) ()
  (cond (ver-scrolling-in-effect self
	 (if (= (send self :logical-height) (send self :inside-height))
	     "Nothing to scroll to vertically.  There is nothing above or below."
	     '(:MOUSE-L-1 "this place to top"
			  :MOUSE-L-2 "this place to bottom"
			  :MOUSE-M-1 "percentage-wise"
			  :MOUSE-R-1 "top to this place"
			  :MOUSE-R-2 "bottom to this place")))
	(hor-scrolling-in-effect
	 (if (= (send self :logical-width) (send self :inside-width))
	     "Nothing to scroll to horizontally.  There is nothing left or right."
	     '(:MOUSE-L-1 "this place to left edge"
			  :MOUSE-L-2 "this place to right edge"
			  :MOUSE-M-1 "percentage-wise"
			  :MOUSE-R-1 "left edge to this place"
			  :MOUSE-R-2 "right edge to this place.")))))


;;; the mouse char has already been changed so just pass on the :mouse-moves message.
(defmethod (x-y-scroll-bars-mixin :mouse-moves-scroll) (x y)
  (send self :mouse-moves x y))

(defmethod (x-y-scroll-bars-mixin :mouse-buttons-scroll) (bd x y)
  "decides how much to scroll in what direction"
  ;;bd is a mask of what button is down. mouse-button-encode looks for double clicks or whatever.
  (let ((button (mouse-character-button-encode bd)))
    (cond (hor-scrolling-in-effect
	   (case button
		 (#\mouse-l (send self :scroll-relative x 0))
		 (#\mouse-l-2 (send self :scroll-relative (- x width) 0))
		 (#\mouse-r (send self :scroll-relative (- x) 0))
		 (#\mouse-r-2 (send self :scroll-relative (- width x) 0))
		 (#\mouse-m (send self :scroll-to
				  (truncate (+ logical-left-edge (* (send self :logical-width)
					       (/ x width))))
				  y-pl-offset))
		 (otherwise (beep))))
	  (ver-scrolling-in-effect
	   (case button
		 (#\mouse-l (send self :scroll-relative 0 y))
		 (#\mouse-l-2 (send self :scroll-relative 0 (- y height)))
		 (#\mouse-r (send self :scroll-relative 0 (- y)))
		 (#\mouse-r-2 (send self :scroll-relative 0 (- height y)))
		 (#\mouse-m (send self :scroll-to
				  x-pl-offset
				  (truncate (+ logical-top-edge (* (send self :logical-height)
					       (/ y height))))))
		 (otherwise (beep))))
	  (t (cerror "ignore safely" "neither scroll bar is in")))))





(defmethod (x-y-scroll-bars-mixin :update-scroll-bars) ()
  (1loop* for pos in (1send* self :Ver-Scroll-Bar-Positions)
       when (2Ver-Scroll-Bar* pos)
       do (send self :Erase-Ver-Scroll-Bar pos)
	  (send self :Draw-Ver-Scroll-Bar pos))
  (1loop* for pos in (1send* self :Hor-Scroll-Bar-Positions)
       when (2Hor-Scroll-Bar* pos)
       do (send self :Erase-Hor-Scroll-Bar pos)
          (send self :Draw-Hor-Scroll-Bar pos)))



;;;--------------------- vertical scrolling code. ------ horizontal is symmetric.

(defmethod (x-y-scroll-bars-mixin :invoke-ver-scrolling) (&optional (1position* :left))
  "Called by the window's mouse handler when the mouse enters the vertical scroll bar.
   Returns when the mouse leaves the scrolling area."
  ;; Give feedback by changing mouse cursor before calling SCROLL-BAR-DRAW, which pages a lot
  (send self ':Set-Mouse-Position
	(1if* (1equal* Position :Left)
	   (TRUNCATE SCROLL-BAR-WIDTH 2)
	   (- (sheet-width self) (TRUNCATE SCROLL-BAR-WIDTH 2))
	)
	NIL)
  ;; Change the mouse to a double-headed up-and-down arrow.
  (MOUSE-SET-BLINKER-DEFINITION ':CHARACTER 0 7 ':ON
				':SET-CHARACTER 4)
  ;; Draw the scroll bar(s)
  ;; We don't care if there already drawn, cause :draw-ver-scroll-bar will do the right thing.
  (1loop* for pos in (1send* self :Ver-Scroll-Bar-Positions)
        do (send self :Draw-Ver-Scroll-Bar pos))
  (when use-both-scroll-bars-p
    (1loop* for pos in (1send* self :Hor-Scroll-Bar-Positions)
	  do (send self :Draw-Hor-Scroll-Bar pos)))
  ;; let this handler run. It will return when the mouse leaves the scrolling area.
  ;; while it is running set the flag the who line and maybe others
  (setq ver-scrolling-in-effect t)
  (send self :Invoke-Ver-Scrolling-Mouse-Handler position)
  (setq ver-scrolling-in-effect nil)
  ;; put back blinker
  (mouse-standard-blinker self)
  ;; erase scroll bar
  (unless ver-scroll-bar-always-displayed-p
    (1loop* for pos in (1send* self :Ver-Scroll-Bar-Positions)
	  do (send self :Erase-Ver-Scroll-Bar pos)))
  (unless hor-scroll-bar-always-displayed-p
    (1loop* for pos in (1send* self :Hor-Scroll-Bar-Positions)
	  when (2Hor-Scroll-Bar* pos)
	  do (send self :Erase-Hor-Scroll-Bar pos))))

(defmethod (x-y-scroll-bars-mixin :draw-ver-scroll-bar) (&optional (1position* :left))
  (WITHOUT-INTERRUPTS
    (IF (SHEET-CAN-GET-LOCK SELF)
	(2Ver-Scroll-Bar-Draw* position)
	(PROCESS-RUN-FUNCTION "Draw Scroll Bar"
			      (let-closed ((self self)
					   (si:self-mapping-table si:self-mapping-table))
				  (SHEET-FORCE-ACCESS (SELF)
				    ;; It is possible that the mouse moved out while we were
				    ;; waiting.  If this is the case, punt drawing.
				    (AND (send self :ver-scrolling-in-effect)
					 (2Ver-Scroll-Bar-Draw* position))))))))

(defmethod (x-y-scroll-bars-mixin :erase-ver-scroll-bar) (&optional (1position* :left))
  (WITHOUT-INTERRUPTS
    ;;There is this funny case where the sheet could be locked by the person waiting
    ;; for us to back out.  For us to block here would be a disaster, so undraw the
    ;; scroll bar in another process
    (if (SHEET-CAN-GET-LOCK SELF)
	(SHEET-FORCE-ACCESS (SELF) (2Ver-Scroll-Bar-Erase* position))
	(PROCESS-RUN-FUNCTION "Undraw Scroll Bar"
			      (let-closed ((self self)
					   (si:self-mapping-table si:self-mapping-table))
				  (SHEET-FORCE-ACCESS (SELF)
				    ;; It is possible that the user reentered the
				    ;; scroll bar before this code ran.  In that
				    ;; case, don't actually erase it.
				    (OR (send self :VER-SCROLLING-IN-EFFECT)
					(2Ver-Scroll-Bar-Erase* position))))))))

(defmethod (x-y-scroll-bars-mixin :invoke-ver-scrolling-mouse-handler)
				    (&optional (1position* :left)
				     &AUX
				    (WINDOW-X-OFFSET 0) (WINDOW-Y-OFFSET 0)
				    WINDOW-X WINDOW-Y
				    (window self))
				    
  "Handles the mouse if vertical scroll bar is engaged."
  (MULTIPLE-VALUE-setq (WINDOW-X-OFFSET WINDOW-Y-OFFSET)
    (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET))
  (DO ((DX) (DY) (BU) (BD)  (X) (Y)
       (OLD-OWNER WINDOW-OWNING-MOUSE WINDOW-OWNING-MOUSE)
       (WAIT-FLAG NIL T))
      (MOUSE-RECONSIDER)
    ;; Wait until the mouse moves
    (if (mx-p)
	;;; Do this twice because otherwise we get bogus values.
	(MULTIPLE-VALUE-setq (DX DY BD BU X Y) (MOUSE-INPUT nil))
	nil)
    (MULTIPLE-VALUE-setq (DX DY BD BU X Y) (MOUSE-INPUT WAIT-FLAG))
    ;; If asked to reconsider, do so immediately.
    ;; Don't bother updating blinker since it is likely to change soon, and
    ;; in any case we are going to be called back shortly.
    (IF MOUSE-RECONSIDER (RETURN NIL))

    (SETQ WINDOW-X (- X WINDOW-X-OFFSET)	; X offset of mouse within window
	  WINDOW-Y (- Y WINDOW-Y-OFFSET))	; Y offset of mouse within window
    ;; Approximate speed of the mouse in inches per second
    (SETQ MOUSE-SPEED (truncate (ISQRT (+ (* MOUSE-X-SPEED MOUSE-X-SPEED)
					  (* MOUSE-Y-SPEED MOUSE-Y-SPEED)))
				100))
    ;; maybe leave the scroll bar
    (COND ((AND SCROLL-BAR-MAX-EXIT-SPEED
		(> MOUSE-SPEED SCROLL-BAR-MAX-EXIT-SPEED))
	   ;; Moving like a bat, let the guy out of the scroll bar
	   (RETURN NIL))
	  ((1and* (1equal* position :Left) (> WINDOW-X SCROLL-BAR-WIDTH))	;Escape out right
	   (RETURN NIL))
	  ((1and* (1equal* position :Right) (< WINDOW-X (- (sheet-width window) SCROLL-BAR-WIDTH)))	;Escape out right
	   (RETURN NIL))
	  ((1and* (1equal* position :Left) (MINUSP WINDOW-X)) ;Trying to go out left, shove back in
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-X 0)
	     (SETQ MOUSE-LAST-X (SETQ MOUSE-X WINDOW-X-OFFSET))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL)))
	  ((1and* (1equal* position :Right) (MINUSP WINDOW-X)) ;Trying to go out left, shove back in
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-X (sheet-width window))
	     (SETQ MOUSE-LAST-X (SETQ MOUSE-X (+ (sheet-width window) WINDOW-x-OFFSET)))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL)))
	  ((MINUSP WINDOW-y)			;Trying to go out up, shove back in
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-y 0)
	     (SETQ MOUSE-LAST-y (SETQ MOUSE-y WINDOW-y-OFFSET))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL)))
	  ((> window-y (send window :inside-height))	;Trying to go out down, shove back in.
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-y (send window :inside-height))
	     (SETQ MOUSE-LAST-y (SETQ MOUSE-y (+ WINDOW-y-OFFSET (send window :inside-height))))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL))))
    ;; Update the position of the mouse before checking for button clicks, so
    ;; that button clicks get processed with knowledge of where the mouse
    ;; was when the button was first clicked.  The arguments to the move handler
    ;; may be where the mouse was when the button was clicked, whereas the
    ;; mouse cursor follows MOUSE-X and MOUSE-Y, which may be different.    
    (SETQ MOUSE-WARP NIL)
    (send window :mouse-moves-scroll window-x window-y)
    ;; Check for all the ways of losing control of the mouse.
    (IF (COND ;; The move handler may have decided to warp the mouse so that it will not
	  ;; move out of the window.  This test is a crock but should work.
	  (MOUSE-WARP NIL)
	  ;; Check for mouse ceasing to be grabbed.
	  ((EQ WINDOW T)
	   (NEQ WINDOW-OWNING-MOUSE T))
	  ;; Check for window becoming grabbed.
	  ((EQ WINDOW-OWNING-MOUSE T)
	   (NEQ WINDOW T))
	  ;; Check for some other window (not above this one) being greedy.
	  (WINDOW-OWNING-MOUSE
	   (NOT (SHEET-ME-OR-MY-KID-P WINDOW WINDOW-OWNING-MOUSE)))
	  ;; Check for moving into a window when not in any
	  ((NULL WINDOW)
	   (WINDOW-OWNING-MOUSE X Y))
	  ;; Check for leaving the boundaries of the current window
	  ;; HYSTERETIC-WINDOW-MIXIN requires that we wait at least once before returning
	  ((and (mx-p)
		;;; We can't warp the mouse on the MX when we end up in
		;;; a scroll bar, so be more lenient.
		(NOT (AND (SHEET-EXPOSED-P WINDOW)
			  ;;; When the mouse is outside the window the
			  ;;; values of window-x and window-y stay constant at
			  ;;; the edges of the window, so we need to calculate
			  ;;; a certain amount of hysteresis on our own.
			  (and (<= y (+ window-y window-y-offset))
			       (and (>= x (+ (- *mx-scroll-bar-tollerance*)
					     window-x window-x-offset))
				    (<= x (+ *mx-scroll-bar-tollerance*
					     window-x window-x-offset))))
			  (>= WINDOW-X (- *mx-scroll-bar-tollerance*))
			  (<  WINDOW-X (+ *mx-scroll-bar-tollerance*
					  (SHEET-WIDTH WINDOW)))
			  (>= WINDOW-Y (- *mx-scroll-bar-tollerance*))
			  (<  WINDOW-Y (+ *mx-scroll-bar-tollerance*
					  (SHEET-HEIGHT WINDOW)))
			  )))
	   wait-flag)
	  ((and (not (mx-p))
		(NOT (AND (SHEET-EXPOSED-P WINDOW)
			  (>= WINDOW-X 0)
			  (<  WINDOW-X (SHEET-WIDTH WINDOW))
			  (>= WINDOW-Y 0)
			  (<  WINDOW-Y (SHEET-HEIGHT WINDOW)))))
	   WAIT-FLAG)
	  ;; Check for moving into an inferior of the current window
	  ((NEQ (LOWEST-SHEET-UNDER-POINT WINDOW WINDOW-X WINDOW-Y
					  ':HANDLE-MOUSE ':EXPOSED)
		WINDOW)
	   T))
	;; Return to overseer, saving any pending button click.
	(RETURN (MOUSE-DEFER-BUTTONS BU BD)))
    ;; Now process button pushes if mouse is not seized.
    (unless (OR (ZEROP BD) OLD-OWNER)
      (FUNCALL WINDOW :mouse-buttons-scroll BD WINDOW-X WINDOW-Y)
      (send window :update-scroll-bars))))

;;;--------------- horizontal scrolling ----- symmetric code to above vertical scrolling

1;;;Edited by HASTINGS              13 Jun 87  2:21*
(defmethod (x-y-scroll-bars-mixin :invoke-hor-scrolling) (&optional (1position* :bottom))
  "Called when the mouse enters the horizontal scroll bar
     Returns when the mouse leaves the scrolling area."
  ;; Give feedback by changing mouse cursor before calling SCROLL-BAR-DRAW, which pages a lot
  (SEND SELF ':SET-MOUSE-POSITION NIL
	(1if* (1equal* Position :Bottom)
	   (- (sheet-height self) (TRUNCATE SCROLL-BAR-WIDTH 2))
	   (TRUNCATE SCROLL-BAR-WIDTH 2)
	)
  )

  ;; Change the mouse to a fat double-headed left-and-right arrow.
  (MOUSE-SET-BLINKER-DEFINITION ':CHARACTER 0 7 ':ON
				':SET-CHARACTER 5)

  ;; Draw the scroll bar
  (1loop* for pos in (1send* self :Hor-Scroll-Bar-Positions)
        do (send self :Draw-Hor-Scroll-Bar pos))
  (when use-both-scroll-bars-p
    (1loop* for pos in (1send* self :Ver-Scroll-Bar-Positions)
	 do (send self :Draw-Ver-Scroll-Bar pos)))
  ;; let this handler run. It will return when the mouse leaves the scrolling area.
  ;; while it is running set the flag the who line and maybe others
  (setq hor-scrolling-in-effect t)
  (send self :Invoke-Hor-Scrolling-Mouse-Handler position)
  (setq hor-scrolling-in-effect nil)
  ;; put back blinker
  (mouse-standard-blinker self)
  ;; erase scroll bar
  (unless hor-scroll-bar-always-displayed-p
    (1loop* for pos in (1send* self :Hor-Scroll-Bar-Positions)
	  do (send self :Erase-Hor-Scroll-Bar pos)))
  (unless ver-scroll-bar-always-displayed-p
    (1loop* for pos in (1send* self :Ver-Scroll-Bar-Positions)
	  when (2Ver-Scroll-Bar* pos)
	  do (send self :Erase-Ver-Scroll-Bar pos))))

(defmethod (x-y-scroll-bars-mixin :draw-hor-scroll-bar) (&optional (1position* :bottom))
  (WITHOUT-INTERRUPTS
    (IF (SHEET-CAN-GET-LOCK SELF)
	(2Hor-Scroll-Bar-Draw* position)
	(PROCESS-RUN-FUNCTION "Draw Scroll Bar"
			      (let-closed ((self self)
					   (si:self-mapping-table si:self-mapping-table))
				  (SHEET-FORCE-ACCESS (SELF)
				    ;; It is possible that the mouse moved out while we were
				    ;; waiting.  If this is the case, punt drawing.
				    (AND (send self :hor-scrolling-in-effect)
					 (2Hor-Scroll-Bar-Draw* position))))))))

(defmethod (x-y-scroll-bars-mixin :erase-hor-scroll-bar) (&optional (1position* :bottom))
    (WITHOUT-INTERRUPTS
      ;;There is this funny case where the sheet could be locked by the person waiting
      ;; for us to back out.  For us to block here would be a disaster, so undraw the
      ;; scroll bar in another process
      (if (SHEET-CAN-GET-LOCK SELF)
	  (SHEET-FORCE-ACCESS (SELF) (2Hor-Scroll-Bar-Erase* position))
	  (PROCESS-RUN-FUNCTION "Undraw Scroll Bar"
				(let-closed ((self self)
					   (si:self-mapping-table si:self-mapping-table))
				    (SHEET-FORCE-ACCESS (SELF)
				      ;; It is possible that the user reentered the
				      ;; scroll bar before this code ran.  In that
				      ;; case, don't actually erase it.
				      (OR (send self :hor-scrolling-in-effect)
					  (2Hor-Scroll-Bar-Erase* position))))))))


1;;;Edited by HASTINGS              13 Jun 87  2:21*
(defmethod (x-y-scroll-bars-mixin :invoke-hor-scrolling-mouse-handler) 
				    (&optional (1position* :bottom)
				     &AUX
				    (WINDOW-X-OFFSET 0) (WINDOW-Y-OFFSET 0)
				    WINDOW-X WINDOW-Y
				    (window self))
				    
  "Handles the mouse if horizontal scroll bar is exposed."
  (MULTIPLE-VALUE-SETQ (WINDOW-X-OFFSET WINDOW-Y-OFFSET)
    (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET)) 
  (DO ((DX) (DY) (BU) (BD)  (X) (Y)
       (OLD-OWNER WINDOW-OWNING-MOUSE WINDOW-OWNING-MOUSE)
       (WAIT-FLAG NIL T))
      (MOUSE-RECONSIDER)
    ;; Wait until the mouse moves
    (MULTIPLE-VALUE-SETQ (DX DY BD BU X Y) (MOUSE-INPUT WAIT-FLAG))
    ;; If asked to reconsider, do so immediately.
    ;; Don't bother updating blinker since it is likely to change soon, and
    ;; in any case we are going to be called back shortly.
    (IF MOUSE-RECONSIDER (RETURN NIL))

    (SETQ WINDOW-X (- X WINDOW-X-OFFSET)	; X offset of mouse within window
	  WINDOW-Y (- Y WINDOW-Y-OFFSET))	; Y offset of mouse within window
    ;; Approximate speed of the mouse in inches per second
    (SETQ MOUSE-SPEED (truncate (ISQRT (+ (* MOUSE-X-SPEED MOUSE-X-SPEED)
					  (* MOUSE-Y-SPEED MOUSE-Y-SPEED)))
				100))
    ;; maybe leave the scroll bar and maybe move the cursor in.
    (COND ((AND SCROLL-BAR-MAX-EXIT-SPEED
		(> MOUSE-SPEED SCROLL-BAR-MAX-EXIT-SPEED))
	   ;; Moving like a bat, let the guy out of the scroll bar
	   (RETURN NIL))
	  ((1and* (1equal* position :Bottom)
		(< WINDOW-y (- (sheet-height window) SCROLL-BAR-WIDTH)))	;Escape out up
	   (RETURN NIL))
	  ((1and* (1equal* position :Top)
		(1>=* WINDOW-y SCROLL-BAR-WIDTH))	;Escape out up
	   (RETURN NIL))
	  ((1and* (1equal* position :Bottom)
		(> WINDOW-y 	(sheet-height window))) ;Trying to go out down, shove back in
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-y (sheet-height window))
	     (SETQ MOUSE-LAST-y (SETQ MOUSE-y (+ (sheet-height window) WINDOW-y-OFFSET)))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL)))
	  ((1and* (1equal* position :Top)
		(1<*= WINDOW-y 0)) ;Trying to go out up, shove back in
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-y 0)
	     (SETQ MOUSE-LAST-y (SETQ MOUSE-y WINDOW-y-OFFSET))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL)))
	  ((MINUSP WINDOW-X)			;Trying to go out left, shove back in
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-X 0)
	     (SETQ MOUSE-LAST-X (SETQ MOUSE-X WINDOW-X-OFFSET))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL)))
	  ((> window-x (send window :inside-width))	;Trying to go out right, shove back in.
	   (WITHOUT-INTERRUPTS
	     (%OPEN-MOUSE-CURSOR)
	     (SETQ WINDOW-X (send window :inside-width))
	     (SETQ MOUSE-LAST-X (SETQ MOUSE-X (+ WINDOW-X-OFFSET (send window :inside-width))))
	     (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		   PREPARED-SHEET NIL)))
	  )
    ;; Update the position of the mouse before checking for button clicks, so
    ;; that button clicks get processed with knowledge of where the mouse
    ;; was when the button was first clicked.  The arguments to the move handler
    ;; may be where the mouse was when the button was clicked, whereas the
    ;; mouse cursor follows MOUSE-X and MOUSE-Y, which may be different.    
    (SETQ MOUSE-WARP NIL)
    (send window :mouse-moves-scroll window-x window-y)
    ;; Check for all the ways of losing control of the mouse.
    (IF (COND ;; The move handler may have decided to warp the mouse so that it will not
	  ;; move out of the window.  This test is a crock but should work.
	  (MOUSE-WARP NIL)
	  ;; Check for mouse ceasing to be grabbed.
	  ((EQ WINDOW T)
	   (NEQ WINDOW-OWNING-MOUSE T))
	  ;; Check for window becoming grabbed.
	  ((EQ WINDOW-OWNING-MOUSE T)
	   (NEQ WINDOW T))
	  ;; Check for some other window (not above this one) being greedy.
	  (WINDOW-OWNING-MOUSE
	   (NOT (SHEET-ME-OR-MY-KID-P WINDOW WINDOW-OWNING-MOUSE)))
	  ;; Check for moving into a window when not in any
	  ((NULL WINDOW)
	   (WINDOW-OWNING-MOUSE X Y))
	  ;; Check for leaving the boundaries of the current window
	  ;; HYSTERETIC-WINDOW-MIXIN requires that we wait at least once before returning
	  ((and (mx-p)
		;;; We can't warp the mouse on the MX when we end up in
		;;; a scroll bar, so be more lenient.
		(NOT (AND (SHEET-EXPOSED-P WINDOW)
			  ;;; When the mouse is outside the window the
			  ;;; values of window-x and window-y stay constant at
			  ;;; the edges of the window, so we need to calculate
			  ;;; a certain amount of hysteresis on our own.
			  (or (eq window (window-under-mouse))
			      (and (<= y (+ *mx-scroll-bar-tollerance*
					    window-y window-y-offset))
				   (<= x (+ *mx-scroll-bar-tollerance*
					    window-x window-x-offset)))
			  )
			  (>= WINDOW-X (- *mx-scroll-bar-tollerance*))
			  (<  WINDOW-X (+ *mx-scroll-bar-tollerance*
					  (SHEET-WIDTH WINDOW)))
			  (>= WINDOW-Y (- *mx-scroll-bar-tollerance*))
			  (<  WINDOW-Y (+ *mx-scroll-bar-tollerance*
					  (SHEET-HEIGHT WINDOW))))))
	   wait-flag)
	  ((and (not (mx-p))
		(NOT (AND (SHEET-EXPOSED-P WINDOW)
			  (>= WINDOW-X 0)
			  (<  WINDOW-X (SHEET-WIDTH WINDOW))
			  (>= WINDOW-Y 0)
			  (<  WINDOW-Y (SHEET-HEIGHT WINDOW)))))
	   WAIT-FLAG)
	  ;; Check for moving into an inferior of the current window
	  ((NEQ (LOWEST-SHEET-UNDER-POINT WINDOW WINDOW-X WINDOW-Y
					  ':HANDLE-MOUSE ':EXPOSED)
		WINDOW)
	   T))
	;; Return to overseer, saving any pending button click.
	(RETURN (MOUSE-DEFER-BUTTONS BU BD)))
    ;; Now process button pushes if mouse is not seized.
    (unless (OR (ZEROP BD) OLD-OWNER)
      (FUNCALL WINDOW :mouse-buttons-scroll BD WINDOW-X WINDOW-Y)
      (send window :update-scroll-bars))))

;;; ------------------------------scroll bar draw and erase functions ------------
(defun-method ver-scroll-bar-draw x-y-scroll-bars-mixin (&optional (1position* :left))
  (when (2Ver-Scroll-Bar* position) (send self :Erase-Ver-Scroll-Bar position))
  (let ((length (truncate (* height (/ (send self :inside-height) (send self :logical-height)))))
	(top (truncate (* height (/ (- y-pl-offset logical-top-edge) (send self :logical-height)))))) 
    (PREPARE-SHEET (SELF)
      ;; Erase anything there first.
      (%DRAW-RECTANGLE scroll-bar-thickness length
		       (1if* (1equal* Position :Left)
			   0
			   (1-* width scroll-bar-thickness)
		       )
		       top  alu-andca self)
      ;; Now we can draw the scroll bar.
      (%DRAW-RECTANGLE scroll-bar-thickness length
		       (1if* (1equal* Position :Left)
			   0
			   (1-* width scroll-bar-thickness)
		       )
		       top  alu-ior self))
    ;; make a record of the scroll bar so it can be erased correctly
    (setf (2Ver-Scroll-Bar* position)
	  (list top length scroll-bar-thickness))))

(defun-method ver-scroll-bar-erase x-y-scroll-bars-mixin (&optional (1position* :left))
  (when (2Ver-Scroll-Bar* position)
    (1destructuring-bind* (top length thickness)
		      (2Ver-Scroll-Bar* position)
      (PREPARE-SHEET (SELF)
	(%DRAW-RECTANGLE THickness length
			 (1if* (1equal* Position :Left)
			    0
			    (1-* width scroll-bar-thickness)
			 )
			 top ALU-andca SELF)
	(send self :refresh-margins)
	(setf (2Ver-Scroll-Bar* position) nil)))))


(defun-method hor-scroll-bar-draw x-y-scroll-bars-mixin (&optional (1position* :bottom))
  (when (2Hor-Scroll-Bar* position) (send self :Erase-Hor-Scroll-Bar position))
  (let ((length (truncate (* width (/ (send self :inside-width) (send self :logical-width)))))
	(left (truncate (* width (/ (- x-pl-offset logical-left-edge) (send self :logical-width)))))
       )
    (PREPARE-SHEET (SELF)
      ;; Erase anything there first.
      (%DRAW-RECTANGLE length scroll-bar-thickness left
		       (1if* (1equal* :Bottom position)
			  (- height scroll-bar-thickness)
			  0
		       )
		       ALU-ANDCA SELF)
      ;; Now we can draw the scroll bar.
      (%DRAW-RECTANGLE length scroll-bar-thickness left
		       (1if* (1equal* :Bottom position)
			  (- height scroll-bar-thickness)
			  0
		       )
		       ALU-ior SELF))
    ;; make a record of the scroll bar so it can be erased correctly
    (setf (2Hor-Scroll-Bar* position)
	  (list left length scroll-bar-thickness)
    )
  )
)

1;;;Edited by HASTINGS              13 Jun 87  2:21*
(defun-method hor-scroll-bar-erase x-y-scroll-bars-mixin (&optional (1position* :bottom))
  (when (2Hor-Scroll-Bar* position)
    (1destructuring-bind* (left length thickness)
		      (2Hor-Scroll-Bar* position)
      (PREPARE-SHEET (SELF)
	(%DRAW-RECTANGLE length Thickness left
			 (1if* (1equal* :Bottom position)
			     (- height scroll-bar-thickness)
			     0
		         )
			 ALU-andca SELF)
	(send self :refresh-margins)
	(setf (2Hor-Scroll-Bar* position) nil)))))

;;;-------------------------- overview-mixin -------------------------

(defflavor overview-mixin ((shrink-factor 1)
			   (overview-window)
			   (overview-inside-p t)
			   (inside-overview-window nil)
			   (outside-overview-window nil)
			  )
	   (always-deactivate-inferiors-mixin)
  (:required-flavors essential-x-y-scrolling-mixin
		     minimum-window)
  (:Initable-Instance-Variables overview-inside-p)
  (:Settable-Instance-Variables overview-inside-p)
  (:Gettable-Instance-Variables
    overview-window shrink-factor overview-inside-p
    inside-overview-window outside-overview-window 
  )
  (:Init-Keywords :outside-overview-initargs :inside-overview-initargs)
)

(defmethod (Overview-mixin :After :Set-overview-inside-p) (to)
  (ignore to)
  (send self :set-up-overview-window)
  (if overview-inside-p
      (if outside-overview-window
	  (process-run-function '(:name "deactivate" :priority 4)
			  #'(lambda (overview)
			      (send overview :deactivate)
			    )
			  outside-overview-window
          )
	  nil
      )
      (send self :Maybe-Show-Overview)
  )
)

(defmethod (Overview-mixin :Set-Up-Overview-Window)
	   (&optional (force-p nil) (outside-inits nil) (inside-inits nil))
  (if force-p
      (progn (setq inside-overview-window nil)
	     (setq outside-overview-window nil)
	     (setq overview-window nil)
      )
      nil
  )
  (if (not inside-overview-window)
      (setq inside-overview-window
	    (apply #'make-instance 'overview-window
		   :graph-window self
		   :superior self
		   inside-inits
	    )

      )
      nil
  )
  (if (not outside-overview-window)
      (progn (setq outside-overview-window
		   (apply #'make-instance
			  'simultaneous-overview-window
			  :graph-window self
			  :superior (send self :Superior)
			  :Height (send self :Height)
			  :Width (send self :Width)
			  :Activate-p t
			  :Expose-p nil
			  :Deexposed-Typeout-Action :permit
			  outside-inits
		   )
	     )
	     (if (member outside-inits
			 '(:Edges :Edges-From :position)
		 )
		 nil
		 (multiple-value-bind (Left Top Right Bottom)
		     (send self :Edges)
		   (w:position-window-next-to-rectangle
		     outside-overview-window '(:Above :Below :Left :right)
		     Left Top Right Bottom
		   )
		 )
	     )
      )
      nil
  )
  (setq Overview-Window
	(if overview-inside-p inside-overview-window outside-overview-window)
  )
)

(defmethod (overview-mixin :after :init) (plist)
  (let ((outside (getf (first plist) :outside-Overview-Initargs))
	(inside  (getf (first plist) :inside-Overview-Initargs))
       )
       (send self :Set-Up-Overview-Window nil outside inside)
  )
)						    

(defmethod (overview-mixin :after :change-of-size-or-margins) (&rest ignore)
  "set overwiew window's new edges also"
  (and overview-window 
       overview-inside-p
       (send overview-window :set-edges
	     (sheet-inside-left self)
	     (sheet-inside-top self)
	     (sheet-inside-right self)
	     (sheet-inside-bottom self))))

(1defmethod* (overview-mixin :After :Clear-Window) (&rest ignore)
  (1if* (1not* overview-inside-p)
     (1send* overview-window :Clear-Window)
     nil
  )
)

(defmethod (overview-mixin :mouse-click) (b ignore ignore)
  (case b
     (#\mouse-m-2
      (process-run-function
	'(:name "overview" :priority 2)
	#'(lambda (w)
	    (if (send w :Overview-Inside-P)
		(send w :show-overview))
	        (delaying-screen-management
		  (send (send w :Overview-Window) :Expose)
		  (send w :Show-Overview)
		)
	  )
	 self))))

(defmethod (overview-mixin :maybe-show-overview) ()
  (if (1or* (not overview-inside-p) (send overview-window :Exposed-P))
      (send self 3:Show-Overview*
	3    *(4and* (4send* 4self* 3:Exposed-P)*
		  (1Not* (send overview-window 3:Exposed-P))*
	3    )
      *)
      Nil
  )
)

(defparameter *inside-without-recursion* nil)

(defmacro without-recursion (&body body)
 `(if *inside-without-recursion* 
      :recursion-prevented
      (let ((*inside-without-recursion* t))
	   (declare (special *inside-without-recursion*))
	   ,@body
      )
  )
)

(defmethod (overview-mixin :show-overview) (&optional (expose-p t))
  (if (or (not overview-inside-p)
	   (typep self 'top-label-mixin)
	  (= 0 (label-top (send self :label)))
      )
      (send overview-window :Set-Label
	    (format nil "Overview of ~A" (sixth (send self :Label)))
      )
      (send overview-window :set-label "Overview of ")
  )
  (if overview-inside-p
     (1if* expose-p (send overview-window :expose) nil)
     (4if* expose-p (Without-Recursion (send overview-window 3:Expose))*)
  )
  (Setq shrink-factor (min (/ (send overview-window :inside-height)
			      (send self :logical-height))
			   (/ (send overview-window :inside-width)
			      (send self :logical-width))
			   1))
  (if overview-inside-p
      nil
      ;;; I think that this only really needs to be done if
      ;;; the logical origin changes, i.e. you drag scroll
      ;;; in such a way that areas that weren't previously
      ;;; within the bounds of the graph become so.  Thus
      ;;; if there is a performance problem a check should
      ;;; be put in here.
      (progn ;;; I don't understand why we need this here.
	     (setf (sheet-output-hold-flag Overview-Window) 0)
	     (4if* expose-p (1send* Overview-Window 3:Expose)* nil)
	     (Send Overview-Window :Clear-window))
  )
  (dolist (item item-list)
    (send item :draw-self-shrunken shrink-factor overview-window))
  (1send* self 3:Redraw-Blinker*)
)

(1defmethod* (2Overview-Mixin* :redraw-blinker) ()
  ;; draw the box that represents the graph window
  (let* ((left (truncate (* (- x-pl-offset logical-left-edge) shrink-factor)))
	 (right (truncate (* (+ (- x-pl-offset logical-left-edge)
				(send self :inside-width)) shrink-factor)))
	 (top (truncate (* (- y-pl-offset logical-top-edge) shrink-factor)))
	 (bottom (truncate (* (+ (- y-pl-offset logical-top-edge)
				 (send self :inside-height)) shrink-factor)))
	 (bwidth (- right left))
	 (bheight (- bottom top))
	 (box (send overview-window :box)))
    (blinker-set-cursorpos box left top)
    (blinker-set-size box bwidth bheight)
    (blinker-set-visibility box t))
)


(defmethod (overview-mixin :After :Kill) (&rest ignore)
  (if (1and* inside-Overview-Window (1typep* inside-Overview-Window 'sheet))
      (1catch-error* (send inside-Overview-Window :Kill) nil)
      nil
  )
  (if (1and* outside-Overview-Window (1typep* outside-Overview-Window 'sheet))
      (1catch-error* (send outside-Overview-Window :Kill) nil)
      nil
  )
)

(defmethod (overview-mixin :overlapped-by-overview-window-p) ()
  (or (and (>= (send self :X-Offset) (send outside-overview-window :X-Offset))
	   (<  (send outside-overview-window :X-Offset)
	       (+ (send self :X-Offset) (send self :Width))
	   )
      )
      (and (>= (send self :y-Offset) (send outside-overview-window :y-Offset))
	   (<  (send outside-overview-window :y-Offset)
	       (+ (send self :y-Offset) (send self :height))
           )
      )
  )
)

(defmethod (overview-mixin :After :expose) (&rest ignore)
  nil
)

(defmethod (overview-mixin :before :scroll-to) (x y &rest ignore)
  (ignore x y)
  (if (and Overview-Window (not overview-inside-p))
      (blinker-set-visibility (send overview-window :box) nil)
      nil
  )
)

(defmethod (overview-mixin :After :scroll-to) (x y &rest ignore)
  (ignore x y)
  (if (and Overview-Window (not overview-inside-p))
      (1send* self 3:Redraw-Blinker*)
      nil
  )
)

(defmethod (overview-mixin :After :refresh) (&optional type &rest ignore)
  (if (and (1not* (member type '(:Use-Saved-Bits :Use-Old-Bits)))
	   overview-window (not overview-inside-p))
      (send self :Maybe-Show-Overview)
      nil
  )
)


;-------------------------------------------------------------------------------

(defflavor overview-window (box ;is a blinker
			    (box-dragging-on nil)
			    graph-window
			    mouse-box-x-offset
			    mouse-box-y-offset)
	   (dont-select-with-mouse-mixin
	    save-superiors-bits-mixin
	    borders-mixin
	    label-mixin
	    w:graphics-mixin
	    stream-mixin
	    minimum-window)
  (:default-init-plist
    :label nil :blinker-p nil
    :Borders 0
    :deexposed-typeout-action :permit)
  (:gettable-instance-variables box)
  (:Settable-instance-variables box graph-window)
  (:initable-instance-variables graph-window))

(defflavor hollow-rectangular-stay-inside-blinker ()
	   (stay-inside-blinker-mixin hollow-rectangular-blinker))

(defmethod (overview-window :after :init) (&rest ignore)
  (setq box  (MAKE-BLINKER SELF 'hollow-rectangular-stay-inside-blinker 
				   :VISIBILITY NIL)))

(defmethod (overview-window :who-line-documentation-string) ()
  "2M: Hold down to drag box;  R: Scroll to the new position.*")

(defmethod (overview-window :after :handle-mouse) (&rest ignore)
  (if (neq self (window-under-mouse))
      (send self :turn-off-box-dragging)))

(defmethod (overview-window :mouse-click) (button x y)
  "If is a mouse-m then
   initiate the dragging"
    (case button
       (#\mouse-m (send self :turn-on-box-dragging x y) t)
       (#\mouse-r (send self :scroll-from-overview) t)))

(defmethod (overview-window :scroll-from-overview) ()
  (let ((logical-x (truncate (+ (/ (send box :x-pos) (send graph-window :shrink-factor))
				(send graph-window :logical-left-edge))))
	(logical-y (truncate (+ (/ (send box :y-pos) (send graph-window :shrink-factor))
				(send graph-window :logical-top-edge)))))
  ;;we have to deactivate and scroll in another process or the mouse process
  ;;sometimes blocks in window lock forever.
    (process-run-function '(:name "deactivate and scroll" :priority 4)
			  #'(lambda (overview graph lx ly)
			      (1send* 2Overview* :Clear-Window)
			      (1send* overview :Set-Label nil)
			      (1send* overview :Deexpose)
			      (send overview :deactivate)
			      (send graph :scroll-to lx ly))
			  self graph-window logical-x logical-y)
    ;;give this other process a chance.
    (process-sleep 2)))

(defmethod (overview-window :after :mouse-moves) (x y)
  (cond (box-dragging-on
	 (cond ((= (mouse-buttons) 2)		;1middle still down*
		(send self :move-box-to (+ x mouse-box-x-offset) (+ y mouse-box-y-offset))
		;;update the offsets, 1they might have changed if the movement fo*r1 the box was truncated.*
		(setq mouse-box-x-offset (- (send box :x-pos) (+ x (sheet-inside-left self)))
		      mouse-box-y-offset (- (send box :y-pos) (+ y (sheet-inside-top self))))
		)
	       (t				;1else turn off dragging*
		(send self :turn-off-box-dragging))))))

(defmethod (overview-window :move-box-to) (x y)
    (blinker-set-cursorpos box x y))
  
(defmethod (overview-window :turn-off-box-dragging) ()
  (setq box-dragging-on nil))

(defmethod (overview-window :turn-on-box-dragging) (x y)
  "record the mouse-box-offsets, and set the flag"
  ;(format self "~a ~a ~a ~a ~%" x y (send box :x-pos) (send box :y-pos))
  (setq mouse-box-x-offset (- (send box :x-pos) x)
	mouse-box-y-offset (- (send box :y-pos) y)
	box-dragging-on t))

(defmethod (overview-window :After :refresh) (&optional (type nil) &rest ignore)
  (if (and graph-window (send graph-window :Overview-Window)
	   (not (send graph-window :Overview-Inside-P))
	   (1not* (1member* type '(:Use-Old-Bits)))
      )
      (send graph-window :Maybe-Show-Overview)
      nil
  )
)

;-------------------------------------------------------------------------------

(defflavor simultaneous-overview-window ()
	   (select-mixin Overview-Window)
  (:default-init-plist
    :label nil
    :blinker-p nil
    :Save-Bits t
    :Borders 1
    :save-superiors-bits-active-p nil
    :deexposed-typeout-action :permit)
)


(defmethod (simultaneous-overview-window :Scroll-From-Overview) ()
  (let ((logical-x (truncate (+ (/ (send box :x-pos) (send graph-window :shrink-factor))
				(send graph-window :logical-left-edge))))
	(logical-y (truncate (+ (/ (send box :y-pos) (send graph-window :shrink-factor))
				(send graph-window :logical-top-edge)))))
  ;;we have to deactivate and scroll in another process or the mouse process sometimes
  ;;blocks in window lock forever.
    (process-run-function '(:name "deactivate and scroll" :priority 4)
			  #'(lambda (overview graph lx ly)
			      (ignore overview)
			      (send graph :scroll-to lx ly))
			  self graph-window logical-x logical-y)
    ;;give this other process a chance.
    (process-sleep 2)))

;-------------------------------------------------------------------------------

(defmethod (scrollable-line-item :draw-self-shrunken) (shrink-factor overview-window)
  (1let* ((from-x- (truncate (* (- from-x (send window :logical-left-edge)) shrink-factor)))
       (from-y- (truncate (* (- from-y (send window :logical-top-edge)) shrink-factor)))
       (to-x- (truncate (* (- to-x (send window :logical-left-edge)) shrink-factor)))
       (to-y- (truncate (* (- to-y (send window :logical-top-edge)) shrink-factor)))
      )
      (1if* visible-p
	 (send overview-window :Draw-Line from-x- from-y- to-x- to-y-)
	 (send overview-window :draw-dashed-line from-x- from-y- to-x- to-y-)
      )
  )
)

(defflavor always-deactivate-inferiors-mixin ()
	   ())

(defmethod (always-deactivate-inferiors-mixin :after :deexpose) (&rest ignore)
  (dolist (inferior (send self :inferiors))
    (send inferior :deactivate)))   



;1; this flavor adapted from Rich Acuff's temporary-typeout-window-mixin*

(defflavor save-superiors-bits-mixin
	   ((bits-covered?)
	    (save-superiors-bits-active-p t)
	    (covered-bits))
	   ()
  (:required-flavors essential-window)
  (:Initable-Instance-Variables save-superiors-bits-active-p)
  (:Settable-Instance-Variables save-superiors-bits-active-p)
)


(defmethod (save-superiors-bits-mixin :after :deexpose) (&rest ignore)
  "Restore the bits of our superior."
  (when (and save-superiors-bits-active-p bits-covered?)
    (sheet-force-access (superior t)
      (bitblt alu-seta width height
	      covered-bits 0 0
	      (sheet-screen-array superior) x-offset y-offset))
    (setf bits-covered? nil)
    )
  )

(defmethod (save-superiors-bits-mixin :before :expose)
	   (&rest ignore)
  "Save the bits of our superior"
  (if save-superiors-bits-active-p
      (progn
	(if covered-bits			   ;been created yet?
	    ;; yes, then make sure it's big enough
	    (let ((save-height (array-dimension covered-bits 0))
		  (save-width (array-dimension covered-bits 1)))
	      (when (or (< save-height height)   ;need to grow?
			(< save-width width))
		(grow-bit-array covered-bits width height width
				save-height save-width nil)
		)
	      )
	    ;; nothing yet, make one
	    (setf covered-bits (make-sheet-bit-array self width height))
	    )
	;; Save the old stuff if it's there
	(when (sheet-screen-array superior)
	  (prepare-sheet (superior)
	    (bitblt alu-seta width height
		  (sheet-screen-array superior) x-offset y-offset
		  covered-bits 0 0)
	  ;; Remember we've saved something
	  (setf bits-covered? t))))
      nil))
  

;;; -------------------- mouse sensitivity -------------------------------

1;;;Edited by Reed Hastings         10 Jul 87  9:49*
(defflavor 2Mouse-Sensitivity-For-Instances-Mixin*
	   ((item-type-alist nil)  ;Associates actions with types of items
	    menu	 	   ;For when item clicked on with right button
	    item-blinker 
	    (mouse-sensitive-types :all)
	    (currently-boxed-item nil)) 		
	   ()
  (:settable-instance-variables item-type-alist mouse-sensitive-types)
  (:initable-instance-variables item-type-alist mouse-sensitive-types)
  (:gettable-instance-variables item-blinker currently-boxed-item)
  (:required-flavors essential-x-y-scrolling-mixin))

(defmethod (mouse-sensitivity-for-instances-mixin :after :init) (ignore)
  "2Make a pop-up menu.*"
  (SETQ	MENU (MAKE-WINDOW 'MOMENTARY-MENU ':SUPERIOR SELF)
	item-blinker (MAKE-BLINKER SELF 'HOLLOW-RECTANGULAR-BLINKER
				   :VISIBILITY NIL)))

(defmethod (mouse-sensitivity-for-instances-mixin :after :handle-mouse)
	   (&rest ignore)
  (when currently-boxed-item
    (send currently-boxed-item :erase-boxing)
    (setq currently-boxed-item nil)))

(defmethod (mouse-sensitivity-for-instances-mixin :current-mouse-sensitve-type-p) (type)
  (or (eql mouse-sensitive-types :Override)
      (and (or (eql mouse-sensitive-types :all)
	       (and (listp mouse-sensitive-types)
		    (member type mouse-sensitive-types)))
	   (assoc type item-type-alist :test #'eq))))

1;;;Edited by Reed Hastings         24 Sep 87  22:12*
(defmethod (mouse-sensitivity-for-instances-mixin :after :mouse-moves) (x y)  ;;x and y are in outside coordinates
  "display the boxing around the item under the mouse cursor"
  (unless (send self :dragging-screen-p)
    (let ((logical-mouse-x (- (+ x x-pl-offset) (sheet-inside-left self)))
	  (logical-mouse-y (- (+ y y-pl-offset) (sheet-inside-top self))))
      (cond (;; if scrolling is in, erase any boxing
	     (or hor-scrolling-in-effect ver-scrolling-in-effect)
	     (and currently-boxed-item (send currently-boxed-item :erase-boxing))
	     (setq currently-boxed-item nil))
	    ((not currently-boxed-item) ;; if nothing is boxed, look for something.
	     (dolist (item item-list)
	       (if (send item :draw-boxing-maybe logical-mouse-x logical-mouse-y)
		   (return (setq currently-boxed-item item)))))
	    ((send currently-boxed-item :boxing-appropriate-p logical-mouse-x logical-mouse-y))	;then do nothing
	    (t (send currently-boxed-item :erase-boxing)	;else we must have moved off the currently-boxed-item
	       (setq currently-boxed-item nil))))))


(defmethod (mouse-sensitivity-for-instances-mixin :who-line-documentation-string) ()
  (when currently-boxed-item
    (let ((documentation (third (assoc (send currently-boxed-item :mouse-sensitive-type) item-type-alist :test #'eq))))
      (COND ((STRINGP documentation) documentation)
	    ((CONSP 2  *documentation)
	     (FUNCALL (car documentation) (send currently-boxed-item :item)))))))


(defmethod (mouse-sensitivity-for-instances-mixin :mouse-click) (button ignore ignore)
  "2Mouse-left selects the blinking item, mouse-right pops up a menu
near it.*"
  ;;this code filched from basic-mouse-sensitive-items
  (when currently-boxed-item
    (LET ((ITEM-TYPE (assoc (send currently-boxed-item :mouse-sensitive-type) item-TYPE-ALIST :test #'eq)))
      (WHEN ITEM-TYPE
	(case button
	  (#\MOUSE-L-1
	   ;; Form the blip and stuff it into the keyboard buffer.
	   (SEND SELF ':FORCE-KBD-INPUT
			 (LIST ':TYPEOUT-EXECUTE (CADR ITEM-TYPE) (send currently-boxed-item :item) currently-boxed-item)))
	  (#\MOUSE-R-1
	   (PROCESS-RUN-FUNCTION
	     "Menu Choose" #'CHOOSE-an-operation
	     menu (CDDDR ITEM-TYPE) self currently-boxed-item
	     ;; Compute a label for the menu.
	     (OR (AND (CONSP (THIRD item-TYPE))
		      (CADR (THIRD item-TYPE))
		      (FUNCALL (CADR (THIRD item-TYPE))
			       (send currently-boxed-item :item)))))))))))



(DEFUN CHOOSE-an-operation (menu ALIST window item MENU-LABEL)
;;code from typeout-menu-choose
   "2Select a thing to do to mouse-sensitive item TYPEOUT-ITEM.*
  2ALIST*			2menu item-list to be displayed in MENU.*
  item                    is an instance of a scrollable-item
  2MENU-LABEL*		2a string to display as the menu's label, or NIL*
			  2for no label.*
  2The user's choice is processed by forcing input* 2of the same sort as is*
  2done by clicking left on the typeout-item,* ie like:
	2(:TYPEOUT-EXECUTE operation item-information).*"
  (LET ((old-x mouse-x)				;1PDC 12/10/85*
	(old-y mouse-y))
    (FUNCALL MENU ':SET-LABEL MENU-LABEL)
    (FUNCALL MENU ':SET-ITEM-LIST ALIST)
    (MOVE-WINDOW-NEAR-RECTANGLE MENU  ;; put the following in physcial coordinates.
				(- (send item :left-edge)(send window :x-pl-offset))
				(- (send item :top-edge) (send window :y-pl-offset))
				(- (send item :right-edge) (send window :x-pl-offset))
				(- (send item :bottom-edge) (send window :y-pl-offset)))
    (LET ((CHOICE-RESULT (FUNCALL MENU ':CHOOSE)))
      (AND CHOICE-RESULT
	   (FUNCALL window :FORCE-KBD-INPUT
		    (LIST :TYPEOUT-EXECUTE CHOICE-RESULT
			  (send item :item) item))))
    (ignore old-x old-y)	;reed. 1/87
;    (SETQ mouse-x old-x				;1PDC 12/10/85*
;	  mouse-y old-y)
    (mouse-standard-blinker window)		;reed. 1/87
    (SEND window :mouse-moves mouse-x mouse-y)))



;;;------------------ basic-mouse-sensitive-items-compatibility-mixin ---------------

(defflavor basic-mouse-sensitive-items-compatibility-mixin () ()
  (:required-instance-variables cursor-x cursor-y item-list))


(defmethod (basic-mouse-sensitive-items-compatibility-mixin  :item) (type item &rest args)
  "Does the same as basic-mouse-sensitive-items :item method. ie. it outputs a mouse
   sensitive item at the cursor."
  
  ;; that ol' &rest bug. the lambda exp. blows up later on.
  (setq args (copy-list args))
  (cond ((not args)
	 (send self :scrollable-text-item item
	       :mouse-sensitive-type type
	       :coordinate-type :physical
	       :Pre-Print-Item-Modify-Function
	       #'(lambda (item)
		   (etypecase item
		     (string item)
		     (symbol (symbol-name item))
		     (instance (send item :string-for-printing)))))
	 (princ item self)) ;print it again just to move the cursor over.
	(t (send self :scrollable-text-item item
		 :mouse-sensitive-type type
		 :coordinate-type :physical
		 :pre-print-item-modify-function
		 #'(lambda (ignore)
		     (apply #'format nil args)))
	   (apply #'format self args)))) ;print it again just to move the cursor over.



(defmethod (basic-mouse-sensitive-items-compatibility-mixin  :extended-item) (type item &rest args)
  (apply self :item type item args))


(defmethod (basic-mouse-sensitive-items-compatibility-mixin  :after :clear-screen) ()
  (send self :re-initialize))


;;;---------------------------- ver-auto-scrolling-mixin ----------------------------------------


(defflavor ver-auto-scrolling-mixin ((increment :half)
				     pixel-increment)
	   ()
  (:required-methods :scroll-to)
  (:required-flavors sheet)
  (:gettable-instance-variables increment)
  (:settable-instance-variables increment)
  (:initable-instance-variables increment)
  )

(defmethod (ver-auto-scrolling-mixin :after :init) (&rest ignore)
  (send self :verify-n-set-pixel-increment))

(defmethod (ver-auto-scrolling-mixin :after :change-of-size-or-margins) (&rest ignore)
  (send self :verify-n-set-pixel-increment))

(defmethod (ver-auto-scrolling-mixin :set-increment) (new-increment-value)
  "new-value can be a number in pixels, or one of the keywords:
  :whole :half :quarter. Increment is
  truncated to a multiple of the line height"
  (setq increment new-increment-value)
  (send self :verify-n-set-pixel-increment))

(defmethod (ver-auto-scrolling-mixin :verify-n-set-pixel-increment) ()
  (case increment
     (:whole (setq pixel-increment (send self :inside-height)))
     (:half (setq pixel-increment (truncate (send self :inside-height) 2)))
     (:quarter (setq pixel-increment (truncate (send self :inside-height) 4))))
  (unless (< 0 pixel-increment (send self :inside-height))
    (cerror "continue with the increment set to half the window height"
	    "the scrolling increment, ~a, is not between 0 and the window height, ~a."
	    pixel-increment (send self :inside-height))
    (if (not (< 0 pixel-increment (send self :inside-height)))
	(setq pixel-increment (truncate (send self :inside-height) 2)))))

(defmethod (ver-auto-scrolling-mixin :end-of-page-exception) ()
  "redifines sheet's :end-of-page-exception method to scroll up by
  increment."
  (COND ((NOT (ZEROP (SHEET-END-PAGE-FLAG)))
	 (LET ((M-VP MORE-VPOS))
	   ;; do the next two things instead of (sheet-home self)
	   (send self :scroll-relative
		 0		              
		 pixel-increment	                      
		 nil)				;nil means expand the logical window
	   (SETF (SHEET-EXCEPTIONS self) 0)
	   (SHEET-CLEAR-EOL SELF)
	   ;; Arrange for more processing next time around
	   (COND ((NULL M-VP))			;No more processing at all
		 ((>= M-VP 100000)		;More processing delayed?
		  (SETQ MORE-VPOS (- M-VP 100000)))	;Cause to happen next
						; time around.
		 (T (SETQ MORE-VPOS (SHEET-DEDUCE-MORE-VPOS SELF))))))))



;;----------------------------- speed initial window creation up -------------


(compile-flavor-methods basic-x-y-scrolling-window)