;;; -*- Mode:LISP; Package:TV; Base:8 -*-
;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;;; The screen editor

(DEFUN MOUSE-SPECIFY-RECTANGLE (&OPTIONAL LEFT TOP RIGHT BOTTOM (SHEET MOUSE-SHEET)
					  (MINIMUM-WIDTH 0) (MINIMUM-HEIGHT 0)
				&AUX LEFT1 TOP1 WIDTH HEIGHT)
"Call this and get back a rectangle as four values: left, top, right, bottom.
The user uses the mouse to specify the rectangle.
Specifying a rectangle of zero or negative size instead gives the full screen.
Our arguments are where to start the corners out:
The upper left corner goes at LEFT and TOP, or where the mouse is if they are NIL;
the lower right corner goes near the other one by default, unless all
four args are present, in which case it starts off so as to make a rectangle
congruent to the one specified by the arguments.
SHEET specifies the area within which we are allowed to act."
  (AND (EQ CURRENT-PROCESS MOUSE-PROCESS)
       (FERROR NIL "MOUSE-SPECIFY-RECTANGLE cannot be called in the mouse process"))
  (OR (SHEET-ME-OR-MY-KID-P SHEET MOUSE-SHEET)
      (FERROR NIL
	"MOUSE-SPECIFY-RECTANGLE attempted on ~S which is not inferior of MOUSE-SHEET"
	SHEET))
  (WITH-MOUSE-GRABBED
    (DO () (NIL)
      (MOUSE-SET-BLINKER-DEFINITION ':CHARACTER 0 0 ':ON
				    ':SET-CHARACTER 21)
      (MOUSE-WARP (OR LEFT MOUSE-X) (OR TOP MOUSE-Y))
      ;; In case this was called in response to a mouse click, wait for
      ;; the buttons to be released.
      (PROCESS-WAIT "Release Button" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
      (PROCESS-WAIT "Button" #'(LAMBDA () (NOT (ZEROP MOUSE-LAST-BUTTONS))))
      (PROCESS-WAIT "Release Button" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
      ;; The first click determines the upper left corner.
      (SETQ LEFT1 MOUSE-X TOP1 MOUSE-Y)
      ;; Set up the mouse for finding the lower right corner.
      (MOUSE-SET-BLINKER-DEFINITION ':CHARACTER 12. 12. ':ON
				    ':SET-CHARACTER 22)
      (COND ((AND LEFT TOP RIGHT BOTTOM)
	     (MOUSE-WARP (+ LEFT1 (- RIGHT LEFT)) (+ TOP1 (- BOTTOM TOP))))
	    (T (MOUSE-WARP (+ MOUSE-X 20.) (+ MOUSE-Y 20.))))
      ;; Leave the auxiliary blinker behind to continue to show the first corner.
      (LET ((MOUSE-RECTANGLE-BLINKER (MOUSE-GET-BLINKER ':RECTANGLE-BLINKER)))
	(UNWIND-PROTECT
	  (PROGN
	    (BLINKER-SET-CURSORPOS MOUSE-RECTANGLE-BLINKER LEFT1 TOP1)
	    (BLINKER-SET-VISIBILITY MOUSE-RECTANGLE-BLINKER T)
	    ;; The next click fixes the lower right corner.
	    (PROCESS-WAIT "Button" #'(LAMBDA () (NOT (ZEROP MOUSE-LAST-BUTTONS)))))
	  (BLINKER-SET-VISIBILITY MOUSE-RECTANGLE-BLINKER NIL)))
      (MOUSE-STANDARD-BLINKER)
      (SETQ WIDTH (- (1+ MOUSE-X) LEFT1)
	    HEIGHT (- (1+ MOUSE-Y) TOP1))
      (COND ((AND (PLUSP WIDTH) (PLUSP HEIGHT))
	     (MULTIPLE-VALUE-BIND (XOFF YOFF)
		 (SHEET-CALCULATE-OFFSETS SHEET MOUSE-SHEET)
	       (SETQ LEFT1 (- LEFT1 XOFF)
		     TOP1 (- TOP1 YOFF)))
	     (IF (OR (< WIDTH MINIMUM-WIDTH) (< HEIGHT MINIMUM-HEIGHT)
		     (MINUSP LEFT1) (MINUSP TOP1)
		     (> (+ LEFT1 WIDTH) (SHEET-WIDTH SHEET))
		     (> (+ TOP1 HEIGHT) (SHEET-HEIGHT SHEET)))
		 (BEEP)
		 (RETURN NIL)))
	    (T (SETQ LEFT1 (SHEET-INSIDE-LEFT SHEET)
		     TOP1 (SHEET-INSIDE-TOP SHEET)
		     WIDTH (SHEET-INSIDE-WIDTH SHEET)
		     HEIGHT (SHEET-INSIDE-HEIGHT SHEET))
	       (RETURN NIL)))))
  (PROG () (RETURN LEFT1 TOP1 (+ LEFT1 WIDTH) (+ TOP1 HEIGHT))))

;;; Put a window someplace using the mouse
(DEFUN MOUSE-SET-WINDOW-SIZE (WINDOW &OPTIONAL (MOVE-P T) &AUX LEFT TOP RIGHT BOTTOM)
  (DECLARE (RETURN-LIST LEFT TOP RIGHT BOTTOM))
  (MULTIPLE-VALUE (LEFT TOP)
    (SHEET-CALCULATE-OFFSETS WINDOW MOUSE-SHEET))
  (SETQ RIGHT (+ LEFT (SHEET-WIDTH WINDOW))
	BOTTOM (+ TOP (SHEET-HEIGHT WINDOW)))
  (DO () (())
    (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM)
      (MOUSE-SPECIFY-RECTANGLE LEFT TOP RIGHT BOTTOM (SHEET-SUPERIOR WINDOW)))
    (IF (FUNCALL WINDOW ':SET-EDGES LEFT TOP RIGHT BOTTOM ':VERIFY)
	(RETURN T)
	(BEEP)))
  (AND MOVE-P (FUNCALL WINDOW ':SET-EDGES LEFT TOP RIGHT BOTTOM))
  (PROG () (RETURN LEFT TOP RIGHT BOTTOM)))


(DEFFLAVOR MOUSE-BOX-BLINKER () (MOUSE-BLINKER-MIXIN BOX-BLINKER))
(COMPILE-FLAVOR-METHODS MOUSE-BOX-BLINKER)
(MOUSE-DEFINE-BLINKER-TYPE ':BOX-BLINKER
			   #'(LAMBDA (SCREEN)
			       (DEFINE-BLINKER SCREEN 'MOUSE-BOX-BLINKER
				 ':VISIBILITY NIL)))

;;; Move a window around using the mouse
;;; If MOVE-P is NIL move just an outline of it and return where it would have moved to
(DEFUN MOUSE-SET-WINDOW-POSITION (WINDOW &OPTIONAL (MOVE-P T)
					 &AUX (SUPERIOR (SHEET-SUPERIOR WINDOW))
				      (X (SHEET-X WINDOW))
				      (Y (SHEET-Y WINDOW))
				      XOFF YOFF)
  (DECLARE (RETURN-LIST X Y))
  (OR (SHEET-ME-OR-MY-KID-P WINDOW MOUSE-SHEET)
      (FERROR NIL "Attempt to set position of ~S, which is not inferior to MOUSE-SHEET"
	      WINDOW))
  (MULTIPLE-VALUE (XOFF YOFF)
    (SHEET-CALCULATE-OFFSETS SUPERIOR MOUSE-SHEET))
  (WITH-MOUSE-GRABBED
    (WITHOUT-INTERRUPTS
	    (MOUSE-SET-BLINKER-DEFINITION ':BOX-BLINKER 0 0 NIL
					  ':SET-SIZE (SHEET-WIDTH WINDOW)
					             (SHEET-HEIGHT WINDOW))
	    (MOUSE-WARP (+ X XOFF) (+ Y YOFF)))
    (BLINKER-SET-VISIBILITY MOUSE-BLINKER T)
    (DO () (NIL)
      ;; In case this was called in response to a mouse click, wait for
      ;; the buttons to be released.
      (PROCESS-WAIT "Release Button" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
      (PROCESS-WAIT "Button" #'(LAMBDA () (NOT (ZEROP MOUSE-LAST-BUTTONS))))
      (PROCESS-WAIT "Release Button" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
      (SETQ X (- MOUSE-X XOFF)
	    Y (- MOUSE-Y YOFF))
      ;; If trying to move off screen, most reasonable thing to do is to
      ;; warp it back onto the screen.
      (SETQ X (MIN (- (SHEET-WIDTH SUPERIOR) (SHEET-WIDTH WINDOW)) X)
	    Y (MIN (- (SHEET-HEIGHT SUPERIOR) (SHEET-HEIGHT WINDOW)) Y))
      (IF (FUNCALL WINDOW ':SET-POSITION X Y ':VERIFY)
	  (RETURN (BLINKER-SET-VISIBILITY MOUSE-BLINKER NIL))
 	  (BEEP))))
  (IF MOVE-P (FUNCALL WINDOW ':SET-POSITION X Y))
  (PROG () (RETURN X Y)))

(DEFUN EXPAND-WINDOW (WINDOW &OPTIONAL (MOVE-P T)
			     &AUX SUPERIOR SIBLINGS LEFT TOP RIGHT BOTTOM)
  (DECLARE (RETURN-LIST LEFT TOP RIGHT BOTTOM))
  (SETQ SUPERIOR (SHEET-SUPERIOR WINDOW)
	SIBLINGS (SHEET-EXPOSED-INFERIORS SUPERIOR)
	LEFT (SHEET-X-OFFSET WINDOW)
	TOP (SHEET-Y-OFFSET WINDOW)
	RIGHT (+ LEFT (SHEET-WIDTH WINDOW))
	BOTTOM (+ TOP (SHEET-HEIGHT WINDOW)))
  ;;Expand to the left and right
  (LET ((MAX-LEFT (SHEET-INSIDE-LEFT SUPERIOR))
	(MAX-RIGHT (SHEET-INSIDE-RIGHT SUPERIOR)))
    (DOLIST (W SIBLINGS)
      (AND (SHEET-OVERLAPS-EDGES-P W MAX-LEFT TOP LEFT BOTTOM)
	   (SETQ MAX-LEFT (+ (SHEET-X-OFFSET W) (SHEET-WIDTH W))))
      (AND (SHEET-OVERLAPS-EDGES-P W RIGHT TOP MAX-RIGHT BOTTOM)
	   (SETQ MAX-RIGHT (SHEET-X-OFFSET W))))
    (SETQ LEFT MAX-LEFT
	  RIGHT MAX-RIGHT))
  ;;Expand to the top and bottom
  (LET ((MAX-TOP (SHEET-INSIDE-TOP SUPERIOR))
	(MAX-BOTTOM (SHEET-INSIDE-BOTTOM SUPERIOR)))
    (DOLIST (W SIBLINGS)
      (AND (SHEET-OVERLAPS-EDGES-P W LEFT MAX-TOP RIGHT TOP)
	   (SETQ MAX-TOP (+ (SHEET-Y-OFFSET W) (SHEET-HEIGHT W))))
      (AND (SHEET-OVERLAPS-EDGES-P W LEFT BOTTOM RIGHT MAX-BOTTOM)
	   (SETQ MAX-BOTTOM (SHEET-Y-OFFSET W))))
    (SETQ TOP MAX-TOP
	  BOTTOM MAX-BOTTOM))
  (AND MOVE-P (FUNCALL WINDOW ':SET-EDGES LEFT TOP RIGHT BOTTOM))
  (PROG () (RETURN LEFT TOP RIGHT BOTTOM)))

;;;The hairy window whitespace reclaimer
(DEFSTRUCT (EXPAND-WINDOWS-ITEM :LIST (:CONSTRUCTOR NIL))
  EXPAND-WINDOWS-WINDOW
  EXPAND-WINDOWS-LEFT
  EXPAND-WINDOWS-TOP
  EXPAND-WINDOWS-RIGHT
  EXPAND-WINDOWS-BOTTOM
  EXPAND-WINDOWS-LEFT-TOP-WINNERS
  EXPAND-WINDOWS-RIGHT-BOTTOM-WINNERS
  EXPAND-WINDOWS-MAX-LEFT-TOP
  EXPAND-WINDOWS-MAX-RIGHT-BOTTOM)

(DEFUN EXPAND-WINDOWS (TOP-WINDOW &AUX WINDOW-LIST)
  (SETQ WINDOW-LIST (MAPCAR #'(LAMBDA (W &AUX LEFT TOP)
				(LIST W
				      (SETQ LEFT (SHEET-X-OFFSET W))
				      (SETQ TOP (SHEET-Y-OFFSET W))
				      (+ LEFT (SHEET-WIDTH W))
				      (+ TOP (SHEET-HEIGHT W))
				      NIL NIL NIL NIL))
			    (SHEET-EXPOSED-INFERIORS TOP-WINDOW)))
  (EXPAND-WINDOWS-LEFT-AND-RIGHT TOP-WINDOW WINDOW-LIST)
  (EXPAND-WINDOWS-TOP-AND-BOTTOM TOP-WINDOW WINDOW-LIST)
  ;;Now we are ready to set all the edges
  (DELAYING-SCREEN-MANAGEMENT
    (DOLIST (ITEM WINDOW-LIST)
      (FUNCALL (EXPAND-WINDOWS-WINDOW ITEM) ':SET-EDGES
	       (EXPAND-WINDOWS-LEFT ITEM) (EXPAND-WINDOWS-TOP ITEM)
	       (EXPAND-WINDOWS-RIGHT ITEM) (EXPAND-WINDOWS-BOTTOM ITEM)))))

;;;Expand the lefts and rights
(DEFUN EXPAND-WINDOWS-LEFT-AND-RIGHT (TOP-WINDOW WINDOW-LIST)
  (DO ((L WINDOW-LIST (CDR L))
       (ITEM)
       (SUPERIOR-INSIDE-LEFT (SHEET-INSIDE-LEFT TOP-WINDOW))
       (SUPERIOR-INSIDE-RIGHT (SHEET-INSIDE-RIGHT TOP-WINDOW)))
      ((NULL L))
    (SETQ ITEM (CAR L))
    (DO ((L WINDOW-LIST (CDR L))
	 (NITEM)
	 (LEFT (EXPAND-WINDOWS-LEFT ITEM))
	 (TOP (EXPAND-WINDOWS-TOP ITEM))
	 (RIGHT (EXPAND-WINDOWS-RIGHT ITEM))
	 (BOTTOM (EXPAND-WINDOWS-BOTTOM ITEM))
	 (MAX-LEFT SUPERIOR-INSIDE-LEFT)
	 (MAX-RIGHT SUPERIOR-INSIDE-RIGHT)
	 (LEFT-WINNERS)
	 (RIGHT-WINNERS)
	 (NITEM-LEFT)
	 (NITEM-RIGHT))
	((NULL L)
	 (SETF (EXPAND-WINDOWS-LEFT-TOP-WINNERS ITEM) LEFT-WINNERS)
	 (SETF (EXPAND-WINDOWS-RIGHT-BOTTOM-WINNERS ITEM) RIGHT-WINNERS)
	 (SETF (EXPAND-WINDOWS-MAX-LEFT-TOP ITEM) MAX-LEFT)
	 (SETF (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM ITEM) MAX-RIGHT))
      (OR (EQ ITEM (SETQ NITEM (CAR L)))		;For all other windows
	  (> TOP (EXPAND-WINDOWS-BOTTOM NITEM))		;Which share some space on y
	  (< BOTTOM (EXPAND-WINDOWS-TOP NITEM))
	  (COND (( LEFT (SETQ NITEM-RIGHT (EXPAND-WINDOWS-RIGHT NITEM)))
		 (AND ( NITEM-RIGHT MAX-LEFT)
		      (IF (= NITEM-RIGHT MAX-LEFT)	;More than one window along the edge
			  (PUSH NITEM LEFT-WINNERS)
			  (SETQ MAX-LEFT NITEM-RIGHT
				LEFT-WINNERS (LIST NITEM)))))
		(( RIGHT (SETQ NITEM-LEFT (EXPAND-WINDOWS-LEFT NITEM)))
		 (AND ( NITEM-LEFT MAX-RIGHT)
		      (IF (= NITEM-LEFT MAX-RIGHT)
			  (PUSH NITEM RIGHT-WINNERS)
			  (SETQ MAX-RIGHT NITEM-LEFT
				RIGHT-WINNERS (LIST NITEM)))))))))
  (DOLIST (ITEM WINDOW-LIST)
    (LET ((WINDOW (EXPAND-WINDOWS-WINDOW ITEM))
	  (LEFT (EXPAND-WINDOWS-LEFT ITEM))
	  (TOP (EXPAND-WINDOWS-TOP ITEM))
	  (RIGHT (EXPAND-WINDOWS-RIGHT ITEM))
	  (BOTTOM (EXPAND-WINDOWS-BOTTOM ITEM))
	  (MAX-LEFT (EXPAND-WINDOWS-MAX-LEFT-TOP ITEM))
	  (MAX-RIGHT (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM ITEM))
	  (LEFT-WINNERS (EXPAND-WINDOWS-LEFT-TOP-WINNERS ITEM))
	  (RIGHT-WINNERS (EXPAND-WINDOWS-RIGHT-BOTTOM-WINNERS ITEM)))
      (AND ( MAX-LEFT LEFT)				;If not already adjacent
	   (LET ((WINNERS-MAX-RIGHT (AND LEFT-WINNERS
					 (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM
					   (CAR LEFT-WINNERS))))
		 (LEFT-MIDDLE (+ MAX-LEFT (// (- LEFT MAX-LEFT) 2))))
	     (AND WINNERS-MAX-RIGHT (SETQ LEFT-MIDDLE (MIN LEFT-MIDDLE WINNERS-MAX-RIGHT)))
	     (IF (AND LEFT-WINNERS (NOT (FUNCALL WINDOW ':SET-EDGES LEFT-MIDDLE TOP
						 RIGHT BOTTOM ':VERIFY)))
		 ;;This window will not move, get as many of the others as will allow
		 (DOLIST (LEFT-WINNER LEFT-WINNERS)
		   (AND (FUNCALL (EXPAND-WINDOWS-WINDOW LEFT-WINNER) ':SET-EDGES
				 (EXPAND-WINDOWS-LEFT LEFT-WINNER)
				 (EXPAND-WINDOWS-TOP LEFT-WINNER)
				 WINNERS-MAX-RIGHT
				 (EXPAND-WINDOWS-BOTTOM LEFT-WINNER)
				 ':VERIFY)
			(SET-EXPAND-WINDOWS-RIGHT LEFT-WINNER WINNERS-MAX-RIGHT)))
		 ;;Otherwise expand this window left
		 (IF (AND (OR (NULL LEFT-WINNERS)	;If no windows to the left,
			      (DOLIST (LEFT-WINNER LEFT-WINNERS)	;or some won't budge
				(OR (FUNCALL (EXPAND-WINDOWS-WINDOW LEFT-WINNER) ':SET-EDGES
					     (EXPAND-WINDOWS-LEFT LEFT-WINNER)
					     (EXPAND-WINDOWS-TOP LEFT-WINNER)
					     LEFT-MIDDLE
					     (EXPAND-WINDOWS-BOTTOM LEFT-WINNER)
					     ':VERIFY)
				    (RETURN T))))
			  (FUNCALL WINDOW ':SET-EDGES MAX-LEFT TOP RIGHT BOTTOM ':VERIFY))
		     ;;Go all the way left
		     (SET-EXPAND-WINDOWS-LEFT ITEM (SETQ LEFT MAX-LEFT))
		     ;;Share with winners
		     (SET-EXPAND-WINDOWS-LEFT ITEM (SETQ LEFT LEFT-MIDDLE))
		     (DOLIST (LEFT-WINNER LEFT-WINNERS)
		       (SET-EXPAND-WINDOWS-RIGHT LEFT-WINNER LEFT-MIDDLE))))))
      (AND ( MAX-RIGHT RIGHT)
	   (LET ((WINNERS-MAX-LEFT (AND RIGHT-WINNERS
					(EXPAND-WINDOWS-MAX-LEFT-TOP (CAR RIGHT-WINNERS))))
		 (RIGHT-MIDDLE (- MAX-RIGHT (// (- MAX-RIGHT RIGHT) 2))))
	     (AND WINNERS-MAX-LEFT (SETQ RIGHT-MIDDLE (MAX RIGHT-MIDDLE WINNERS-MAX-LEFT)))
	     (IF (AND RIGHT-WINNERS (NOT (FUNCALL WINDOW ':SET-EDGES LEFT TOP
						  RIGHT-MIDDLE BOTTOM ':VERIFY)))
		 (DOLIST (RIGHT-WINNER RIGHT-WINNERS)
		   (AND (FUNCALL (EXPAND-WINDOWS-WINDOW RIGHT-WINNER) ':SET-EDGES
				 WINNERS-MAX-LEFT
				 (EXPAND-WINDOWS-TOP RIGHT-WINNER)
				 (EXPAND-WINDOWS-RIGHT RIGHT-WINNER)
				 (EXPAND-WINDOWS-BOTTOM RIGHT-WINNER)
				 ':VERIFY)
			(SET-EXPAND-WINDOWS-LEFT RIGHT-WINNER WINNERS-MAX-LEFT)))
		 (IF (AND (OR (NULL RIGHT-WINNERS)
			      (DOLIST (RIGHT-WINNER RIGHT-WINNERS)
				(OR (FUNCALL (EXPAND-WINDOWS-WINDOW RIGHT-WINNER)
					     ':SET-EDGES
					     RIGHT-MIDDLE
					     (EXPAND-WINDOWS-TOP RIGHT-WINNER)
					     (EXPAND-WINDOWS-RIGHT RIGHT-WINNER)
					     (EXPAND-WINDOWS-BOTTOM RIGHT-WINNER)
					     ':VERIFY)
				    (RETURN T))))
			  (FUNCALL WINDOW ':SET-EDGES LEFT TOP MAX-RIGHT BOTTOM ':VERIFY))
		     (SET-EXPAND-WINDOWS-RIGHT ITEM (SETQ RIGHT MAX-RIGHT))
		     (SET-EXPAND-WINDOWS-RIGHT ITEM (SETQ RIGHT RIGHT-MIDDLE))
		     (DOLIST (RIGHT-WINNER RIGHT-WINNERS)
		       (SET-EXPAND-WINDOWS-LEFT RIGHT-WINNER RIGHT-MIDDLE)))))))))

(DEFUN SET-EXPAND-WINDOWS-LEFT (ITEM VAL)
  (SETF (EXPAND-WINDOWS-LEFT ITEM) VAL)
  (SETF (EXPAND-WINDOWS-MAX-LEFT-TOP ITEM) VAL)
  (DOLIST (WINNER (EXPAND-WINDOWS-LEFT-TOP-WINNERS ITEM))
    (SETF (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM WINNER)
	  (MIN VAL (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM WINNER)))))

(DEFUN SET-EXPAND-WINDOWS-RIGHT (ITEM VAL)
  (SETF (EXPAND-WINDOWS-RIGHT ITEM) VAL)
  (SETF (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM ITEM) VAL)
  (DOLIST (WINNER (EXPAND-WINDOWS-RIGHT-BOTTOM-WINNERS ITEM))
    (SETF (EXPAND-WINDOWS-MAX-LEFT-TOP WINNER)
	  (MAX VAL (EXPAND-WINDOWS-MAX-LEFT-TOP WINNER)))))

(DEFUN EXPAND-WINDOWS-TOP-AND-BOTTOM (TOP-WINDOW WINDOW-LIST)
  (DO ((L WINDOW-LIST (CDR L))
       (ITEM)
       (SUPERIOR-INSIDE-TOP (SHEET-INSIDE-TOP TOP-WINDOW))
       (SUPERIOR-INSIDE-BOTTOM (SHEET-INSIDE-BOTTOM TOP-WINDOW)))
      ((NULL L))
    (SETQ ITEM (CAR L))
    (DO ((L WINDOW-LIST (CDR L))
	 (NITEM)
	 (LEFT (EXPAND-WINDOWS-LEFT ITEM))
	 (TOP (EXPAND-WINDOWS-TOP ITEM))
	 (RIGHT (EXPAND-WINDOWS-RIGHT ITEM))
	 (BOTTOM (EXPAND-WINDOWS-BOTTOM ITEM))
	 (MAX-TOP SUPERIOR-INSIDE-TOP)
	 (MAX-BOTTOM SUPERIOR-INSIDE-BOTTOM)
	 (TOP-WINNERS)
	 (BOTTOM-WINNERS)
	 (NITEM-TOP)
	 (NITEM-BOTTOM))
	((NULL L)
	 (SETF (EXPAND-WINDOWS-LEFT-TOP-WINNERS ITEM) TOP-WINNERS)
	 (SETF (EXPAND-WINDOWS-RIGHT-BOTTOM-WINNERS ITEM) BOTTOM-WINNERS)
	 (SETF (EXPAND-WINDOWS-MAX-LEFT-TOP ITEM) MAX-TOP)
	 (SETF (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM ITEM) MAX-BOTTOM))
      (OR (EQ ITEM (SETQ NITEM (CAR L)))		;For all other windows
	  (> LEFT (EXPAND-WINDOWS-RIGHT NITEM))		;Which share some space on y
	  (< RIGHT (EXPAND-WINDOWS-LEFT NITEM))
	  (COND (( TOP (SETQ NITEM-BOTTOM (EXPAND-WINDOWS-BOTTOM NITEM)))
		 (AND ( NITEM-BOTTOM MAX-TOP)
		      (IF (= NITEM-BOTTOM MAX-TOP)	;More than one window along the edge
			  (PUSH NITEM TOP-WINNERS)
			  (SETQ MAX-TOP NITEM-BOTTOM
				TOP-WINNERS (LIST NITEM)))))
		(( BOTTOM (SETQ NITEM-TOP (EXPAND-WINDOWS-TOP NITEM)))
		 (AND ( NITEM-TOP MAX-BOTTOM)
		      (IF (= NITEM-TOP MAX-BOTTOM)
			  (PUSH NITEM BOTTOM-WINNERS)
			  (SETQ MAX-BOTTOM NITEM-TOP
				BOTTOM-WINNERS (LIST NITEM)))))))))
  (DOLIST (ITEM WINDOW-LIST)
    (LET ((WINDOW (EXPAND-WINDOWS-WINDOW ITEM))
	  (LEFT (EXPAND-WINDOWS-LEFT ITEM))
	  (TOP (EXPAND-WINDOWS-TOP ITEM))
	  (RIGHT (EXPAND-WINDOWS-RIGHT ITEM))
	  (BOTTOM (EXPAND-WINDOWS-BOTTOM ITEM))
	  (MAX-TOP (EXPAND-WINDOWS-MAX-LEFT-TOP ITEM))
	  (MAX-BOTTOM (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM ITEM))
	  (TOP-WINNERS (EXPAND-WINDOWS-LEFT-TOP-WINNERS ITEM))
	  (BOTTOM-WINNERS (EXPAND-WINDOWS-RIGHT-BOTTOM-WINNERS ITEM)))
      (AND ( MAX-TOP TOP)				;If not already adjacent
	   (LET ((WINNERS-MAX-BOTTOM (AND TOP-WINNERS
					  (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM
					    (CAR TOP-WINNERS))))
		 (TOP-MIDDLE (+ MAX-TOP (// (- TOP MAX-TOP) 2))))
	     (AND WINNERS-MAX-BOTTOM (SETQ TOP-MIDDLE (MIN TOP-MIDDLE WINNERS-MAX-BOTTOM)))
	     (IF (AND TOP-WINNERS (NOT (FUNCALL WINDOW ':SET-EDGES LEFT TOP-MIDDLE
						 RIGHT BOTTOM ':VERIFY)))
		 ;;This window will not move, get as many of the others as will allow
		 (DOLIST (TOP-WINNER TOP-WINNERS)
		   (AND (FUNCALL (EXPAND-WINDOWS-WINDOW TOP-WINNER) ':SET-EDGES
				 (EXPAND-WINDOWS-LEFT TOP-WINNER)
				 (EXPAND-WINDOWS-TOP TOP-WINNER)
				 (EXPAND-WINDOWS-RIGHT TOP-WINNER)
				 WINNERS-MAX-BOTTOM
				 ':VERIFY)
			(SET-EXPAND-WINDOWS-BOTTOM TOP-WINNER WINNERS-MAX-BOTTOM)))
		 ;;Otherwise expand this window top
		 (IF (AND (OR (NULL TOP-WINNERS)	;If no windows to the top,
			      (DOLIST (TOP-WINNER TOP-WINNERS)	;or some won't budge
				(OR (FUNCALL (EXPAND-WINDOWS-WINDOW TOP-WINNER) ':SET-EDGES
					     (EXPAND-WINDOWS-LEFT TOP-WINNER)
					     (EXPAND-WINDOWS-TOP TOP-WINNER)
					     (EXPAND-WINDOWS-RIGHT TOP-WINNER)
					     TOP-MIDDLE
					     ':VERIFY)
				    (RETURN T))))
			  (FUNCALL WINDOW ':SET-EDGES LEFT MAX-TOP RIGHT BOTTOM ':VERIFY))
		     ;;Go all the way top
		     (SET-EXPAND-WINDOWS-TOP ITEM (SETQ TOP MAX-TOP))
		     ;;Share with winners
		     (SET-EXPAND-WINDOWS-TOP ITEM (SETQ TOP TOP-MIDDLE))
		     (DOLIST (TOP-WINNER TOP-WINNERS)
		       (SET-EXPAND-WINDOWS-BOTTOM TOP-WINNER TOP-MIDDLE))))))
      (AND ( MAX-BOTTOM BOTTOM)
	   (LET ((WINNERS-MAX-TOP (AND BOTTOM-WINNERS
					(EXPAND-WINDOWS-MAX-LEFT-TOP (CAR BOTTOM-WINNERS))))
		 (BOTTOM-MIDDLE (- MAX-BOTTOM (// (- MAX-BOTTOM BOTTOM) 2))))
	     (AND WINNERS-MAX-TOP (SETQ BOTTOM-MIDDLE (MAX BOTTOM-MIDDLE WINNERS-MAX-TOP)))
	     (IF (AND BOTTOM-WINNERS (NOT (FUNCALL WINDOW ':SET-EDGES LEFT TOP
						  RIGHT BOTTOM-MIDDLE ':VERIFY)))
		 (DOLIST (BOTTOM-WINNER BOTTOM-WINNERS)
		   (AND (FUNCALL (EXPAND-WINDOWS-WINDOW BOTTOM-WINNER) ':SET-EDGES
				 (EXPAND-WINDOWS-LEFT BOTTOM-WINNER)
				 WINNERS-MAX-TOP
				 (EXPAND-WINDOWS-RIGHT BOTTOM-WINNER)
				 (EXPAND-WINDOWS-BOTTOM BOTTOM-WINNER)
				 ':VERIFY)
			(SET-EXPAND-WINDOWS-TOP BOTTOM-WINNER WINNERS-MAX-TOP)))
		 (IF (AND (OR (NULL BOTTOM-WINNERS)
			      (DOLIST (BOTTOM-WINNER BOTTOM-WINNERS)
				(OR (FUNCALL (EXPAND-WINDOWS-WINDOW BOTTOM-WINNER)
					     ':SET-EDGES
					     (EXPAND-WINDOWS-LEFT BOTTOM-WINNER)
					     BOTTOM-MIDDLE
					     (EXPAND-WINDOWS-RIGHT BOTTOM-WINNER)
					     (EXPAND-WINDOWS-BOTTOM BOTTOM-WINNER)
					     ':VERIFY)
				    (RETURN T))))
			  (FUNCALL WINDOW ':SET-EDGES LEFT TOP RIGHT MAX-BOTTOM ':VERIFY))
		     (SET-EXPAND-WINDOWS-BOTTOM ITEM (SETQ BOTTOM MAX-BOTTOM))
		     (SET-EXPAND-WINDOWS-BOTTOM ITEM (SETQ BOTTOM BOTTOM-MIDDLE))
		     (DOLIST (BOTTOM-WINNER BOTTOM-WINNERS)
		       (SET-EXPAND-WINDOWS-TOP BOTTOM-WINNER BOTTOM-MIDDLE)))))))))

(DEFUN SET-EXPAND-WINDOWS-TOP (ITEM VAL)
  (SETF (EXPAND-WINDOWS-TOP ITEM) VAL)
  (SETF (EXPAND-WINDOWS-MAX-LEFT-TOP ITEM) VAL)
  (DOLIST (WINNER (EXPAND-WINDOWS-LEFT-TOP-WINNERS ITEM))
    (SETF (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM WINNER)
	  (MIN VAL (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM WINNER)))))

(DEFUN SET-EXPAND-WINDOWS-BOTTOM (ITEM VAL)
  (SETF (EXPAND-WINDOWS-BOTTOM ITEM) VAL)
  (SETF (EXPAND-WINDOWS-MAX-RIGHT-BOTTOM ITEM) VAL)
  (DOLIST (WINNER (EXPAND-WINDOWS-RIGHT-BOTTOM-WINNERS ITEM))
    (SETF (EXPAND-WINDOWS-MAX-LEFT-TOP WINNER)
	  (MAX VAL (EXPAND-WINDOWS-MAX-LEFT-TOP WINNER)))))

(DEFVAR SCREEN-EDITOR-ITEM-LIST
	'(("Bury" . SEC-BURY) ("Expose" . SEC-EXPOSE) ("Expose (menu)" . SEC-EXPOSE-MENU)
	  ("Create" . SEC-CREATE)
	  ("Kill" . SEC-KILL)
	  ("Exit" . SEC-QUIT) ("Undo" . SEC-UNDO)
	  ("Move window" . SEC-MOVE-WINDOW) ("Reshape" . SEC-RESHAPE)
	  ("Move multiple" . SEC-MULTIPLE-MOVE) ("Move single" . SEC-SINGLE-MOVE)
	  ("Expand window" . SEC-EXPAND-WINDOW) ("Expand all" . SEC-EXPAND-ALL)))

(SYSTEM-WINDOW-ADD-TYPE 'SCREEN-EDITOR-MENU
			#'(LAMBDA (SUP)
			    (WINDOW-CREATE 'DYNAMIC-POP-UP-MENU
					   ':SUPERIOR SUP
					   ':SAVE-BITS T
					   ':ITEM-LIST-POINTER 'SCREEN-EDITOR-ITEM-LIST))
			T ':DEEXPOSED)

(DEFVAR SCREEN-EDITOR-MENU)
(DEFVAR SCREEN-EDITOR-PREVIOUS-ALIST)

;;; The actual screen editor
;;; The WINDOW-EDGE-ALIST is in sheet visibility order and has elements
;;;	(window exposed-p left top right bottom)
;;; :BURY in exposed-p is a special kludge to make burying to deexposed windows work
;;; Only problem with this is that undoing a bury of a de-exposed window does not work;
;;; we do not have window operations to do things like bring a window to the top
;;; of the de-exposed ones.

;;; Commands work by modifying this alist and the command loop here does the
;;; actual side-effects, allowing for undoing.
(DEFUN EDIT-SCREEN (TOP-SHEET &AUX WINDOW-EDGE-ALIST SCREEN-EDITOR-PREVIOUS-ALIST
				   (OLD-MOUSE-SHEET MOUSE-SHEET)
				   (OLD-SELECTED-WINDOW SELECTED-WINDOW)
				   (SCREEN-EDITOR-MENU
				     (GET-A-SYSTEM-WINDOW 'SCREEN-EDITOR-MENU TOP-SHEET)))
  (SETQ WINDOW-EDGE-ALIST (GET-WINDOW-EDGE-ALIST TOP-SHEET)
	SCREEN-EDITOR-PREVIOUS-ALIST WINDOW-EDGE-ALIST)
  (UNWIND-PROTECT
   (*CATCH 'EXIT-SCREEN-EDITOR
    (LET-GLOBALLY ((WHO-LINE-PROCESS CURRENT-PROCESS))
     (MOUSE-SET-SHEET TOP-SHEET)
     (DO ((COMMAND)
	  (NEW-ALIST))
	(NIL)
      (EXPOSE-WINDOW-NEAR SCREEN-EDITOR-MENU '(:MOUSE))
      (COND ((SETQ COMMAND (FUNCALL SCREEN-EDITOR-MENU ':CHOOSE))
	     (DELAYING-SCREEN-MANAGEMENT
	       (FUNCALL SCREEN-EDITOR-MENU ':DEACTIVATE)
	       (SETQ NEW-ALIST (FUNCALL COMMAND TOP-SHEET WINDOW-EDGE-ALIST))
	       (DOLIST (NEW NEW-ALIST)
		 (LET ((OLD (ASSQ (CAR NEW) WINDOW-EDGE-ALIST)))
		   (OR (EQUAL (CDDR OLD) (CDDR NEW))	;Edges not the same?
		       (LEXPR-FUNCALL (CAR NEW) ':SET-EDGES (CDDR NEW)))
		   ;; Try to fix exposure and ordering of de-exposed sheets.
		   ;; This may not be quite right, e.g. if undoing an expose
		   ;; because the window will go in the wrong place in the
		   ;; de-exposed sheets, and Undo twice will not be a no-op.
		   ;; It will just have to do for now though.
		   (COND ((EQ (CADR NEW) T)
			  (OR (CADR OLD) (FUNCALL (CAR NEW) ':EXPOSE)))
			 ((EQ (CADR NEW) ':BURY)
			  (FUNCALL (CAR NEW) ':BURY)))))
	       ;; Doing the buries in a second pass makes the above-mentioned inaccuracy less
	       (DOLIST (NEW NEW-ALIST)
		 (AND (NOT (CADR NEW)) (SHEET-EXPOSED-P (CAR NEW))
		      (FUNCALL (CAR NEW) ':BURY))))
	     ;; Save the previous state for Undo, and recompute what the state really
	     ;; is to reflect whatever the screen manager decided to do.
	     (SETQ SCREEN-EDITOR-PREVIOUS-ALIST WINDOW-EDGE-ALIST
		   WINDOW-EDGE-ALIST (GET-WINDOW-EDGE-ALIST TOP-SHEET)))))))
   (MOUSE-SET-SHEET OLD-MOUSE-SHEET))
  (IF (SCREEN-EDITOR-SHOULD-RESELECT OLD-SELECTED-WINDOW)
      (FUNCALL OLD-SELECTED-WINDOW ':SELECT)
      (FUNCALL TOP-SHEET ':SCREEN-MANAGE-AUTOEXPOSE-INFERIORS)))

(DEFUN GET-WINDOW-EDGE-ALIST (TOP-SHEET &AUX WINDOW-EDGE-ALIST TEM)
  (DOLIST (SHEET (SHEET-INFERIORS TOP-SHEET))
    (AND (OR (SETQ TEM (SHEET-EXPOSED-P SHEET))
	     (FUNCALL SHEET ':SCREEN-MANAGE-DEEXPOSED-VISIBILITY))
	 (PUSH (LIST* SHEET TEM (MULTIPLE-VALUE-LIST (FUNCALL SHEET ':EDGES)))
	       WINDOW-EDGE-ALIST)))
  (NREVERSE WINDOW-EDGE-ALIST))

(DEFUN SCREEN-EDITOR-SHOULD-RESELECT (W)
  (AND W
       (DO ((W W (SHEET-SUPERIOR W)))
	   ((NULL W) T)
	 (OR (SHEET-EXPOSED-P W)
	     (RETURN NIL)))))

(DEFUN SCREEN-EDITOR-FIND-SCREEN-TO-EDIT (BOTTOM-WINDOW &AUX LIST)
  (DO SHEET BOTTOM-WINDOW (SHEET-SUPERIOR SHEET) (NULL SHEET)
    (AND (TYPEP SHEET 'BASIC-FRAME) (PUSH SHEET LIST)))
  (IF (NULL LIST) MOUSE-SHEET
      (OR (MEMQ MOUSE-SHEET LIST) (PUSH MOUSE-SHEET LIST))
      (MENU-CHOOSE
	(MAPCAR #'(LAMBDA (W) (CONS (OR (AND (GET-HANDLER-FOR W ':NAME-FOR-SELECTION)
					     (FUNCALL W ':NAME-FOR-SELECTION))
					(SHEET-NAME W))
				    W))
		LIST)
	"Edit which:")))

;;; This is like SUBST but uses EQ rather than EQUAL and only copies what it has to.
(DEFUN SUBSTQ (NEW OLD SEXP)
  (COND ((EQ OLD SEXP) NEW)
	((ATOM SEXP) SEXP)
	(T (LET ((NCAR (SUBSTQ NEW OLD (CAR SEXP)))
		 (NCDR (SUBSTQ NEW OLD (CDR SEXP))))
	     (IF (AND (EQ (CAR SEXP) NCAR) (EQ (CDR SEXP) NCDR)) SEXP (CONS NCAR NCDR))))))

;;; The screen editor commands and their friends; called with the top-sheet and edge-alist
;;; as arguments, they return the new edge alist.
(DEFUN SEC-QUIT (IGNORE IGNORE)
  (*THROW 'EXIT-SCREEN-EDITOR T))

(DEFUN SEC-UNDO (IGNORE IGNORE)
  SCREEN-EDITOR-PREVIOUS-ALIST)

(DEFUN SEC-BURY (IGNORE WINDOW-EDGE-ALIST &AUX WINDOW)
  (COND ((SETQ WINDOW (SCREEN-EDITOR-FIND-WINDOW WINDOW-EDGE-ALIST NIL "Bury window"))
	 (SETQ WINDOW-EDGE-ALIST (NREVERSE (XCONS (DELQ WINDOW (REVERSE WINDOW-EDGE-ALIST))
						  (SETQ WINDOW (COPYLIST WINDOW)))))
	 (SETF (SECOND WINDOW) ':BURY)))
  WINDOW-EDGE-ALIST)

;This is not really undoable, in that the window cannot be "unkilled"
(DEFUN SEC-KILL (IGNORE WINDOW-EDGE-ALIST &AUX WINDOW)
  (COND ((SETQ WINDOW (SCREEN-EDITOR-FIND-WINDOW WINDOW-EDGE-ALIST NIL "Kill window"))
	 (FUNCALL (CAR WINDOW) ':KILL)
	 (SETQ WINDOW-EDGE-ALIST (REMQ WINDOW WINDOW-EDGE-ALIST))))
  WINDOW-EDGE-ALIST)

;Undoing this won't kill this window, just bury it
(DEFUN SEC-CREATE (SUP WINDOW-EDGE-ALIST)
  (SYSTEM-MENU-CREATE-WINDOW SUP)
  WINDOW-EDGE-ALIST)

(DEFUN SEC-EXPOSE (IGNORE WINDOW-EDGE-ALIST &AUX WINDOW)
  (COND ((SETQ WINDOW (SCREEN-EDITOR-FIND-WINDOW WINDOW-EDGE-ALIST NIL "Expose window"))
	 (SETQ WINDOW-EDGE-ALIST (REMQ WINDOW WINDOW-EDGE-ALIST))
	 (PUSH (SETQ WINDOW (COPYLIST WINDOW)) WINDOW-EDGE-ALIST)
	 (SETF (SECOND WINDOW) T)))
  WINDOW-EDGE-ALIST)

(DEFUN SEC-EXPOSE-MENU (TOP-SHEET WINDOW-EDGE-ALIST &AUX WINDOW)
  (COND ((SETQ WINDOW
	   (ASSQ (MENU-CHOOSE
		   (MAPCAN #'(LAMBDA (W)
			       (AND (NOT (MEMQ W (SHEET-EXPOSED-INFERIORS TOP-SHEET)))
				    (NCONS (CONS (OR (AND (GET-HANDLER-FOR W
							     ':NAME-FOR-SELECTION)
							  (FUNCALL W ':NAME-FOR-SELECTION))
						     (SHEET-NAME W))
						 W))))
			   (SHEET-INFERIORS TOP-SHEET))
		   "Expose:")
		 WINDOW-EDGE-ALIST))
	 (SETQ WINDOW-EDGE-ALIST (REMQ WINDOW WINDOW-EDGE-ALIST))
	 (PUSH (SETQ WINDOW (COPYLIST WINDOW)) WINDOW-EDGE-ALIST)
	 (SETF (SECOND WINDOW) T)))
  WINDOW-EDGE-ALIST)

(DEFUN SEC-MOVE-WINDOW (IGNORE WINDOW-EDGE-ALIST &AUX WINDOW)
  (AND (SETQ WINDOW (SCREEN-EDITOR-FIND-WINDOW WINDOW-EDGE-ALIST NIL "Move window"))
       (MULTIPLE-VALUE-BIND (X Y)
	   (MOUSE-SET-WINDOW-POSITION (CAR WINDOW) NIL)
	 (SETQ WINDOW-EDGE-ALIST (SUBSTQ (LIST (CAR WINDOW) (CADR WINDOW) X Y
					       (+ X (SHEET-WIDTH (CAR WINDOW)))
					       (+ Y (SHEET-HEIGHT (CAR WINDOW))))
					 WINDOW WINDOW-EDGE-ALIST))))
  WINDOW-EDGE-ALIST)

(DEFUN SEC-RESHAPE (IGNORE WINDOW-EDGE-ALIST &AUX WINDOW)
  (AND (SETQ WINDOW (SCREEN-EDITOR-FIND-WINDOW WINDOW-EDGE-ALIST NIL "Reshape window"))
       (SETQ WINDOW-EDGE-ALIST
	     (SUBSTQ (LIST* (CAR WINDOW) (CADR WINDOW)
			    (MULTIPLE-VALUE-LIST (MOUSE-SET-WINDOW-SIZE (CAR WINDOW) NIL)))
		     WINDOW WINDOW-EDGE-ALIST)))
  WINDOW-EDGE-ALIST)

(DEFUN SEC-EXPAND-WINDOW (IGNORE WINDOW-EDGE-ALIST &AUX WINDOW)
  (AND (SETQ WINDOW (SCREEN-EDITOR-FIND-WINDOW WINDOW-EDGE-ALIST NIL "Expand window"))
       (SETQ WINDOW-EDGE-ALIST
	     (SUBSTQ (LIST* (CAR WINDOW) (CADR WINDOW)
			    (MULTIPLE-VALUE-LIST (EXPAND-WINDOW (CAR WINDOW) NIL)))
		     WINDOW WINDOW-EDGE-ALIST)))
  WINDOW-EDGE-ALIST)

(DEFUN SEC-EXPAND-ALL (TOP-WINDOW WINDOW-EDGE-ALIST &AUX WINDOW-LIST)
  (SETQ WINDOW-LIST (DO ((L WINDOW-EDGE-ALIST (CDR L))
			 (LIST NIL))
			((NULL L) (NREVERSE LIST))
		      (AND (CADAR L)	;Exposed
			   (PUSH (CONS (CAAR L) (APPEND (CDDAR L) (MAKE-LIST NIL 4))) LIST))))
  (EXPAND-WINDOWS-LEFT-AND-RIGHT TOP-WINDOW WINDOW-LIST)
  (EXPAND-WINDOWS-TOP-AND-BOTTOM TOP-WINDOW WINDOW-LIST)
  (NCONC (MAPCAR #'(LAMBDA (ITEM)
		     (LIST (EXPAND-WINDOWS-WINDOW ITEM) T
			   (EXPAND-WINDOWS-LEFT ITEM) (EXPAND-WINDOWS-TOP ITEM)
			   (EXPAND-WINDOWS-RIGHT ITEM) (EXPAND-WINDOWS-BOTTOM ITEM)))
		 WINDOW-LIST)
	 (DO L WINDOW-EDGE-ALIST (CDR L) (NULL L)	;All the de-exposed guys
	     (AND (NULL (CADAR L)) (RETURN L)))))

;Clicking a button other than the left-hand one is the way to punt
;NIL for CHAR means use the default, which you should use unless there
;is a good reason to have a different blinker.
(DEFUN SCREEN-EDITOR-FIND-WINDOW (WINDOW-EDGE-ALIST CHAR PROMPT &AUX X Y WINDOW)
  (OR CHAR (SETQ CHAR 24))  ;Default is the bombsight
  (WITH-MOUSE-GRABBED
    (PROCESS-WAIT "Button up" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
    (MOUSE-SET-BLINKER-DEFINITION ':CHARACTER 0 0 ':ON
				  ':SET-CHARACTER CHAR)
    (PROCESS-WAIT PROMPT #'(LAMBDA () (NOT (ZEROP MOUSE-LAST-BUTTONS))))
    (SETQ X MOUSE-X Y MOUSE-Y)
    (AND (BIT-TEST 1 MOUSE-LAST-BUTTONS)
	 (DOLIST (W WINDOW-EDGE-ALIST)
	   (AND ( X (THIRD W)) ( Y (FOURTH W))
		(< X (FIFTH W)) (< Y (SIXTH W))
		(RETURN (SETQ WINDOW W))))))
  WINDOW)

;;; Hairy movement commands
(DEFFLAVOR FOLLOWING-ARROW-BLINKER
	(X-ORIGIN Y-ORIGIN
	 TRI-WIDTH TRI-HEIGHT
	 RECT-WIDTH RECT-HEIGHT
	 STATE)
	(BLINKER)
  (:INITABLE-INSTANCE-VARIABLES X-ORIGIN Y-ORIGIN TRI-WIDTH TRI-HEIGHT
				RECT-WIDTH RECT-HEIGHT))

(DEFMETHOD (FOLLOWING-ARROW-BLINKER :BEFORE :INIT) (IGNORE)
  (SETQ STATE (MAKE-LIST NIL 12.)))

(DEFUN MAKE-FOLLOWING-ARROW-BLINKER (SHEET X-ORIGIN Y-ORIGIN TRI-WIDTH TRI-HEIGHT
					   RECT-WIDTH RECT-HEIGHT
				     &REST OPTIONS)
  (LEXPR-FUNCALL #'DEFINE-BLINKER SHEET 'FOLLOWING-ARROW-BLINKER
		 ':X-ORIGIN X-ORIGIN ':Y-ORIGIN Y-ORIGIN
		 ':TRI-WIDTH TRI-WIDTH ':TRI-HEIGHT TRI-HEIGHT
		 ':RECT-WIDTH RECT-WIDTH ':RECT-HEIGHT RECT-HEIGHT
		 OPTIONS))

(DEFMETHOD (FOLLOWING-ARROW-BLINKER :SIZE) ()
  (PROG () (RETURN (MAX TRI-WIDTH RECT-WIDTH)
		   (+ TRI-HEIGHT RECT-HEIGHT))))

(DEFUN SET-FOLLOWING-ARROW-BLINKER-ORIGIN (BLINKER X-ORIGIN Y-ORIGIN)
  (FUNCALL BLINKER ':SET-ORIGIN X-ORIGIN Y-ORIGIN))					   

(DEFMETHOD (FOLLOWING-ARROW-BLINKER :SET-ORIGIN) (NX-ORIGIN NY-ORIGIN)
  (WITHOUT-INTERRUPTS
    (OPEN-BLINKER SELF)
    (SETQ X-ORIGIN NX-ORIGIN Y-ORIGIN NY-ORIGIN)))

(DEFMETHOD (FOLLOWING-ARROW-BLINKER :BLINK) (&AUX X0 Y0 X2 Y2 X3 Y3 X4 Y4 X5 Y5 X6 Y6 X7 Y7)
  (COND ((NOT PHASE)
	 ;;Making it visible, recompute the parameters
	 (LET (DX DY LEN)
	   (SETQ X0 (OR X-ORIGIN X-POS))
	   (SETQ Y0 (OR Y-ORIGIN Y-POS))
	   (SETQ DX (- X-POS X0)
		 DY (- Y-POS Y0)
		 LEN (ISQRT (+ (* DX DX) (* DY DY))))
	   (AND (ZEROP LEN) (SETQ LEN 1))
	   (SETQ X4 (+ X-POS (// (* DX TRI-HEIGHT) LEN))
		 Y4 (+ Y-POS (// (* DY TRI-HEIGHT) LEN))
		 X6 (+ X-POS (// (* DX (+ TRI-HEIGHT RECT-HEIGHT)) LEN))
		 Y6 (+ Y-POS (// (* DY (+ TRI-HEIGHT RECT-HEIGHT)) LEN)))
	   (LET ((DX1 (// (* TRI-WIDTH DY) LEN))
		 (DY1 (// (* TRI-WIDTH DX) LEN)))
	     (SETQ X2 (- X4 DX1)
		   Y2 (+ Y4 DY1)
		   X3 (+ X4 DX1)
		   Y3 (- Y4 DY1)))
	   (LET ((DX1 (// (* RECT-WIDTH DY) LEN))
		 (DY1 (// (* RECT-WIDTH DX) LEN)))
	     (SETQ X5 (+ X4 DX1)
		   Y5 (- Y4 DY1)
		   X4 (- X4 DX1)
		   Y4 (+ Y4 DY1))
	     (SETQ X7 (+ X6 DX1)
		   Y7 (- Y6 DY1)
		   X6 (- X6 DX1)
		   Y6 (+ Y6 DY1))))
	 (SETF (NTH 0 STATE) X2)
	 (SETF (NTH 1 STATE) Y2)
	 (SETF (NTH 2 STATE) X3)
	 (SETF (NTH 3 STATE) Y3)
	 (SETF (NTH 4 STATE) X4)
	 (SETF (NTH 5 STATE) Y4)
	 (SETF (NTH 6 STATE) X5)
	 (SETF (NTH 7 STATE) Y5)
	 (SETF (NTH 10 STATE) X6)
	 (SETF (NTH 11 STATE) Y6)
	 (SETF (NTH 12 STATE) X7)
	 (SETF (NTH 13 STATE) Y7))
	(T
	 ;;Erasing it, use old parameters
	 (SETQ X2 (NTH 0 STATE))
	 (SETQ Y2 (NTH 1 STATE))
	 (SETQ X3 (NTH 2 STATE))
	 (SETQ Y3 (NTH 3 STATE))
	 (SETQ X4 (NTH 4 STATE))
	 (SETQ Y4 (NTH 5 STATE))
	 (SETQ X5 (NTH 6 STATE))
	 (SETQ Y5 (NTH 7 STATE))
	 (SETQ X6 (NTH 10 STATE))
	 (SETQ Y6 (NTH 11 STATE))
	 (SETQ X7 (NTH 12 STATE))
	 (SETQ Y7 (NTH 13 STATE))))
  (%DRAW-TRIANGLE X-POS Y-POS X2 Y2 X4 Y4 ALU-XOR SHEET)
  (%DRAW-TRIANGLE X-POS Y-POS X4 Y4 X6 Y6 ALU-XOR SHEET)
  (%DRAW-TRIANGLE X-POS Y-POS X6 Y6 X7 Y7 ALU-XOR SHEET)
  (%DRAW-TRIANGLE X-POS Y-POS X7 Y7 X5 Y5 ALU-XOR SHEET)
  (%DRAW-TRIANGLE X-POS Y-POS X5 Y5 X3 Y3 ALU-XOR SHEET))

(DEFFLAVOR MOUSE-FOLLOWING-ARROW-BLINKER () (MOUSE-BLINKER-MIXIN FOLLOWING-ARROW-BLINKER))
(COMPILE-FLAVOR-METHODS MOUSE-FOLLOWING-ARROW-BLINKER)
(MOUSE-DEFINE-BLINKER-TYPE ':FOLLOWING-ARROW
			   #'(LAMBDA (SCREEN)
			       (DEFINE-BLINKER SCREEN 'MOUSE-FOLLOWING-ARROW-BLINKER
				  ':X-ORIGIN 0 ':Y-ORIGIN 0
				  ':TRI-WIDTH 12 ':TRI-HEIGHT 24 ':RECT-WIDTH 4
				  ':RECT-HEIGHT 40 ':VISIBILITY NIL)))

(DEFUN FIND-EDGE-OR-CORNER (WINDOW-EDGE-ALIST)
  (PROG KLUDGE ()
    (WITH-MOUSE-GRABBED
      (WITHOUT-INTERRUPTS
	      (MOUSE-SET-BLINKER ':FOLLOWING-ARROW)
	      (MOUSE-WARP MOUSE-X MOUSE-Y))
      (DO ((MODE ':FOO)
	   (X0) (Y0)
	   (OLD-X MOUSE-X MOUSE-X)
	   (OLD-Y MOUSE-Y MOUSE-Y)
	   (WINDOW-AND-EDGES)
	   (NEW-WINDOW-AND-EDGES)
	   (NEW-MODE))
	  (NIL)
	(COND ((SETQ NEW-WINDOW-AND-EDGES (DOLIST (WINDOW-AND-EDGES WINDOW-EDGE-ALIST)
					    (AND ( OLD-X (THIRD WINDOW-AND-EDGES))
						 ( OLD-Y (FOURTH WINDOW-AND-EDGES))
						 (< OLD-X (FIFTH WINDOW-AND-EDGES))
						 (< OLD-Y (SIXTH WINDOW-AND-EDGES))
						 (RETURN WINDOW-AND-EDGES))))
	       (LET ((LEFT (THIRD NEW-WINDOW-AND-EDGES))
		     (TOP (FOURTH NEW-WINDOW-AND-EDGES))
		     (RIGHT (FIFTH NEW-WINDOW-AND-EDGES))
		     (BOTTOM (SIXTH NEW-WINDOW-AND-EDGES)))
		 (LET (LEFT-P TOP-P LEFT-RIGHT-CORNER-P TOP-BOTTOM-CORNER-P)
		   (LET ((ONE-THIRD (// (- RIGHT LEFT) 3)))
		     (SETQ LEFT-RIGHT-CORNER-P
			   (IF (SETQ LEFT-P (< OLD-X (// (+ LEFT RIGHT) 2)))
			       (< OLD-X (+ LEFT ONE-THIRD))
			       (> OLD-X (- RIGHT ONE-THIRD)))))
		   (LET ((ONE-THIRD (// (- BOTTOM TOP) 3)))
		     (SETQ TOP-BOTTOM-CORNER-P
			   (IF (SETQ TOP-P (< OLD-Y (// (+ TOP BOTTOM) 2)))
			       (< OLD-Y (+ TOP ONE-THIRD))
			       (> OLD-Y (- BOTTOM ONE-THIRD)))))
		   (IF (AND LEFT-RIGHT-CORNER-P TOP-BOTTOM-CORNER-P)
		       (SETQ NEW-MODE (IF LEFT-P (IF TOP-P ':TOP-LEFT ':BOTTOM-LEFT)
					  (IF TOP-P ':TOP-RIGHT ':BOTTOM-RIGHT)))
		       (LET ((DX (// (* 100. (IF LEFT-P (- OLD-X LEFT) (- RIGHT OLD-X)))
				     (- RIGHT LEFT)))
			     (DY (// (* 100. (IF TOP-P (- OLD-Y TOP) (- BOTTOM OLD-Y)))
				     (- BOTTOM TOP))))
			 (SETQ NEW-MODE (IF (< DX DY) (IF LEFT-P ':LEFT ':RIGHT)
					    (IF TOP-P ':TOP ':BOTTOM))))))
		 (COND ((OR (NEQ NEW-WINDOW-AND-EDGES WINDOW-AND-EDGES)
			    (NEQ NEW-MODE MODE))
			(SETQ X0 (COND ((MEMQ NEW-MODE '(:LEFT :TOP-LEFT :BOTTOM-LEFT))
					LEFT)
				       ((MEMQ NEW-MODE '(:RIGHT :TOP-RIGHT
								:BOTTOM-RIGHT))
					RIGHT)
				       (T
					NIL)))
			(SETQ Y0 (COND ((MEMQ NEW-MODE '(:TOP :TOP-LEFT :TOP-RIGHT))
					TOP)
				       ((MEMQ NEW-MODE '(:BOTTOM :BOTTOM-LEFT
								 :BOTTOM-RIGHT))
					BOTTOM)
				       (T
					NIL)))
			(FUNCALL MOUSE-BLINKER ':SET-ORIGIN X0 Y0)
			(BLINKER-SET-VISIBILITY MOUSE-BLINKER T)
			(SETQ MODE NEW-MODE
			      WINDOW-AND-EDGES NEW-WINDOW-AND-EDGES)))))
	      ((NEQ MODE ':OUT)			;Not already out
	       (SETQ MODE ':OUT)
	       (BLINKER-SET-VISIBILITY MOUSE-BLINKER NIL)))
	(PROCESS-WAIT "Pick something"
		      #'(LAMBDA (OLD-X OLD-Y)
			  (OR (NOT (ZEROP MOUSE-LAST-BUTTONS))
			      ( MOUSE-X OLD-X)
			      ( MOUSE-Y OLD-Y)))
		      OLD-X OLD-Y)
	(OR (ZEROP MOUSE-LAST-BUTTONS)
	    (RETURN-FROM KLUDGE WINDOW-AND-EDGES MODE))))))

;;; Display a set of filled in rectangles
(DEFFLAVOR MULTIPLE-RECTANGLE-BLINKER
	((RECTANGLE-LIST))
	(BLINKER)
  (:INITABLE-INSTANCE-VARIABLES RECTANGLE-LIST))

(DEFMETHOD (MULTIPLE-RECTANGLE-BLINKER :SET-RECTANGLE-LIST) (NEW-RECTANGLE-LIST)
  (WITHOUT-INTERRUPTS
    (OPEN-BLINKER SELF)
    (SETQ RECTANGLE-LIST NEW-RECTANGLE-LIST)))

(DEFMETHOD (MULTIPLE-RECTANGLE-BLINKER :SIZE) ()
  (DO ((RECTS RECTANGLE-LIST (CDR RECTS))
       (RECT)
       (MIN-X0 0) (MIN-Y0 0)
       (MAX-X1 0) (MAX-Y1 0))
      ((NULL RECTS)
       (PROG () (RETURN (- MAX-X1 MIN-X0) (- MAX-Y1 MIN-Y0))))
    (SETQ RECT (CAR RECTS))
    (SETQ MIN-X0 (MIN MIN-X0 (FIRST RECT))
	  MIN-Y0 (MIN MIN-Y0 (SECOND RECT)))
    (SETQ MAX-X1 (MAX MAX-X1 (+ (FIRST RECT) (THIRD RECT)))
	  MAX-Y1 (MAX MAX-Y1 (+ (SECOND RECT) (FOURTH RECT))))))

(DEFMETHOD (MULTIPLE-RECTANGLE-BLINKER :BLINK) ()
  (DOLIST (RECT RECTANGLE-LIST)
    (%DRAW-RECTANGLE-CLIPPED (THIRD RECT) (FOURTH RECT)
			     (+ X-POS (FIRST RECT)) (+ Y-POS (SECOND RECT))
			     ALU-XOR SHEET)))

;;; Rectangle merger, makes an XORable set
(DEFUN ADD-RECT (LIST X Y WIDTH HEIGHT &AUX (RIGHT (+ X WIDTH)) (BOTTOM (+ Y HEIGHT)))
  (DO ((RLIST LIST (CDR RLIST))
       (RECT)
       (RBOTTOM)
       (RRIGHT))
      (NIL)
    (COND ((OR (NULL RLIST)			;If above all others, just add this one
	       (< BOTTOM (SECOND (SETQ RECT (CAR RLIST)))))
	   (PUSH (LIST X Y WIDTH HEIGHT) LIST)
	   (RETURN)))
    (COND ((< Y (SECOND RECT))			;Handle part above all others
	   (COND ((AND (= X (FIRST RECT)) (= WIDTH (THIRD RECT)))
		  (SETF (FOURTH RECT) (- (+ (SECOND RECT) (FOURTH RECT)) Y))
		  (SETF (SECOND RECT) Y)
		  (SETQ Y (+ Y (FOURTH RECT))))
		 (T
		  (PUSH (LIST X Y WIDTH (- (SECOND RECT) Y)) LIST)
		  (SETQ Y (SECOND RECT))))
	   (OR (PLUSP (SETQ HEIGHT (- BOTTOM Y))) (RETURN))))
    (COND ((> Y (SETQ RBOTTOM (+ (SECOND RECT) (FOURTH RECT)))))
	  ((= Y RBOTTOM)			;Can extend to the bottom
	   (COND ((AND (= X (FIRST RECT)) (= WIDTH (THIRD RECT)))
		  (SETF (FOURTH RECT) (- BOTTOM (SECOND RECT)))
		  (RETURN))))
	  (T					;Consider part that overlaps this rectangle
	   (COND ((NOT (OR (< RIGHT (FIRST RECT))
			   (> X (SETQ RRIGHT (+ (FIRST RECT) (THIRD RECT))))))
		  (COND ((OR (< X (FIRST RECT)) (> RIGHT RRIGHT))
			 (COND ((> Y (SECOND RECT))	;Fragment the top
				(PUSH (LIST (FIRST RECT) (SECOND RECT) (THIRD RECT)
					    (- Y (SECOND RECT)))
				      LIST)
				(SETF (SECOND RECT) Y)
				(SETF (FOURTH RECT) (- RBOTTOM Y))))
			 (COND ((< BOTTOM RBOTTOM)	;Fragment the bottom
				(PUSH (LIST (FIRST RECT) BOTTOM (THIRD RECT)
					    (- RBOTTOM BOTTOM))
				      LIST)
				(SETF (FOURTH RECT) (- Y (SECOND RECT)))))))
		  (SETF (FIRST RECT) (MIN X (FIRST RECT)))
		  (SETF (THIRD RECT) (- (MAX RIGHT RRIGHT) (FIRST RECT)))
		  (SETQ Y RBOTTOM)
		  (OR (PLUSP (SETQ HEIGHT (- BOTTOM Y))) (RETURN)))))))
  LIST)

(DEFVAR CORNER-LENGTH 100)			;The length of displayed corners
(DEFVAR EDGE-WIDTH 4)				;The width of displayed edges

;;; Add just the corner of a window
(DEFUN ADD-CORNER (LIST LEFT-P TOP-P LEFT TOP RIGHT BOTTOM)
  (SETQ LIST (ADD-RECT LIST (IF LEFT-P LEFT (- RIGHT CORNER-LENGTH))
		       (IF TOP-P TOP (- BOTTOM EDGE-WIDTH))
		       CORNER-LENGTH EDGE-WIDTH))
  (ADD-RECT LIST (IF LEFT-P LEFT (- RIGHT EDGE-WIDTH))
	    (IF TOP-P TOP (- BOTTOM CORNER-LENGTH))
	    EDGE-WIDTH CORNER-LENGTH))

;;; Add a window's corners or edge to the movement list
;;; ON-P means only turn things on, not off
(DEFUN ADD-MOVING-WINDOW (WINDOW-AND-EDGES EDGE-OR-CORNER WINDOW-MOVEMENT-ALIST
			  &OPTIONAL ON-P &AUX EDGES)
  (OR (SETQ EDGES (ASSQ WINDOW-AND-EDGES WINDOW-MOVEMENT-ALIST))
      (PUSH (SETQ EDGES (LIST WINDOW-AND-EDGES NIL NIL NIL NIL))
	    WINDOW-MOVEMENT-ALIST))
  (SELECTQ EDGE-OR-CORNER
    (:LEFT
     (SETF (SECOND EDGES) (SETQ ON-P (OR (NOT (SECOND EDGES)) ON-P))))
    (:TOP
     (SETF (THIRD EDGES) (SETQ ON-P (OR (NOT (THIRD EDGES)) ON-P))))
    (:RIGHT
     (SETF (FOURTH EDGES) (SETQ ON-P (OR (NOT (FOURTH EDGES)) ON-P))))
    (:BOTTOM
     (SETF (FIFTH EDGES) (SETQ ON-P (OR (NOT (FIFTH EDGES)) ON-P))))
    (:TOP-LEFT
     (SETF (THIRD EDGES) (SETQ ON-P (OR (NOT (AND (SECOND EDGES) (THIRD EDGES))) ON-P)))
     (SETF (SECOND EDGES) ON-P))
    (:TOP-RIGHT
     (SETF (FOURTH EDGES) (SETQ ON-P (OR (NOT (AND (THIRD EDGES) (FOURTH EDGES))) ON-P)))
     (SETF (THIRD EDGES) ON-P))
    (:BOTTOM-LEFT
     (SETF (FIFTH EDGES) (SETQ ON-P (OR (NOT (AND (SECOND EDGES) (FIFTH EDGES))) ON-P)))
     (SETF (SECOND EDGES) ON-P))
    (:BOTTOM-RIGHT
     (SETF (FIFTH EDGES) (SETQ ON-P (OR (NOT (AND (FOURTH EDGES) (FIFTH EDGES))) ON-P)))
     (SETF (FOURTH EDGES) ON-P))
    (:OTHERWISE
     (FERROR NIL "~A invalid edge//corner descriptor.")))
  (PROG () (RETURN WINDOW-MOVEMENT-ALIST ON-P)))

;;; Return the corner or edge of a window associated with another
;;; This could somehow take frames into account, i have no idea how though
(DEFUN ASSOCIATED-CORNER-OR-EDGE (WINDOW-AND-EDGES CORNER-OR-EDGE OTHER-WINDOW-AND-EDGES
				  &AUX LEFT TOP RIGHT BOTTOM
				       OLEFT OTOP ORIGHT OBOTTOM)
  (SETQ LEFT (THIRD WINDOW-AND-EDGES)
	TOP (FOURTH WINDOW-AND-EDGES)
	RIGHT (FIFTH WINDOW-AND-EDGES)
	BOTTOM (SIXTH WINDOW-AND-EDGES)
	OLEFT (THIRD OTHER-WINDOW-AND-EDGES)
	OTOP (FOURTH OTHER-WINDOW-AND-EDGES)
	ORIGHT (FIFTH OTHER-WINDOW-AND-EDGES)
	OBOTTOM (SIXTH OTHER-WINDOW-AND-EDGES))
  (AND (NEQ WINDOW-AND-EDGES OTHER-WINDOW-AND-EDGES)
       (SELECTQ CORNER-OR-EDGE
	 (:LEFT (AND (= LEFT ORIGHT) ( TOP OTOP) ( BOTTOM OBOTTOM) ':RIGHT))
	 (:TOP (AND (= TOP OBOTTOM) ( LEFT OLEFT) ( RIGHT ORIGHT) ':BOTTOM))
	 (:RIGHT (AND (= RIGHT OLEFT) ( TOP OTOP) ( BOTTOM OBOTTOM) ':LEFT))
	 (:BOTTOM (AND (= BOTTOM OTOP) ( LEFT OLEFT) ( RIGHT ORIGHT) ':TOP))
	 (:TOP-LEFT
	  (COND ((= LEFT OLEFT) (AND (= TOP OBOTTOM) ':BOTTOM-LEFT))
		(( LEFT ORIGHT) NIL)
		((= TOP OTOP) ':TOP-RIGHT)
		((= TOP OBOTTOM) ':BOTTOM-RIGHT)))
	 (:TOP-RIGHT
	  (COND ((= RIGHT ORIGHT) (AND (= TOP OBOTTOM) ':BOTTOM-RIGHT))
		(( RIGHT OLEFT) NIL)
		((= TOP OTOP) ':TOP-LEFT)
		((= TOP OBOTTOM) ':BOTTOM-LEFT)))
	 (:BOTTOM-LEFT
	  (COND ((= LEFT OLEFT) (AND (= BOTTOM OTOP) ':TOP-LEFT))
		(( LEFT ORIGHT) NIL)
		((= BOTTOM OBOTTOM) ':BOTTOM-RIGHT)
		((= BOTTOM OTOP) ':TOP-RIGHT)))
	 (:BOTTOM-RIGHT
	  (COND ((= RIGHT ORIGHT) (AND (= BOTTOM OTOP) ':TOP-RIGHT))
		(( RIGHT OLEFT) NIL)
		((= BOTTOM OBOTTOM) ':BOTTOM-LEFT)
		((= BOTTOM OTOP) ':TOP-LEFT))))))

;;; Make the rectangle list for a given list of window movements
(DEFUN CONSTRUCT-MOVEMENT-RECTANGLE-LIST (WINDOW-MOVEMENT-ALIST)
  (DO ((ALIST WINDOW-MOVEMENT-ALIST (CDR ALIST))
       (WINDOW-AND-MOVING-EDGES)
       (LIST NIL)
       (LEFT) (TOP)
       (RIGHT) (BOTTOM))
      ((NULL ALIST)
       LIST)
    (SETQ WINDOW-AND-MOVING-EDGES (CAR ALIST))
    (SETQ LEFT (THIRD (FIRST WINDOW-AND-MOVING-EDGES))
	  TOP (FOURTH (FIRST WINDOW-AND-MOVING-EDGES))
	  RIGHT (FIFTH (FIRST WINDOW-AND-MOVING-EDGES))
	  BOTTOM (SIXTH (FIRST WINDOW-AND-MOVING-EDGES)))
    ;; If there is just one corner, light it up as a corner
    (IF (MEMBER (CDR WINDOW-AND-MOVING-EDGES)
		'((T T NIL NIL) (NIL T T NIL) (NIL NIL T T) (T NIL NIL T)))
	(SETQ LIST (ADD-CORNER LIST
			       (SECOND WINDOW-AND-MOVING-EDGES)
			       (THIRD WINDOW-AND-MOVING-EDGES)
			       LEFT TOP RIGHT BOTTOM))
	(AND (SECOND WINDOW-AND-MOVING-EDGES)	;Left
	     (SETQ LIST (ADD-RECT LIST LEFT TOP EDGE-WIDTH (- BOTTOM TOP))))
	(AND (THIRD WINDOW-AND-MOVING-EDGES)	;Top
	     (SETQ LIST (ADD-RECT LIST LEFT TOP (- RIGHT LEFT) EDGE-WIDTH)))
	(AND (FOURTH WINDOW-AND-MOVING-EDGES)	;Right
	     (SETQ LIST (ADD-RECT LIST (- RIGHT EDGE-WIDTH) TOP EDGE-WIDTH (- BOTTOM TOP))))
	(AND (FIFTH WINDOW-AND-MOVING-EDGES)	;Bottom
	     (SETQ LIST (ADD-RECT LIST LEFT (- BOTTOM EDGE-WIDTH) (- RIGHT LEFT)
				  EDGE-WIDTH))))))

(DEFVAR MULTIPLE-MOVE-BLINKER)
(DEFVAR MULTIPLE-MOVE-RELEASE-TIME 60.)		;1 second hold-down to start moving things
(DEFFLAVOR MOUSE-MULTIPLE-RECTANGLE-BLINKER
	()
	(MOUSE-BLINKER-MIXIN MULTIPLE-RECTANGLE-BLINKER))

(COMPILE-FLAVOR-METHODS MOUSE-MULTIPLE-RECTANGLE-BLINKER)
(MOUSE-DEFINE-BLINKER-TYPE ':MULTIPLE-RECTANGLE
			   #'(LAMBDA (SCREEN)
			       (DEFINE-BLINKER SCREEN 'MOUSE-MULTIPLE-RECTANGLE-BLINKER
						  ':RECTANGLE-LIST NIL ':VISIBILITY NIL
						  ':FOLLOW-P NIL ':X-POS 0 ':Y-POS 0)))

;;; Screen editor multiple moving command
(DEFUN SEC-MULTIPLE-MOVE (TOP-SHEET WINDOW-EDGE-ALIST)
  (INITIALIZE-MULTIPLE-MOVE-BLINKER TOP-SHEET)
  (PROCESS-WAIT "Button up" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
  (WITH-MOUSE-GRABBED
   (UNWIND-PROTECT
    (DO-NAMED ABORT
	((MOVEMENT-LIST NIL)
	 (WINDOW-AND-EDGES) (CORNER-OR-EDGE)
	 (ON-P) (RECTANGLE-LIST))
	(NIL)
      (MULTIPLE-VALUE (WINDOW-AND-EDGES CORNER-OR-EDGE)
	(FIND-EDGE-OR-CORNER WINDOW-EDGE-ALIST))
      (AND (BIT-TEST 6 MOUSE-LAST-BUTTONS)	;Middle or right button aborts
	   (RETURN-FROM ABORT))
      (COND ((BIT-TEST 1 MOUSE-LAST-BUTTONS)	;Left button changes things
	     (MULTIPLE-VALUE (MOVEMENT-LIST ON-P)
	       (ADD-MOVING-WINDOW WINDOW-AND-EDGES CORNER-OR-EDGE MOVEMENT-LIST))
	     ;; If we turned things on, also turn on the associated things
	     (AND ON-P
		  (DOLIST (OTHER-WINDOW-AND-EDGES WINDOW-EDGE-ALIST)
		    (LET ((ASSOCIATED-CORNER-OR-EDGE (ASSOCIATED-CORNER-OR-EDGE
						       WINDOW-AND-EDGES CORNER-OR-EDGE
						       OTHER-WINDOW-AND-EDGES)))
		      (AND ASSOCIATED-CORNER-OR-EDGE
			   (SETQ MOVEMENT-LIST (ADD-MOVING-WINDOW OTHER-WINDOW-AND-EDGES
								  ASSOCIATED-CORNER-OR-EDGE
								  MOVEMENT-LIST T))))))
	     (SETQ RECTANGLE-LIST (CONSTRUCT-MOVEMENT-RECTANGLE-LIST MOVEMENT-LIST))
	     (FUNCALL MULTIPLE-MOVE-BLINKER ':SET-RECTANGLE-LIST RECTANGLE-LIST)
	     (PROCESS-WAIT "Button"
			   #'(LAMBDA (TIME)
			       (OR (ZEROP MOUSE-LAST-BUTTONS)
				   (> (TIME-DIFFERENCE (TIME) TIME)
				      MULTIPLE-MOVE-RELEASE-TIME)))
			   (TIME))))
      (COND ((NOT (ZEROP MOUSE-LAST-BUTTONS))	;Still held down?
	     (SETQ WINDOW-EDGE-ALIST (DO-MULTIPLE-MOVE TOP-SHEET WINDOW-EDGE-ALIST
						       RECTANGLE-LIST MOVEMENT-LIST))
	     (RETURN T))))
    (BLINKER-SET-VISIBILITY MULTIPLE-MOVE-BLINKER NIL)))
  WINDOW-EDGE-ALIST)

(DEFUN GET-MOVEMENT-DELTA (&AUX (STARTING-X MOUSE-X) (STARTING-Y MOUSE-Y))
  (PROCESS-WAIT "Release" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
  (PROCESS-WAIT "Moving" #'(LAMBDA () (NOT (ZEROP MOUSE-LAST-BUTTONS))))
  (PROG () (RETURN (- MOUSE-X STARTING-X) (- MOUSE-Y STARTING-Y))))

;;; Make an absolute rectangle list relative to its upper-left corner for moving with mouse
(DEFUN RELATIVE-RECTANGLE-LIST (LIST &AUX (MIN-X 177777) (MIN-Y 177777))
  (DOLIST (RECT LIST)
    (SETQ MIN-X (MIN MIN-X (FIRST RECT))
	  MIN-Y (MIN MIN-Y (SECOND RECT))))
  (DOLIST (RECT LIST)
    (SETF (FIRST RECT) (- (FIRST RECT) MIN-X))
    (SETF (SECOND RECT) (- (SECOND RECT) MIN-Y)))
  (PROG () (RETURN MIN-X MIN-Y LIST)))

(DEFUN INITIALIZE-MULTIPLE-MOVE-BLINKER (TOP-SHEET)
  (LET ((BL (MOUSE-GET-BLINKER ':MULTIPLE-RECTANGLE TOP-SHEET)))
    (FUNCALL BL ':SET-RECTANGLE-LIST NIL)
    (FUNCALL BL ':SET-CURSORPOS 0 0)
    (FUNCALL BL ':SET-VISIBILITY T)
    (SETQ MULTIPLE-MOVE-BLINKER BL)))

(DEFUN DO-MULTIPLE-MOVE (TOP-SHEET WINDOW-EDGE-ALIST RECTANGLE-LIST MOVEMENT-LIST)
  (WITH-MOUSE-GRABBED
    (WITHOUT-INTERRUPTS				;Don't spastically appear at the top left,
      (OPEN-BLINKER MULTIPLE-MOVE-BLINKER)	; and open while destructively modifying
      (MULTIPLE-VALUE-BIND (X Y L)		; the blinker's RECTANGLE-LIST.
	  (RELATIVE-RECTANGLE-LIST RECTANGLE-LIST)
	(MOUSE-SET-BLINKER-DEFINITION ':MULTIPLE-RECTANGLE 0 0 T ':SET-RECTANGLE-LIST L)
	(MOUSE-WARP X Y)))
    (DO ((MIN-X (SHEET-INSIDE-LEFT TOP-SHEET))
	 (MAX-X (SHEET-INSIDE-RIGHT TOP-SHEET))
	 (MIN-Y (SHEET-INSIDE-TOP TOP-SHEET))
	 (MAX-Y (SHEET-INSIDE-BOTTOM TOP-SHEET))
	 (NEW-EDGE-ALIST)
	 (DELTA-X) (DELTA-Y))
	(NIL)
      (SETQ NEW-EDGE-ALIST WINDOW-EDGE-ALIST)
      (MULTIPLE-VALUE (DELTA-X DELTA-Y)
	(GET-MOVEMENT-DELTA))
      (IF (BIT-TEST MOUSE-LAST-BUTTONS 6)	;Middle or right abort
	  (RETURN NIL)
	  (IF (DOLIST (MOVE MOVEMENT-LIST)
		(LET ((NEW-EDGES (COPYLIST (CAR MOVE))))
		  (AND (SECOND MOVE)
		       (LET ((NEW-LEFT (+ (THIRD NEW-EDGES) DELTA-X)))
			 (AND (OR (< NEW-LEFT MIN-X) ( NEW-LEFT MAX-X))
			      (RETURN T))
			 (SETF (THIRD NEW-EDGES) NEW-LEFT)))
		  (AND (THIRD MOVE)
		       (LET ((NEW-TOP (+ (FOURTH NEW-EDGES) DELTA-Y)))
			 (AND (OR (< NEW-TOP MIN-Y) ( NEW-TOP MAX-Y))
			      (RETURN T))
			 (SETF (FOURTH NEW-EDGES) NEW-TOP)))
		  (AND (FOURTH MOVE)
		       (LET ((NEW-RIGHT (+ (FIFTH NEW-EDGES) DELTA-X)))
			 (AND (OR (< NEW-RIGHT MIN-X) ( NEW-RIGHT MAX-X))
			      (RETURN T))
			 (SETF (FIFTH NEW-EDGES) NEW-RIGHT)))
		  (AND (FIFTH MOVE)
		       (LET ((NEW-BOTTOM (+ (SIXTH NEW-EDGES) DELTA-Y)))
			 (AND (OR (< NEW-BOTTOM MIN-Y) ( NEW-BOTTOM MAX-Y))
			      (RETURN T))
			 (SETF (SIXTH NEW-EDGES) NEW-BOTTOM)))
		  (SETQ NEW-EDGE-ALIST (SUBSTQ NEW-EDGES (CAR MOVE) NEW-EDGE-ALIST))))
	      (BEEP)				;Something off the screen
	      (SETQ WINDOW-EDGE-ALIST NEW-EDGE-ALIST)		     
	      (RETURN T)))))
  WINDOW-EDGE-ALIST)

(DEFUN SEC-SINGLE-MOVE (TOP-SHEET WINDOW-EDGE-ALIST)
  (INITIALIZE-MULTIPLE-MOVE-BLINKER TOP-SHEET)
  (PROCESS-WAIT "Button up" #'(LAMBDA () (ZEROP MOUSE-LAST-BUTTONS)))
  (WITH-MOUSE-GRABBED
   (UNWIND-PROTECT
     (MULTIPLE-VALUE-BIND (WINDOW-AND-EDGES CORNER-OR-EDGE)
	 (FIND-EDGE-OR-CORNER WINDOW-EDGE-ALIST)
       (COND ((NOT (BIT-TEST 6 MOUSE-LAST-BUTTONS))	;Middle or right button aborts
	      (LET* ((MOVEMENT-LIST (ADD-MOVING-WINDOW WINDOW-AND-EDGES CORNER-OR-EDGE NIL))
		     (RECTANGLE-LIST (CONSTRUCT-MOVEMENT-RECTANGLE-LIST MOVEMENT-LIST)))
		(SETQ WINDOW-EDGE-ALIST (DO-MULTIPLE-MOVE TOP-SHEET WINDOW-EDGE-ALIST
							  RECTANGLE-LIST MOVEMENT-LIST))))))
    (BLINKER-SET-VISIBILITY MULTIPLE-MOVE-BLINKER NIL)))
  WINDOW-EDGE-ALIST)

(COMPILE-FLAVOR-METHODS MOUSE-FOLLOWING-ARROW-BLINKER MOUSE-BOX-BLINKER)