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

(DEFUN %DRAW-RECTANGLE-CLIPPED (WIDTH HEIGHT X-BITPOS Y-BITPOS ALU-FUNCTION SHEET)
  (AND (MINUSP X-BITPOS) (SETQ WIDTH (+ WIDTH X-BITPOS)
			       X-BITPOS 0))
  (AND (MINUSP Y-BITPOS) (SETQ HEIGHT (+ HEIGHT Y-BITPOS)
			       Y-BITPOS 0))
  (SETQ WIDTH (MIN WIDTH (MAX 0 (- (SHEET-WIDTH SHEET) X-BITPOS))))
  (SETQ HEIGHT (MIN HEIGHT (MAX 0 (- (SHEET-HEIGHT SHEET) Y-BITPOS))))
  (AND (> WIDTH 0) (> HEIGHT 0)
       (%DRAW-RECTANGLE WIDTH HEIGHT X-BITPOS Y-BITPOS ALU-FUNCTION SHEET)))

;;;This takes arguments relative to the inside and clips inside
(DEFUN DRAW-RECTANGLE-INSIDE-CLIPPED (WIDTH HEIGHT X-BITPOS Y-BITPOS ALU-FUNCTION SHEET
				      &AUX (INSIDE-LEFT (SHEET-INSIDE-LEFT SHEET))
					   (INSIDE-TOP (SHEET-INSIDE-TOP SHEET)))
  (SETQ X-BITPOS (+ X-BITPOS INSIDE-LEFT)
	Y-BITPOS (+ Y-BITPOS INSIDE-TOP))
  (AND (< X-BITPOS INSIDE-LEFT) (SETQ WIDTH (- WIDTH (- INSIDE-LEFT X-BITPOS))
				     X-BITPOS INSIDE-LEFT))
  (AND (< Y-BITPOS INSIDE-TOP) (SETQ HEIGHT (- HEIGHT (- INSIDE-TOP Y-BITPOS))
				       Y-BITPOS INSIDE-TOP))
  (SETQ WIDTH (MIN WIDTH (MAX 0 (- (SHEET-INSIDE-RIGHT SHEET) X-BITPOS))))
  (SETQ HEIGHT (MIN HEIGHT (MAX 0 (- (SHEET-INSIDE-BOTTOM SHEET) Y-BITPOS))))
  (AND (> WIDTH 0) (> HEIGHT 0)
       (%DRAW-RECTANGLE WIDTH HEIGHT X-BITPOS Y-BITPOS ALU-FUNCTION SHEET)))

;;;Primitives
(DEFMETHOD (SHEET :PRINT-SELF) (STREAM IGNORE SLASHIFY-P)
  (IF SLASHIFY-P
      (FORMAT STREAM "#<~A ~A ~O ~A>"
	      (TYPEP SELF) NAME (%POINTER SELF)
	      (IF EXPOSED-P "exposed"
		  (IF (OR (NULL SUPERIOR)
			  (MEMQ SELF (SHEET-INFERIORS SUPERIOR)))
		      "deexposed"
		      "deactivated")))
      (FUNCALL STREAM ':STRING-OUT (STRING (OR (FUNCALL-SELF ':NAME-FOR-SELECTION) NAME)))))

;;;Compute offsets for one sheet within another (WINDOW within TOP)
(DEFUN SHEET-CALCULATE-OFFSETS (WINDOW TOP)
  (DO ((W WINDOW (SHEET-SUPERIOR W))
       (X-OFFSET 0)
       (Y-OFFSET 0))
      ((EQ W TOP)
       (PROG () (RETURN X-OFFSET Y-OFFSET)))
      (SETQ X-OFFSET (+ X-OFFSET (SHEET-X W))
	    Y-OFFSET (+ Y-OFFSET (SHEET-Y W)))))

(DEFUN SHEET-ME-OR-MY-KID-P (SHEET ME)
  (DO ((SHEET SHEET (SHEET-SUPERIOR SHEET)))
      ((NULL SHEET) NIL)
    (AND (EQ SHEET ME) (RETURN T))))

(DEFUN SHEET-GET-SCREEN (SHEET &OPTIONAL HIGHEST)
  (DO ((SHEET SHEET SUPERIOR)
       (SUPERIOR SHEET (SHEET-SUPERIOR SUPERIOR)))
      ((OR (NULL SUPERIOR)
	   (EQ SUPERIOR HIGHEST))
       SHEET)))

;;; Call the given function on all the sheets in the universe.
(DEFUN MAP-OVER-EXPOSED-SHEETS (FUNCTION)
  (DOLIST (SCREEN ALL-THE-SCREENS)
    (MAP-OVER-EXPOSED-SHEET FUNCTION SCREEN)))

(DEFUN MAP-OVER-EXPOSED-SHEET (FUNCTION SHEET)
  (DOLIST (SHEET (SHEET-EXPOSED-INFERIORS SHEET))
    (MAP-OVER-EXPOSED-SHEET FUNCTION SHEET))
  (FUNCALL FUNCTION SHEET))

(DEFUN MAP-OVER-SHEETS (FUNCTION)
  (DOLIST (SCREEN ALL-THE-SCREENS)
    (MAP-OVER-SHEET FUNCTION SCREEN)))

(DEFUN MAP-OVER-SHEET (FUNCTION SHEET)
  (DOLIST (SHEET (SHEET-INFERIORS SHEET))
    (MAP-OVER-SHEET FUNCTION SHEET))
  (FUNCALL FUNCTION SHEET))

;; This page implements locking for the window system.  The lock of a SHEET can be
;; in one of the following states:
;; Lock cell is NIL -- no lock, LOCK-COUNT must be zero
;; Lock cell is an atom and
;;  the lock count equals the lock count of the superior then
;;   the sheet is locked, but can be temp locked by any inferior of the lowest superior
;;   that is actually locked (lock-plus state).
;;  the lock count is greater than the lock count of the superior then
;;   the sheet is really locked, and can only be locked by the same unique ID.
;; Lock cell is a list then
;;  the sheet is temp locked by the windows in that list
;;  and if the lock count is non-zero then the window is also lock-plus.

;; What all this says, essentially, is that you can get the lock on the sheet
;; and the sheet can be temp locked if all the temp lockers are being locked by
;; the same operation that is locking the original sheet (these locks can happen in
;; either order)

(DEFUN SHEET-CAN-GET-LOCK (SHEET &OPTIONAL (UNIQUE-ID CURRENT-PROCESS))
  "Returns T if a sheet's lock can be gotten.  Should be called with interrupts
inhibited if it's to be meaningful."
  (SHEET-CAN-GET-LOCK-INTERNAL SHEET UNIQUE-ID SHEET))

(DEFUN SHEET-CAN-GET-LOCK-INTERNAL (SHEET UID WITH-RESPECT-TO &AUX LOCK)
  (COND ((EQ (SETQ LOCK (SHEET-LOCK SHEET)) UID)
	 ;; Lock already owned by unique-id, so return OK
	 T)
	((OR (NULL LOCK)
	     ;; If window is temp locked, the current sheet isn't the top-level one, and all
	     ;; of the temp lockers are inferiors of the top-level sheet, then it's ok
	     ;; to lock this sheet, so recurse
	     (AND (LISTP LOCK)
		  (NEQ SHEET WITH-RESPECT-TO)
		  (NOT (DOLIST (I LOCK)
			 (OR (SHEET-ME-OR-MY-KID-P SHEET WITH-RESPECT-TO)
			     (RETURN T))))))
	 (NOT (DOLIST (I (SHEET-INFERIORS SHEET))
		(OR (SHEET-CAN-GET-LOCK-INTERNAL I UID WITH-RESPECT-TO)
		    (RETURN T)))))
	(T NIL)))

(DEFUN SHEET-GET-LOCK (SHEET &OPTIONAL (UNIQUE-ID CURRENT-PROCESS))
  (DO ((INHIBIT-SCHEDULING-FLAG T T))
      (())
    (COND ((SHEET-CAN-GET-LOCK SHEET UNIQUE-ID)
	   (RETURN (SHEET-GET-LOCK-INTERNAL SHEET UNIQUE-ID)))
	  (T
	   (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	   (PROCESS-WAIT "Lock" #'SHEET-CAN-GET-LOCK SHEET UNIQUE-ID)))))

(DEFUN SHEET-GET-LOCK-INTERNAL (SHEET UNIQUE-ID)
  "Really get the lock on a sheet and its inferiors.  Must be INHIBIT-SCHEDULING-FLAG
bound and set to T.  The caller must guarantee the lock isn't locked by someone else."
  (OR (SHEET-LOCK SHEET)
      ;; If lock is currently non-NIL, then initialize it to the unique-id
      (SETF (SHEET-LOCK SHEET) UNIQUE-ID))
  ;; Always bump the lock count here
  (SETF (SHEET-LOCK-COUNT SHEET) (1+ (SHEET-LOCK-COUNT SHEET)))
  (DOLIST (INFERIOR (SHEET-INFERIORS SHEET))
    (SHEET-GET-LOCK-INTERNAL INFERIOR UNIQUE-ID)))

(DEFUN SHEET-RELEASE-LOCK (SHEET &OPTIONAL (UNIQUE-ID CURRENT-PROCESS)
				 &AUX (INHIBIT-SCHEDULING-FLAG T) LOCK)
  "Release a lock on a sheet and its inferiors"
  (COND ((OR (EQ UNIQUE-ID (SETQ LOCK (SHEET-LOCK SHEET)))
	     (AND LOCK (NOT (ZEROP (SHEET-LOCK-COUNT SHEET)))))
	 ;; If we own the lock, or if temp locked and the lock count is non-zero, then
	 ;; we must decrement the lock count
	 (SETF (SHEET-LOCK-COUNT SHEET) (1- (SHEET-LOCK-COUNT SHEET)))
	 (AND (ZEROP (SHEET-LOCK-COUNT SHEET))
	      (NOT (LISTP LOCK))
	      ;; If the count is currently zero, and the sheet is not temp-locked, then
	      ;; cler out the lock cell
	      (SETF (SHEET-LOCK SHEET) NIL))
	 (DOLIST (INFERIOR (SHEET-INFERIORS SHEET))
	   (SHEET-RELEASE-LOCK INFERIOR UNIQUE-ID)))))

(DEFUN SHEET-CAN-GET-TEMPORARY-LOCK (SHEET REQUESTOR &AUX LOCK)
  "Returns T if the lock can be grabbed.  Should be called with interrupts inhibited.
REQUESTOR is the temporary sheet that is going to cover SHEET."
  (COND ((NULL (SETQ LOCK (SHEET-LOCK SHEET)))
	 ;; Can always get temporary lock if no previous locker
	 T)
	(T
	 ;; Determine if sheet is in Lock, Temp-Lock, Lock-Plus, or Temp-Lock-Plus.
	 ;; If 
	 (LET* ((LC (SHEET-LOCK-COUNT SHEET))
		(SUP (SHEET-SUPERIOR SHEET))
		;; In plus state if sheet's lock count is the same as that of its superior,
		;; and the lock count is non-zero (this is for the case of a window being
		;; in temp-lock state, but not being plussified)
		(PLUS (AND (NOT (ZEROP LC)) (= LC (SHEET-LOCK-COUNT SUP)))))
	   (COND (PLUS
		  ;; In plus state, determine if we are a valid temp locker (we must be
		  ;; an inferior (direct or indirect) of the lowest superior that is not
		  ;; in the plus state)
		  (SHEET-ME-OR-MY-KID-P REQUESTOR
					(DO (NSUP) (())
					  (SETQ NSUP (SHEET-SUPERIOR SUP))
					  (AND (OR (NULL NSUP)
						   (> LC (SHEET-LOCK-COUNT NSUP)))
					       ;; Found where the buck stops, return the sheet
					       (RETURN SUP)))))
		 (T
		  ;; Otherwise, only ok to lock if already temp locked
		  (LISTP LOCK)))))))

(DEFUN SHEET-GET-TEMPORARY-LOCK (SHEET REQUESTOR)
  "Get a temporary lock on a sheet.  Requestor is used as the unique-id."
  (DO ((INHIBIT-SCHEDULING-FLAG T T))
      ((SHEET-CAN-GET-TEMPORARY-LOCK SHEET REQUESTOR)
       ;; Make sure we lock in appropriate fashion (i.e. if the window is already temp locked
       ;; add another locker, else start the list).  We don't have to worry about
       ;; plus states, since SHEET-CAN-GET-TEMPORARY-LOCK already worried for us.
       (LET ((LOCK (SHEET-LOCK SHEET)))
	 (SETF (SHEET-LOCK SHEET)
	       (IF (LISTP LOCK)
		   (CONS REQUESTOR LOCK)
		   (NCONS REQUESTOR)))))
    (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    (PROCESS-WAIT "Lock" #'SHEET-CAN-GET-TEMPORARY-LOCK SHEET REQUESTOR)))

(DEFUN SHEET-FIND-LOCKER (SHEET)
  (DO ((SUP SHEET) (LOCK)) (())
    (SETQ SUP (SHEET-SUPERIOR SUP))
    (OR SUP (FERROR NIL
		    "Internal error - Lock count non-zero, but nobody is locked!"))
    (AND (ATOM (SETQ LOCK (SHEET-LOCK SUP)))
	 (RETURN LOCK))))

(DEFUN SHEET-RELEASE-TEMPORARY-LOCK (SHEET REQUESTOR &AUX (INHIBIT-SCHEDULING-FLAG T))
  "Release a temporary lock on a sheet."
  (LET ((LOCK (DELQ REQUESTOR (SHEET-LOCK SHEET))))
    (SETF (SHEET-LOCK SHEET)
	  (OR LOCK (IF (ZEROP (SHEET-LOCK-COUNT SHEET))
		       NIL
		       (SHEET-FIND-LOCKER SHEET))))))

(DEFUN SHEET-FREE-TEMPORARY-LOCKS (SHEET)
  "Free all temporary locks on a sheet by deexposing the sheets that own the lock."
  (DO ((LOCK (SHEET-LOCK SHEET) (SHEET-LOCK SHEET)))
      ((NULL LOCK) T)
    (OR (LISTP LOCK)
	(RETURN NIL))				;Not temporary locked, can't do anything
    (OR (= DTP-INSTANCE (%DATA-TYPE (SETQ LOCK (CAR LOCK))))
	(RETURN NIL))				;The lock isn't an instance, can't do anything
    (OR (GET-HANDLER-FOR LOCK ':DEEXPOSE)
	(RETURN NIL))				;An instance, but maybe not a window -- punt
    (COND ((LISTP (SHEET-LOCK LOCK))		;Is the locker also temp locked?
	   (OR (SHEET-FREE-TEMPORARY-LOCKS LOCK);Yes, free it up first.  If ok, keep going
	       (RETURN NIL))))
    (FUNCALL LOCK ':DEEXPOSE)))

(DEFUN SHEET-CLEAR-LOCKS ()
  "Called in an emergency to reset all locks"
  (DOLIST (SHEET ALL-THE-SCREENS)
    (SHEET-CLEAR-LOCKS-INTERNAL SHEET)))

(DEFUN SHEET-CLEAR-LOCKS-INTERNAL (SHEET)
  (SETF (SHEET-LOCK SHEET) NIL)
  (SETF (SHEET-LOCK-COUNT SHEET) 0)
  (SETF (SHEET-TEMPORARY-WINDOWS-LOCKED SHEET) NIL)
  (SETF (SHEET-INVISIBLE-TO-MOUSE-P SHEET) NIL)
  (DOLIST (SHEET (SHEET-INFERIORS SHEET))
    (SHEET-CLEAR-LOCKS-INTERNAL SHEET)))

(DEFUN SHEET-ASSURE-LOCK-AVAILABLE (SHEET)
  "Must be called with INHIBIT-SCHEDULING-FLAG bound to T.  Waits until the lock can be
gotten on SHEET, and returns in that state with scheduling inhibited."
  (DO () ((SHEET-CAN-GET-LOCK SHEET))
    (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    (PROCESS-WAIT "Lock" #'SHEET-CAN-GET-LOCK SHEET)
    (SETQ INHIBIT-SCHEDULING-FLAG T)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SHEET-MORE-LOCK-KLUDGE (FUN &REST ARGS)
  ;; **********************************************************************
  ;; ** The following is a total kludge and should not even be looked at **
  ;; **********************************************************************
  (LET ((INHIBIT-SCHEDULING-FLAG T)
	(OLD-LOCK-STATE) (CHAR))
    (UNWIND-PROTECT
      (PROGN
	(AND LOCK
	     (NEQ LOCK CURRENT-PROCESS)
	     (FERROR NIL "Attempt to **MORE** when sheet was not locked by current process."))
	(SETQ OLD-LOCK-STATE
	      (AND LOCK (SHEET-MORE-LOCK-KLUDGE-LOCK-STATE SELF (SHEET-LOCK-COUNT SUPERIOR))))
	(SETQ INHIBIT-SCHEDULING-FLAG NIL)
	(SETQ CHAR (LEXPR-FUNCALL FUN ARGS)))
      (AND OLD-LOCK-STATE (SHEET-GET-LOCK SELF))
      (SETQ INHIBIT-SCHEDULING-FLAG T)
      (AND OLD-LOCK-STATE
	   (SHEET-MORE-LOCK-KLUDGE-RESTORE-LOCK-STATE SELF OLD-LOCK-STATE))
      (PREPARE-SHEET (SELF)))		;Open blinkers.
    ;; ******************* End of total, complete, and utter kludge *******************
    CHAR)))

(DEFUN SHEET-MORE-LOCK-KLUDGE-LOCK-STATE (SHEET SUPERIOR-LC &OPTIONAL (STATE NIL))
  (DOLIST (I (SHEET-INFERIORS SHEET))
    (SETQ STATE (SHEET-MORE-LOCK-KLUDGE-LOCK-STATE I SUPERIOR-LC STATE)))
  (PUSH (CONS SHEET (- (SHEET-LOCK-COUNT SHEET) SUPERIOR-LC)) STATE)
  (OR (LISTP (SHEET-LOCK SHEET)) (SETF (SHEET-LOCK SHEET) NIL))
  (SETF (SHEET-LOCK-COUNT SHEET) SUPERIOR-LC)
  STATE)

(DEFUN SHEET-MORE-LOCK-KLUDGE-RESTORE-LOCK-STATE (SHEET STATE
						  &OPTIONAL (SUPERIOR-LOCK-COUNT 0)
						  &AUX LOCK-COUNT)
  ;; This code assumes that the caller has locked the sheet once already
  (SETF (SHEET-LOCK-COUNT SHEET)
	(SETQ LOCK-COUNT 
	      (+ SUPERIOR-LOCK-COUNT (SHEET-LOCK-COUNT SHEET)
		 (OR (CDR (ASSQ SHEET STATE)) 0)
		 -1)))
  (DOLIST (I (SHEET-INFERIORS SHEET))
    (SHEET-MORE-LOCK-KLUDGE-RESTORE-LOCK-STATE SHEET STATE LOCK-COUNT)))

(DEFUN SHEET-CAN-ACTIVATE-INFERIOR (SUPERIOR &AUX SUP-LOCK)
  (OR (NULL (SETQ SUP-LOCK (SHEET-LOCK SUPERIOR)))
      (AND (LISTP SUP-LOCK) (ZEROP (SHEET-LOCK-COUNT SUPERIOR)))
      (EQ SUP-LOCK CURRENT-PROCESS)
      (AND (LISTP SUP-LOCK) (EQ CURRENT-PROCESS (SHEET-FIND-LOCKER SUPERIOR)))))

(DEFMETHOD (SHEET :INFERIOR-ACTIVATE) (INFERIOR) INFERIOR)
(DEFMETHOD (SHEET :INFERIOR-DEACTIVATE) (INFERIOR) INFERIOR)
(DEFMETHOD (SHEET :INFERIOR-TIME-STAMP) (INFERIOR)
  INFERIOR					;Inferior getting stamped -- unused here
  TIME-STAMP)

(DEFMETHOD (SHEET :UPDATE-TIME-STAMP) ()
  (AND SUPERIOR
       (SETQ TIME-STAMP (FUNCALL SUPERIOR ':INFERIOR-TIME-STAMP SELF))))


;;; Activation and deactivation (these go with locking)
(DEFMETHOD (SHEET :ACTIVATE) (&AUX (INHIBIT-SCHEDULING-FLAG T))
  "Activates a sheet."
  (COND ((NOT (FUNCALL SUPERIOR ':INFERIOR-ACTIVATE SELF)))
	((DO () ((MEMQ SELF (SHEET-INFERIORS SUPERIOR)) NIL)
	   (COND ((NOT (SHEET-CAN-GET-LOCK SELF))
		  (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		  (PROCESS-WAIT "Lock" #'SHEET-CAN-GET-LOCK SELF)
		  (SETQ INHIBIT-SCHEDULING-FLAG T))
		 ((SHEET-CAN-ACTIVATE-INFERIOR SUPERIOR)
		  (OR (ZEROP (SHEET-LOCK-COUNT SUPERIOR))
		      ;; Superior is locked by us, must merge lock counts
		      (LOCK-SHEET (SELF)
			(LOCAL-DECLARE ((SPECIAL **ACTIVATE-LOCK-COUNT**))
			  (LET ((**ACTIVATE-LOCK-COUNT** (SHEET-LOCK-COUNT SUPERIOR)))
			    (MAP-OVER-SHEET #'(LAMBDA (SHEET)
						(SETF (SHEET-LOCK-COUNT SHEET)
						      (+ (SHEET-LOCK-COUNT SHEET)
							 **ACTIVATE-LOCK-COUNT**)))
					    SELF)))))
		  (RETURN T))
		 (T
		  (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		  ;; Wait for sheet to become activatable or to become activated
		  (PROCESS-WAIT "Activate" #'(LAMBDA (SHEET SUP)
					       (OR (SHEET-CAN-ACTIVATE-INFERIOR SUP)
						   (MEMQ SHEET (SHEET-INFERIORS SUP))))
				SELF SUPERIOR)
		  ;; Loop back to prevent timing screws
		  (SETQ INHIBIT-SCHEDULING-FLAG T))))
	 ;; Executed if we are not active already
	 (SHEET-SET-SUPERIOR-PARAMS SELF (SHEET-LOCATIONS-PER-LINE SUPERIOR))
	 (SHEET-CONSING
	   (SETF (SHEET-INFERIORS SUPERIOR)
		 (COPYLIST (CONS SELF (SHEET-INFERIORS SUPERIOR))))))))

(DEFWRAPPER (SHEET :DEACTIVATE) (IGNORE . BODY)
  `(LOCK-SHEET (SELF)
     (DELAYING-SCREEN-MANAGEMENT . ,BODY)))

(DEFMETHOD (SHEET :DEACTIVATE) (&AUX (INHIBIT-SCHEDULING-FLAG T))
  "Deactivates a sheet.  Should be called by all deactivate methods to do the actual work."
  (COND ((FUNCALL SUPERIOR ':INFERIOR-DEACTIVATE SELF)
	 (DO () ((NOT (MEMQ SELF (SHEET-EXPOSED-INFERIORS SUPERIOR))))
	   (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	   (FUNCALL-SELF ':DEEXPOSE)
	   (SETQ INHIBIT-SCHEDULING-FLAG T))
	 (COND ((MEMQ SELF (SHEET-INFERIORS SUPERIOR))
		(OR (ZEROP (SHEET-LOCK-COUNT SUPERIOR))
		    ;; Superior is locked by us, must subtract his lock count from ours
		    ;; because he isn't going to do it for us when he gets unlocked.
		    ;; (Note: the superior can't be locked by someone else as in the
		    ;; deactivate case because we own the lock on one of his inferiors (namely,
		    ;; us) preventing this situation from arising)
		    ;; That lock also prevents the lock count from going to zero in here.
		    (LOCAL-DECLARE ((SPECIAL **ACTIVATE-LOCK-COUNT**))
	              (LET ((**ACTIVATE-LOCK-COUNT** (SHEET-LOCK-COUNT SUPERIOR)))
			   (MAP-OVER-SHEET #'(LAMBDA (SHEET)
						     (SETF (SHEET-LOCK-COUNT SHEET)
							   (- (SHEET-LOCK-COUNT SHEET)
							      **ACTIVATE-LOCK-COUNT**)))
					   SELF))))
		(SETF (SHEET-INFERIORS SUPERIOR) (DELQ SELF (SHEET-INFERIORS SUPERIOR))))))))

(DEFMETHOD (SHEET :KILL) ()
  "Killing is equivalent to deactivating, but there are likely demons to be run."
  (FUNCALL-SELF ':DEACTIVATE))

(DEFUN SHEET-OVERLAPS-P (SHEET LEFT TOP WIDTH HEIGHT
			       &AUX (W-X (SHEET-X SHEET))
			            (W-Y (SHEET-Y SHEET))
				    (W-X1 (+ W-X (SHEET-WIDTH SHEET)))
				    (W-Y1 (+ W-Y (SHEET-HEIGHT SHEET))))
  "True if a sheet overlaps the given area"
  (NOT (OR ( LEFT W-X1)
	   ( W-X (+ LEFT WIDTH))
	   ( TOP W-Y1)
	   ( W-Y (+ TOP HEIGHT)))))

(DEFUN SHEET-OVERLAPS-EDGES-P (SHEET LEFT TOP RIGHT BOTTOM
			       &AUX (W-X (SHEET-X SHEET))
			            (W-Y (SHEET-Y SHEET))
				    (W-X1 (+ W-X (SHEET-WIDTH SHEET)))
				    (W-Y1 (+ W-Y (SHEET-HEIGHT SHEET))))
  "True if a sheet overlaps the given four coordinates"
  (NOT (OR ( LEFT W-X1)
	   ( W-X RIGHT)
	   ( TOP W-Y1)
	   ( W-Y BOTTOM))))

(DEFUN SHEET-OVERLAPS-SHEET-P (SHEET-A SHEET-B &AUX X-OFF-A X-OFF-B
				                    Y-OFF-A Y-OFF-B)
  "True if two sheets overlap"
  (COND ((EQ (SHEET-SUPERIOR SHEET-A) (SHEET-SUPERIOR SHEET-B))
	 ;; If superiors are the same, simple comparison
	 (SHEET-OVERLAPS-P SHEET-A (SHEET-X SHEET-B) (SHEET-Y SHEET-B)
			   (SHEET-WIDTH SHEET-B) (SHEET-HEIGHT SHEET-B)))
	(T
	 (MULTIPLE-VALUE (X-OFF-A Y-OFF-A)
	   (SHEET-CALCULATE-OFFSETS SHEET-A NIL))
	 (MULTIPLE-VALUE (X-OFF-B Y-OFF-B)
	   (SHEET-CALCULATE-OFFSETS SHEET-B NIL))
	 (NOT (OR ( X-OFF-A (+ X-OFF-B (SHEET-WIDTH SHEET-B)))
		  ( X-OFF-B (+ X-OFF-A (SHEET-WIDTH SHEET-A)))
		  ( Y-OFF-A (+ Y-OFF-B (SHEET-HEIGHT SHEET-B)))
		  ( Y-OFF-B (+ Y-OFF-A (SHEET-HEIGHT SHEET-A))))))))

(DEFUN SHEET-WITHIN-P (SHEET OUTER-LEFT OUTER-TOP OUTER-WIDTH OUTER-HEIGHT
			     &AUX (W-X (SHEET-X SHEET))
			          (W-Y (SHEET-Y SHEET))
				  (W-X1 (+ W-X (SHEET-WIDTH SHEET)))
				  (W-Y1 (+ W-Y (SHEET-HEIGHT SHEET))))
  "True if the sheet is fully within the specified rectangle"
  (AND ( OUTER-LEFT W-X)
       ( W-X1 (+ OUTER-LEFT OUTER-WIDTH))
       ( OUTER-TOP W-Y)
       ( W-Y1 (+ OUTER-TOP OUTER-HEIGHT))))

(DEFUN SHEET-BOUNDS-WITHIN-SHEET-P (W-X W-Y WIDTH HEIGHT OUTER-SHEET
					&AUX (OUTER-LEFT (SHEET-INSIDE-LEFT OUTER-SHEET))
					     (OUTER-TOP (SHEET-INSIDE-TOP OUTER-SHEET))
					     (OUTER-WIDTH (SHEET-INSIDE-WIDTH OUTER-SHEET))
					     (OUTER-HEIGHT (SHEET-INSIDE-HEIGHT OUTER-SHEET)))
  "True if the specified rectangle is fully within the non-margin part of the sheet"
  (AND ( OUTER-LEFT W-X)
       ( (+ W-X WIDTH) (+ OUTER-LEFT OUTER-WIDTH))
       ( OUTER-TOP W-Y)
       ( (+ W-Y HEIGHT) (+ OUTER-TOP OUTER-HEIGHT))))

(DEFUN SHEET-WITHIN-SHEET-P (SHEET OUTER-SHEET)
  "True if sheet is fully within the non-margin area of the outer sheet"
  (SHEET-WITHIN-P SHEET (SHEET-INSIDE-LEFT OUTER-SHEET) (SHEET-INSIDE-TOP OUTER-SHEET)
		        (SHEET-INSIDE-WIDTH OUTER-SHEET)
			(SHEET-INSIDE-HEIGHT OUTER-SHEET)))

(DEFUN SHEET-CONTAINS-SHEET-POINT-P (SHEET TOP-SHEET X Y)
  "T if (X,Y) lies in SHEET.  X and Y are co-ordinates in TOP-SHEET."
  (DO ((S SHEET (SHEET-SUPERIOR S))
       (X X (- X (SHEET-X S)))
       (Y Y (- Y (SHEET-Y S))))
      ((NULL S))			;Not in the same hierarchy, return nil
    (AND (EQ S TOP-SHEET)
	 (RETURN (AND ( X 0) ( Y 0)
		      (< X (SHEET-WIDTH SHEET)) (< Y (SHEET-HEIGHT SHEET)))))))

;;; A sheet is no longer "selected", blinkers are left on or turned off as wanted
(DEFUN DESELECT-SHEET-BLINKERS (SHEET)
  (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
    (AND (EQ (BLINKER-VISIBILITY BLINKER) ':BLINK)
	 (SETF (BLINKER-VISIBILITY BLINKER)
	       (BLINKER-DESELECTED-VISIBILITY BLINKER)))))

;;; Turn off blinkers, regardless of deselected-visibility
(DEFUN TURN-OFF-SHEET-BLINKERS (SHEET)
  (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
    (AND (MEMQ (BLINKER-VISIBILITY BLINKER) '(:BLINK :ON))
	 (SETF (BLINKER-VISIBILITY BLINKER) ':OFF))))

;;; A sheet is to be selected, make sure its blinkers are blinking if they should be
(DEFUN SELECT-SHEET-BLINKERS (SHEET)
  (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
    (AND (MEMQ (BLINKER-VISIBILITY BLINKER) '(:ON :OFF))
	 (SETF (BLINKER-VISIBILITY BLINKER) ':BLINK))))

(DEFUN SHEET-OPEN-ALL-BLINKERS (FROM-SHEET)
  (DO SHEET FROM-SHEET (SHEET-SUPERIOR SHEET) (NULL SHEET)
      (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
	(OPEN-BLINKER BLINKER))
      ;; If this sheet is not exposed, don't have to open blinkers on superior
      (OR (SHEET-EXPOSED-P SHEET) (RETURN NIL))))

(DEFUN SHEET-OPEN-BLINKERS (SHEET)
  (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
    (OPEN-BLINKER BLINKER)))

(DEFUN SHEET-FOLLOWING-BLINKER (SHEET)
  "Return NIL or the blinker which follows the sheet's cursorpos
  If there is more than one, which would be strange, only one is returned."
  (DOLIST (B (SHEET-BLINKER-LIST SHEET))
    (AND (BLINKER-FOLLOW-P B) (RETURN B))))

(DEFUN SHEET-PREPARE-SHEET-INTERNAL (SHEET &AUX LOCK)
  "This is an internal function for PREPARE-SHEET, and must be called with
INHIBIT-SCHEDULING-FLAG bound."
  (DO () ((AND (SETQ LOCK (SHEET-CAN-GET-LOCK SHEET))
	       (NOT (SHEET-OUTPUT-HELD-P SHEET))))
    (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    (IF LOCK
	(FUNCALL SHEET ':OUTPUT-HOLD-EXCEPTION)
	(PROCESS-WAIT "Lock" #'SHEET-CAN-GET-LOCK SHEET))
    (SETQ INHIBIT-SCHEDULING-FLAG T))
  (IF (SHEET-INFERIORS SHEET)
      (MAP-OVER-EXPOSED-SHEET
	#'(LAMBDA (SHEET)
	    (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
	      (OPEN-BLINKER BLINKER)))
	SHEET)
      ;; No need to do full hair if no inferiors
      (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
	(OPEN-BLINKER BLINKER)))
  (SHEET-OPEN-ALL-BLINKERS (SHEET-SUPERIOR SHEET)))

(DEFMETHOD (SHEET :EDGES) ()
  (PROG () (RETURN X-OFFSET Y-OFFSET (+ X-OFFSET WIDTH) (+ Y-OFFSET HEIGHT))))

(DEFMETHOD (SHEET :SIZE) ()
  (PROG () (RETURN WIDTH HEIGHT)))

(DEFMETHOD (SHEET :INSIDE-SIZE) ()
  (PROG () (RETURN (SHEET-INSIDE-WIDTH) (SHEET-INSIDE-HEIGHT))))

(DEFMETHOD (SHEET :INSIDE-EDGES) ()
  (PROG () (RETURN (SHEET-INSIDE-LEFT) (SHEET-INSIDE-TOP) (SHEET-INSIDE-RIGHT)
		   (SHEET-INSIDE-BOTTOM))))

(DEFMETHOD (SHEET :POSITION) ()
  (PROG () (RETURN X-OFFSET Y-OFFSET)))

(DEFMETHOD (SHEET :MARGINS) ()
  (PROG () (RETURN LEFT-MARGIN-SIZE TOP-MARGIN-SIZE RIGHT-MARGIN-SIZE BOTTOM-MARGIN-SIZE)))

 ;;; Screen management issues 
(DEFMETHOD (SHEET :NAME-FOR-SELECTION) () NIL)

(DEFMETHOD (SHEET :ORDER-INFERIORS) ()
  (WITHOUT-INTERRUPTS (SETQ INFERIORS (STABLE-SORT INFERIORS #'SHEET-PRIORITY-LESSP))))

(DEFMETHOD (SHEET :SET-PRIORITY) (NEW-PRIORITY)
  (CHECK-ARG NEW-PRIORITY (OR (NUMBERP NEW-PRIORITY) (NULL NEW-PRIORITY))
	     "a number or NIL" NUMBER-OR-NIL)
  (SETQ PRIORITY NEW-PRIORITY)
  (SCREEN-CONFIGURATION-HAS-CHANGED SELF))

(DEFMETHOD (SHEET :BEFORE :REFRESH) (&OPTIONAL IGNORE)
  (SCREEN-MANAGE-FLUSH-KNOWLEDGE SELF))

(DEFUN SHEET-PRIORITY-LESSP (S1 S2 &AUX (EI (SHEET-EXPOSED-INFERIORS (SHEET-SUPERIOR S1)))
					(PRI-S1 (SHEET-PRIORITY S1))
				        (PRI-S2 (SHEET-PRIORITY S2))
					(EX1 (MEMQ S1 EI))
					(EX2 (MEMQ S2 EI)))
  (COND ((AND EX1 (NOT EX2))
	 ;; First exposed, second not -- S1 on top
	 T)
	((AND (NOT EX1) EX2)
	 ;; Second exposed, first not -- S1 underneath
	 NIL)
	((OR (EQ PRI-S1 PRI-S2)
	     (AND EX1 EX2))
	 ;; Both exposed, or equal priority -- S2 remains on bottom
	 NIL)
	((AND (NULL PRI-S1) PRI-S1)
	 ;; S2 has explicit priority, and S1 doesn't -- S1 on bottom
	 NIL)
	((AND PRI-S1 (NULL PRI-S2))
	 ;; S1 has explicit priority, and S2 doesn't -- S1 on top
	 T)
	(T
	 ;; Both have explicit priority -- S2 on bottom if it's priority is less,
	 ;; stable if equal
	 ( PRI-S2 PRI-S1))))

;;;This does it all (somehow)
(DEFUN WINDOW-CREATE (FLAVOR-NAME &REST OPTIONS &AUX WINDOW (PLIST (LOCF OPTIONS)))
  (SETQ OPTIONS (COPYLIST OPTIONS)	;Allow RPLACD'ing
	WINDOW (INSTANTIATE-FLAVOR FLAVOR-NAME PLIST NIL NIL (OR (GET PLIST ':AREA)
								 SHEET-AREA)))
  (DELAYING-SCREEN-MANAGEMENT
    (FUNCALL WINDOW ':INIT PLIST)
    (AND (SHEET-BIT-ARRAY WINDOW)
	 (SHEET-FORCE-ACCESS (WINDOW :NO-PREPARE)
	   (FUNCALL WINDOW ':REFRESH ':COMPLETE-REDISPLAY)))
    (AND (GET PLIST ':ACTIVATE-P) (FUNCALL WINDOW ':ACTIVATE))
    (LET ((EXPOSE-P (GET PLIST ':EXPOSE-P)))
      (AND EXPOSE-P (LEXPR-FUNCALL WINDOW ':EXPOSE (IF (EQ EXPOSE-P T) NIL EXPOSE-P))))
    WINDOW))

(DEFWRAPPER (SHEET :INIT) (IGNORE . BODY)
  `(LOCK-SHEET (SELF)
     . ,BODY))

(DEFUN SHEET-ARRAY-TYPE (SHEET)
  (SELECTQ (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SHEET))
    (1 'ART-1B)
    (2 'ART-2B)
    (4 'ART-4B)
    (8 'ART-8B)
    (T 'ART-1B)))

(DEFMETHOD (SHEET :INIT) (INIT-PLIST &AUX BOTTOM RIGHT SAVE-BITS (VSP 2) (MORE-P T)
				          (CHARACTER-WIDTH NIL) (CHARACTER-HEIGHT NIL)
					  (REVERSE-VIDEO-P NIL) (INTEGRAL-P NIL)
					  (BLINKER-P T) (BLINK-FL 'RECTANGULAR-BLINKER)
					  (DESELECTED-VISIBILITY ':ON))
  ;; Process options
  (DOPLIST ((CAR INIT-PLIST) VAL OP)
    (SELECTQ OP
	((:LEFT :X) (SETQ X-OFFSET VAL))
	((:TOP :Y) (SETQ Y-OFFSET VAL))
	(:POSITION (SETQ X-OFFSET (FIRST VAL) Y-OFFSET (SECOND VAL)))
	(:RIGHT (SETQ RIGHT VAL))
	(:BOTTOM (SETQ BOTTOM VAL))
	(:SIZE (AND VAL (SETQ WIDTH (FIRST VAL)
			      HEIGHT (SECOND VAL))))
	(:EDGES (AND VAL (SETQ X-OFFSET (FIRST VAL)
			       Y-OFFSET (SECOND VAL)
			       RIGHT (THIRD VAL)
			       BOTTOM (FOURTH VAL))))
	(:CHARACTER-WIDTH (SETQ CHARACTER-WIDTH VAL))
	(:CHARACTER-HEIGHT (SETQ CHARACTER-HEIGHT VAL))
	(:BLINKER-P (SETQ BLINKER-P VAL))
	(:REVERSE-VIDEO-P (SETQ REVERSE-VIDEO-P VAL))
	(:MORE-P (SETQ MORE-P VAL))
	(:VSP (SETQ VSP VAL))
	(:BLINKER-FLAVOR (SETQ BLINK-FL VAL))
	(:BLINKER-DESELECTED-VISIBILITY (SETQ DESELECTED-VISIBILITY VAL))
	(:INTEGRAL-P (SETQ INTEGRAL-P VAL))
	(:SAVE-BITS (SETQ SAVE-BITS VAL))
	(:RIGHT-MARGIN-CHARACTER-FLAG (SETF (SHEET-RIGHT-MARGIN-CHARACTER-FLAG) VAL))
	(:BACKSPACE-NOT-OVERPRINTING-FLAG (SETF (SHEET-BACKSPACE-NOT-OVERPRINTING-FLAG) VAL))
	(:CR-NOT-NEWLINE-FLAG (SETF (SHEET-CR-NOT-NEWLINE-FLAG) VAL))
	(:TRUNCATE-LINE-OUT-FLAG (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG) VAL))
	(:DEEXPOSED-TYPEIN-ACTION (FUNCALL-SELF ':SET-DEEXPOSED-TYPEIN-ACTION VAL))
	(:TAB-NCHARS (SETF (SHEET-TAB-NCHARS) VAL))
	))
  (SHEET-DEDUCE-AND-SET-SIZES RIGHT BOTTOM VSP INTEGRAL-P CHARACTER-WIDTH CHARACTER-HEIGHT)
  (COND ((EQ SAVE-BITS 'T)
	 (LET ((DIMS (LIST (// (* 32. (SETQ LOCATIONS-PER-LINE
					    (SHEET-LOCATIONS-PER-LINE SUPERIOR)))
			       (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SELF)))
			   HEIGHT))
	       (ARRAY-TYPE (SHEET-ARRAY-TYPE (OR SUPERIOR SELF))))
	   (SETQ BIT-ARRAY
		 (IF BIT-ARRAY
		     (GROW-BIT-ARRAY BIT-ARRAY (CAR DIMS) (CADR DIMS) WIDTH)
		     (MAKE-ARRAY NIL ARRAY-TYPE DIMS)))
	   (SETQ SCREEN-ARRAY (MAKE-ARRAY NIL ARRAY-TYPE DIMS BIT-ARRAY NIL 0))))
	((EQ SAVE-BITS ':DELAYED)
	 (SETF (SHEET-FORCE-SAVE-BITS) 1)))
  (SETQ MORE-VPOS (AND MORE-P (SHEET-DEDUCE-MORE-VPOS SELF)))
  (COND (SUPERIOR
	 (OR BIT-ARRAY
	     (LET ((ARRAY (SHEET-SUPERIOR-SCREEN-ARRAY)))
	       (SETQ OLD-SCREEN-ARRAY
		     (MAKE-ARRAY NIL (ARRAY-TYPE ARRAY)
				 (LIST (ARRAY-DIMENSION-N 1 ARRAY) HEIGHT) ARRAY NIL
				 (+ X-OFFSET (* Y-OFFSET (ARRAY-DIMENSION-N 1 ARRAY)))))
	       (SETQ LOCATIONS-PER-LINE (SHEET-LOCATIONS-PER-LINE SUPERIOR))))
	 (AND BLINKER-P
	      (LEXPR-FUNCALL #'DEFINE-BLINKER SELF BLINK-FL
			     ':FOLLOW-P T ':DESELECTED-VISIBILITY DESELECTED-VISIBILITY
			     (AND (LISTP BLINKER-P) BLINKER-P)))))
  (SETF (SHEET-OUTPUT-HOLD-FLAG) 1)
  (OR (BOUNDP 'CHAR-ALUF) (SETQ CHAR-ALUF (IF REVERSE-VIDEO-P ALU-ANDCA ALU-IOR)))
  (OR (BOUNDP 'ERASE-ALUF) (SETQ ERASE-ALUF (IF REVERSE-VIDEO-P ALU-IOR ALU-ANDCA)))
  (FUNCALL-SELF ':UPDATE-TIME-STAMP)
  SELF)

(DEFMETHOD (SCREEN :BEFORE :INIT) (IGNORE)
  (OR (BOUNDP 'LOCATIONS-PER-LINE)
      (SETQ LOCATIONS-PER-LINE (// (* WIDTH BITS-PER-PIXEL) 32.)))
  (SETQ FONT-MAP (LIST DEFAULT-FONT)
	;; No one uses this anyway...
	BUFFER-HALFWORD-ARRAY (MAKE-ARRAY NIL 'ART-16B
					  (// (* WIDTH (OR HEIGHT 1) BITS-PER-PIXEL) 16.)
					  ;;Displaced to actual video buffer
					  BUFFER))
  (OR BIT-ARRAY
      (SETQ OLD-SCREEN-ARRAY (MAKE-ARRAY NIL (SHEET-ARRAY-TYPE SELF)
					 ;; this will get fixed later
					 (LIST WIDTH (OR HEIGHT 1))	;Dimensions
					 BUFFER))))

(DEFMETHOD (SCREEN :BEFORE :EXPOSE) (&REST IGNORE)
  (COND ((NOT EXPOSED-P)
	 (SETQ BUFFER-HALFWORD-ARRAY (MAKE-ARRAY NIL 'ART-16B
						 (// (* WIDTH HEIGHT BITS-PER-PIXEL) 16.)
						 ;;Displaced to actual video buffer
						 BUFFER))
	 (SI:CHANGE-INDIRECT-ARRAY OLD-SCREEN-ARRAY (ARRAY-TYPE OLD-SCREEN-ARRAY)
				   (LIST WIDTH HEIGHT)
				   (+ BUFFER (// (* Y-OFFSET WIDTH) 32.))
				   NIL))))

(DEFMETHOD (SCREEN :SELECTABLE-WINDOWS) ()
  (MAPCAN #'(LAMBDA (I) (FUNCALL I ':SELECTABLE-WINDOWS)) INFERIORS))

(DEFMETHOD (SHEET :IDLE-LISP-LISTENER) () 
  (IF SUPERIOR
      (FUNCALL SUPERIOR ':IDLE-LISP-LISTENER)
      (IDLE-LISP-LISTENER SELF)))

(DEFMETHOD (SHEET :ALIAS-FOR-SELECTED-WINDOWS) ()
  SELF)

(DEFMETHOD (SCREEN :PARSE-FONT-DESCRIPTOR) (FD)
  (SCREEN-PARSE-FONT-DESCRIPTOR FD 'FONTS:CPT-FONT))

(DEFUN SCREEN-PARSE-FONT-DESCRIPTOR (FD TYPE &OPTIONAL DONT-LOAD-P)
  (AND (TYPEP FD 'FONT) (BOUNDP (FONT-NAME FD))
       (SETQ FD (FONT-NAME FD)))
  (COND ((SYMBOLP FD)
	 ;; Name of font -- find appropriate font
	 (LET ((FONT (GET FD TYPE)))
	   (IF (NULL FONT)
	       (IF (BOUNDP FD)
		   (SYMEVAL FD)
		   (IF DONT-LOAD-P
		       (FERROR NIL "Font ~D not found" FD)
		       ;; Specifying FONTS package is to inhibit loading message.
		       (CATCH-ERROR (LOAD (FORMAT NIL "AI: LMFONT; ~A" FD) "FONTS" T T) NIL)
		       (SCREEN-PARSE-FONT-DESCRIPTOR FD TYPE T)))
	       (IF (SYMBOLP FONT)
		   (SCREEN-PARSE-FONT-DESCRIPTOR FONT TYPE)
		   FONT))))
	((TYPEP FD 'FONT) FD)
	(T (FERROR NIL "Illegal font descriptor ~A" FD))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SHEET-NEW-FONT-MAP (NEW-MAP VSP &AUX (SCREEN (SHEET-GET-SCREEN SELF)))
  (COND ((ARRAYP NEW-MAP))
	((LISTP NEW-MAP)
	 (LET* ((LENGTH (MAX (LENGTH NEW-MAP) 26.))
		(FM (MAKE-ARRAY LENGTH)))
	   (DO ((I 0 (1+ I))
		(L NEW-MAP (OR (CDR L) L)))
	       (( I LENGTH))
	     (ASET (CAR L) FM I))
	   (SETQ NEW-MAP FM)))
	((FERROR NIL "~S is not a valid FONT-MAP" NEW-MAP)))

  ;; Now that NEW-MAP contains fonts descriptors, extract the real fonts
  (DOTIMES (I (ARRAY-ACTIVE-LENGTH NEW-MAP))
    (ASET (FUNCALL SCREEN ':PARSE-FONT-DESCRIPTOR (AREF NEW-MAP I)) NEW-MAP I))

  (WITHOUT-INTERRUPTS
    (SETQ FONT-MAP NEW-MAP)
    ;;Now, find out the character dimensions of this set of fonts
    (LET ((FONT (AREF NEW-MAP 0)))
      (SETQ CURRENT-FONT FONT)
      (SETQ CHAR-WIDTH (FONT-CHAR-WIDTH FONT)))
    (SETQ BASELINE-ADJ 0)
    (DO ((I 0 (1+ I))
	 (LENGTH (ARRAY-ACTIVE-LENGTH NEW-MAP))
;	 (MAXWIDTH 0)
	 (MAXHEIGHT 0)
	 (MAXBASE 0)
	 (FONT))
	(( I LENGTH)
	 (SETQ BASELINE MAXBASE
	       LINE-HEIGHT (+ VSP MAXHEIGHT)))
      (SETQ FONT (AREF NEW-MAP I))
      (SETQ MAXHEIGHT (MAX MAXHEIGHT (FONT-CHAR-HEIGHT FONT))
	    MAXBASE (MAX MAXBASE (FONT-BASELINE FONT)))
;     (LET ((CWT (FONT-CHAR-WIDTH-TABLE FONT)))
;       (IF CWT
;	   (DO J 0 (1+ J) (= J 200)
;	       (SETQ MAXWIDTH (MAX MAXWIDTH (AR-1 TEM J))))
;	   (SETQ MAXWIDTH (MAX MAXWIDTH (FONT-CHAR-WIDTH (AR-1 NEW-MAP I))))))
      ))))


(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SHEET-DEDUCE-AND-SET-SIZES (RIGHT BOTTOM VSP INTEGRAL-P
				   &OPTIONAL CHARACTER-WIDTH CHARACTER-HEIGHT)
   ;;Standardize the font map
   (OR (AND (BOUNDP 'FONT-MAP) FONT-MAP)
       (SETQ FONT-MAP (LIST (SCREEN-DEFAULT-FONT (SHEET-GET-SCREEN SELF)))))
   (SHEET-NEW-FONT-MAP FONT-MAP VSP)

   ;; If height and/or width given in terms of characters in font 0, convert to pixels
   (IF (NOT (NULL CHARACTER-WIDTH))
       (SETQ WIDTH (DECODE-CHARACTER-WIDTH-SPEC CHARACTER-WIDTH)))
   (IF (NOT (NULL CHARACTER-HEIGHT))
       (SETQ HEIGHT (DECODE-CHARACTER-HEIGHT-SPEC CHARACTER-HEIGHT)))

   ;; Need to have X-OFFSET, Y-OFFSET, WIDTH, HEIGHT
   (OR X-OFFSET
       (SETQ X-OFFSET (IF (AND RIGHT WIDTH) (- RIGHT WIDTH) (SHEET-INSIDE-LEFT SUPERIOR))))
   (OR Y-OFFSET
       (SETQ Y-OFFSET (IF (AND BOTTOM HEIGHT) (- BOTTOM HEIGHT) (SHEET-INSIDE-TOP SUPERIOR))))
   (OR WIDTH
       (SETQ WIDTH (- (OR RIGHT (SHEET-INSIDE-RIGHT SUPERIOR)) X-OFFSET)))
   (OR HEIGHT
       (SETQ HEIGHT (- (OR BOTTOM (SHEET-INSIDE-BOTTOM SUPERIOR)) Y-OFFSET)))

   (AND INTEGRAL-P
	(SETQ BOTTOM-MARGIN-SIZE (- HEIGHT TOP-MARGIN-SIZE
				    (* LINE-HEIGHT (SHEET-NUMBER-OF-INSIDE-LINES)))))

   (SETQ CURSOR-X (SHEET-INSIDE-LEFT))
   (SETQ CURSOR-Y (SHEET-INSIDE-TOP))

   SELF))


(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN DECODE-CHARACTER-WIDTH-SPEC (SPEC)
  (COND ((NUMBERP SPEC)
	 (+ (* SPEC CHAR-WIDTH) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE))
	((STRINGP SPEC)
	 (MULTIPLE-VALUE-BIND (NIL NIL MAX-X)
	     (SHEET-STRING-LENGTH SELF SPEC)
	   (+ MAX-X LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))
	(T (FERROR NIL "~S illegal as :CHARACTER-WIDTH; use NIL, number, or string")))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN DECODE-CHARACTER-HEIGHT-SPEC (SPEC)
  (COND ((NUMBERP SPEC)
	 (+ (* SPEC LINE-HEIGHT)
	    TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
	((STRING SPEC)
	 (DO ((HT (+ TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE) (+ HT LINE-HEIGHT))
	      (I -1 (STRING-SEARCH-CHAR #\CR SPEC (1+ I))))
	     ((NULL I) HT)))
	(T (FERROR NIL "~S illegal as :CHARACTER-HEIGHT; use NIL, number, or string")))))

(DEFMETHOD (SHEET :MORE-P) ()
  (NOT (NULL MORE-VPOS)))

(DEFMETHOD (SHEET :SET-MORE-P) (MORE-P)
  (SETQ MORE-VPOS (AND MORE-P (SHEET-DEDUCE-MORE-VPOS SELF))))

(DEFUN SHEET-DEDUCE-MORE-VPOS (SHEET &AUX (LH (SHEET-LINE-HEIGHT SHEET)))
  (+ (SHEET-TOP-MARGIN-SIZE SHEET)
     (1- (* (1- (// (SHEET-INSIDE-HEIGHT SHEET) LH)) LH))))

(DEFMETHOD (SHEET :VSP) ()
  (SHEET-DEDUCE-VSP SELF))

(DEFMETHOD (SHEET :SET-VSP) (NEW-VSP)
  (SHEET-NEW-FONT-MAP FONT-MAP NEW-VSP)
  NEW-VSP)

(DEFUN SHEET-DEDUCE-VSP (SHEET &AUX (FONT-MAP (SHEET-FONT-MAP SHEET)))
  (- (SHEET-LINE-HEIGHT SHEET)
     (DO ((I 0 (1+ I))
	  (N (ARRAY-DIMENSION-N 1 FONT-MAP))
	  (H 0))
	 ((= I N) H)
       (SETQ H (MAX H (FONT-CHAR-HEIGHT (AREF FONT-MAP I)))))))

(DEFMETHOD (SHEET :SET-FONT-MAP) (NEW-MAP)
  (OR NEW-MAP (SETQ NEW-MAP (LIST (SCREEN-DEFAULT-FONT (SHEET-GET-SCREEN SELF)))))
  (SHEET-NEW-FONT-MAP NEW-MAP (SHEET-DEDUCE-VSP SELF))
  FONT-MAP)

(DEFMETHOD (SHEET :SET-CURRENT-FONT) (NEW-FONT)
  (WITHOUT-INTERRUPTS
    (IF (NUMBERP NEW-FONT)
	(SETQ NEW-FONT (AREF FONT-MAP NEW-FONT))
	(SETQ NEW-FONT (FUNCALL (SHEET-GET-SCREEN SELF) ':PARSE-FONT-DESCRIPTOR NEW-FONT))
	(OR (DOTIMES (I (ARRAY-ACTIVE-LENGTH FONT-MAP))
	      (AND NEW-FONT (EQ (AREF FONT-MAP I) NEW-FONT)
		   (RETURN T)))
	    (FERROR NIL "~A is illegal font" NEW-FONT)))
    (SETQ CURRENT-FONT NEW-FONT
	  CHAR-WIDTH (FONT-CHAR-WIDTH NEW-FONT))))


(DEFMETHOD (SHEET :REVERSE-VIDEO-P) ()
  (EQ CHAR-ALUF ALU-ANDCA))

(DEFMETHOD (SHEET :SET-REVERSE-VIDEO-P) (REVERSE-VIDEO-P)
  (AND ( CHAR-ALUF (IF REVERSE-VIDEO-P ALU-ANDCA ALU-IOR))
       (SHEET-FORCE-ACCESS (SELF)
         (%DRAW-RECTANGLE WIDTH HEIGHT 0 0 ALU-XOR SELF)))
  (IF REVERSE-VIDEO-P
      (SETQ CHAR-ALUF ALU-ANDCA ERASE-ALUF ALU-IOR)
      (SETQ CHAR-ALUF ALU-IOR ERASE-ALUF ALU-ANDCA)))

(DEFMETHOD (SHEET :DEEXPOSED-TYPEIN-ACTION) ()
  (IF (ZEROP (SHEET-DEEXPOSED-TYPEIN-NOTIFY)) ':NORMAL ':NOTIFY))

(DEFMETHOD (SHEET :SET-DEEXPOSED-TYPEIN-ACTION) (VALUE)
  (SETF (SHEET-DEEXPOSED-TYPEIN-NOTIFY)
	(SELECTQ VALUE
	  (:NORMAL 0)
	  (:NOTIFY 1)
	  (OTHERWISE
	   (FERROR NIL "~S illegal deexposed-typein-action; use :NORMAL or :NOTIFY")))))

(DEFMETHOD (SHEET :SAVE-BITS) ()
  (IF BIT-ARRAY T (IF (ZEROP (SHEET-FORCE-SAVE-BITS)) NIL ':DELAYED)))

(DEFMETHOD (SHEET :SET-SAVE-BITS) (SAVE-BITS &AUX (INHIBIT-SCHEDULING-FLAG T))
  (OR SUPERIOR (FERROR NIL "Cannot :SET-SAVE-BITS on a top-level sheet"))
  (LOCK-SHEET (SELF)
    (COND ((EQ SAVE-BITS 'T)
	   (LET ((INHIBIT-SCHEDULING-FLAG T))
	     (OR BIT-ARRAY
		 (SETQ BIT-ARRAY
		       (MAKE-ARRAY NIL (SHEET-ARRAY-TYPE SELF)
				   (LIST (// (* 32. LOCATIONS-PER-LINE)
					     (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SELF)))
					 HEIGHT))))
	     (COND ((NULL SCREEN-ARRAY)
		    (REDIRECT-ARRAY (SETQ SCREEN-ARRAY OLD-SCREEN-ARRAY)
				    (ARRAY-TYPE BIT-ARRAY)
				    (CDR (ARRAYDIMS BIT-ARRAY)) BIT-ARRAY 0)
		    (SETQ OLD-SCREEN-ARRAY NIL))))
	   (COND ((NOT EXPOSED-P)
		  ;; We are not exposed, first refresh ourself
		  (SHEET-FORCE-ACCESS (SELF :NO-PREPARE) (FUNCALL-SELF ':REFRESH))
		  ;; Expose in reverse order for the sake of temporary windows
		  (DOLIST (I (REVERSE EXPOSED-INFERIORS))
		    ;; Then actually expose all of our virtually exposed inferiors.
		    ;; Note that we already own the lock on all of them, and the mouse
		    ;; can't be in them since we are deexposed.
		    (FUNCALL I ':EXPOSE)))))
	  ((NULL BIT-ARRAY))
	  (T
	   (SETQ BIT-ARRAY NIL)
	   ;; Note that SCREEN-ARRAY still points to the old value of BIT-ARRAY.  This is
	   ;; important for the following deexposes to work.
	   (COND ((NOT EXPOSED-P)
		  ;; The mouse can't possibly be in any of these windows, so it's alright
		  ;; to just go ahead and deexpose them with us locked
		  (DOLIST (I EXPOSED-INFERIORS)
		    (FUNCALL I ':DEEXPOSE ':DEFAULT ':NOOP NIL))
		  (WITHOUT-INTERRUPTS		    
		    (SETQ OLD-SCREEN-ARRAY SCREEN-ARRAY)
		    (LET ((ARRAY (SHEET-SUPERIOR-SCREEN-ARRAY)))
		      (REDIRECT-ARRAY OLD-SCREEN-ARRAY (ARRAY-TYPE OLD-SCREEN-ARRAY)
				      (LIST (ARRAY-DIMENSION-N 1 ARRAY)
					    (ARRAY-DIMENSION-N 2 OLD-SCREEN-ARRAY))
				      ARRAY
				      (+ X-OFFSET (* Y-OFFSET
						     (ARRAY-DIMENSION-N 1 ARRAY)))))
		    (SETQ SCREEN-ARRAY NIL))))))
    (SETF (SHEET-FORCE-SAVE-BITS) (IF (EQ SAVE-BITS ':DELAYED) 1 0)))
  SAVE-BITS)

(DEFMETHOD (SHEET :AFTER :SET-SAVE-BITS) (IGNORE)
  (SCREEN-MANAGE-WINDOW-AREA SELF))

(DEFMETHOD (SHEET :CHANGE-OF-SIZE-OR-MARGINS) (&REST OPTIONS
					       &AUX TOP BOTTOM LEFT RIGHT
						    NEW-HEIGHT NEW-WIDTH OLD-X OLD-Y
						    (OLD-TOP-MARGIN-SIZE TOP-MARGIN-SIZE)
						    (OLD-LEFT-MARGIN-SIZE LEFT-MARGIN-SIZE)
						    DELTA-TOP-MARGIN DELTA-LEFT-MARGIN
						    (INTEGRAL-P NIL)
						    OLD-INSIDE-WIDTH OLD-INSIDE-HEIGHT)
  "Change some sheet parameters"
  (OR SUPERIOR (NOT EXPOSED-P)
      (FERROR NIL "Cannot change size or margins of an exposed window with no superior"))
  (SETQ OLD-INSIDE-WIDTH (SHEET-INSIDE-WIDTH)
	OLD-INSIDE-HEIGHT (SHEET-INSIDE-HEIGHT))
  (SHEET-FORCE-ACCESS (SELF)
    (ERASE-MARGINS))
  (MULTIPLE-VALUE (OLD-X OLD-Y) (SHEET-READ-CURSORPOS SELF))
  ;; Process options
  (DOPLIST (OPTIONS VAL OP)
    (SELECTQ OP
      ((:TOP :Y) (SETQ TOP VAL))
      (:BOTTOM (SETQ BOTTOM VAL))
      ((:LEFT :X) (SETQ LEFT VAL))
      (:RIGHT (SETQ RIGHT VAL))
      (:WIDTH (SETQ NEW-WIDTH VAL))
      (:HEIGHT (SETQ NEW-HEIGHT VAL))
      (:TOP-MARGIN-SIZE (SETQ TOP-MARGIN-SIZE VAL))
      (:BOTTOM-MARGIN-SIZE (SETQ BOTTOM-MARGIN-SIZE VAL))
      (:LEFT-MARGIN-SIZE (SETQ LEFT-MARGIN-SIZE VAL))
      (:RIGHT-MARGIN-SIZE (SETQ RIGHT-MARGIN-SIZE VAL))
      (:INTEGRAL-P (SETQ INTEGRAL-P VAL))
      (OTHERWISE (FERROR NIL "~S is not a recognized option" OP))))
  (SETQ X-OFFSET (OR LEFT (IF RIGHT (- RIGHT (OR NEW-WIDTH WIDTH)) X-OFFSET)))
  (SETQ Y-OFFSET (OR TOP (IF BOTTOM (- BOTTOM (OR NEW-HEIGHT HEIGHT)) Y-OFFSET)))
  (SETQ NEW-WIDTH (OR NEW-WIDTH (IF RIGHT (- RIGHT LEFT) WIDTH)))
  (SETQ NEW-HEIGHT (OR NEW-HEIGHT (IF BOTTOM (- BOTTOM TOP) HEIGHT)))
  (SETQ WIDTH NEW-WIDTH HEIGHT NEW-HEIGHT)

  ;; We need to deexpose all of our inferiors that won't fit anymore
  (DOLIST (I EXPOSED-INFERIORS)
    (OR (SHEET-WITHIN-P I (SHEET-INSIDE-LEFT) (SHEET-INSIDE-TOP)
			(SHEET-INSIDE-RIGHT) (SHEET-INSIDE-BOTTOM))
	(FUNCALL I ':DEEXPOSE)))

  (WITHOUT-INTERRUPTS
    (SHEET-FORCE-ACCESS (SELF T)
      (MAPC #'OPEN-BLINKER BLINKER-LIST))
    (SHEET-DEDUCE-AND-SET-SIZES RIGHT BOTTOM (SHEET-DEDUCE-VSP SELF) INTEGRAL-P)
    (SETQ CURSOR-X
	  (MIN (+ LEFT-MARGIN-SIZE OLD-X) (- WIDTH RIGHT-MARGIN-SIZE CHAR-WIDTH)))
    (SETQ CURSOR-Y
	  (MIN (+ TOP-MARGIN-SIZE OLD-Y) (- HEIGHT BOTTOM-MARGIN-SIZE LINE-HEIGHT)))
    (DOLIST (BL BLINKER-LIST)
      (COND ((NULL (BLINKER-X-POS BL)))
	    (( (BLINKER-X-POS BL) (SHEET-INSIDE-RIGHT))
	     (SETF (BLINKER-X-POS BL) (SHEET-INSIDE-LEFT))))
      (COND ((NULL (BLINKER-Y-POS BL)))
	    (( (BLINKER-Y-POS BL) (SHEET-INSIDE-BOTTOM))
	     (SETF (BLINKER-Y-POS BL) (SHEET-INSIDE-TOP)))))
    (AND BIT-ARRAY (SETQ BIT-ARRAY
			 (GROW-BIT-ARRAY BIT-ARRAY
					 (// (* 32. LOCATIONS-PER-LINE)
					     (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SELF)))
					 HEIGHT WIDTH)))

    (COND (SUPERIOR
	   ;;If we have a bit-array, SCREEN-ARRAY indirects to it, else OLD-SCREEN-ARRAY 
	   ;; indirects into our superior.
	   (LET ((ARRAY (OR SCREEN-ARRAY OLD-SCREEN-ARRAY))
		 (INDIRECT-TO (OR (AND (NOT EXPOSED-P) BIT-ARRAY)
				  (SHEET-SUPERIOR-SCREEN-ARRAY))))
	     (REDIRECT-ARRAY
	       ARRAY (ARRAY-TYPE INDIRECT-TO)
	       (LIST (ARRAY-DIMENSION-N 1 INDIRECT-TO) HEIGHT)
	       INDIRECT-TO
	       (IF (AND BIT-ARRAY (NOT EXPOSED-P)) 0
		   (+ X-OFFSET (* Y-OFFSET (ARRAY-DIMENSION-N 1 INDIRECT-TO)))))
	     (IF (OR BIT-ARRAY EXPOSED-P)
		 (SETQ SCREEN-ARRAY ARRAY
		       OLD-SCREEN-ARRAY NIL)
		 (SETQ OLD-SCREEN-ARRAY ARRAY
		       SCREEN-ARRAY NIL))
	     ;; If the size of the top and/or left margin changed, move the inside bits around
	     (SETQ DELTA-TOP-MARGIN (- TOP-MARGIN-SIZE OLD-TOP-MARGIN-SIZE)
		   DELTA-LEFT-MARGIN (- LEFT-MARGIN-SIZE OLD-LEFT-MARGIN-SIZE))
	     (COND ((AND (ZEROP DELTA-TOP-MARGIN) (ZEROP DELTA-LEFT-MARGIN)))
		   ((NULL SCREEN-ARRAY))	;Don't BITBLT some other guy's bits!!
		   (T ;; This should be BITBLT-WITH-FAST-PAGING, sometimes it is not paged in
		    (OR EXPOSED-P (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT)))
		    (BITBLT ALU-SETA (IF (PLUSP DELTA-LEFT-MARGIN) (- (SHEET-INSIDE-WIDTH))
					 (SHEET-INSIDE-WIDTH))
			    (IF (PLUSP DELTA-TOP-MARGIN) (- (SHEET-INSIDE-HEIGHT))
				(SHEET-INSIDE-HEIGHT))
			    ARRAY OLD-LEFT-MARGIN-SIZE OLD-TOP-MARGIN-SIZE
			    ARRAY LEFT-MARGIN-SIZE TOP-MARGIN-SIZE)
		    ;; If margins got smaller, may be space to clear out on bottom and right
		    (AND (MINUSP DELTA-LEFT-MARGIN)
			 (BITBLT ERASE-ALUF (- DELTA-LEFT-MARGIN) (SHEET-INSIDE-HEIGHT)
				 ARRAY (+ (SHEET-INSIDE-RIGHT) DELTA-LEFT-MARGIN)
				 (SHEET-INSIDE-TOP)
				 ARRAY (+ (SHEET-INSIDE-RIGHT) DELTA-LEFT-MARGIN)
				 (SHEET-INSIDE-TOP)))
		    (AND (MINUSP DELTA-TOP-MARGIN)
			 (BITBLT ERASE-ALUF (SHEET-INSIDE-WIDTH) (- DELTA-TOP-MARGIN)
				 ARRAY (SHEET-INSIDE-LEFT)
				 (+ (SHEET-INSIDE-BOTTOM) DELTA-TOP-MARGIN)
				 ARRAY (SHEET-INSIDE-LEFT)
				 (+ (SHEET-INSIDE-BOTTOM) DELTA-TOP-MARGIN))))))
	   (AND TEMPORARY-BIT-ARRAY (NEQ TEMPORARY-BIT-ARRAY T)
		(SETQ TEMPORARY-BIT-ARRAY (GROW-BIT-ARRAY TEMPORARY-BIT-ARRAY WIDTH HEIGHT)))
	   (SHEET-FORCE-ACCESS (SELF)
	     (ERASE-MARGINS))))
    (FUNCALL-SELF ':UPDATE-TIME-STAMP)
    (OR ( OLD-INSIDE-WIDTH (SHEET-INSIDE-WIDTH))
	( OLD-INSIDE-HEIGHT (SHEET-INSIDE-HEIGHT)))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN ERASE-MARGINS ()
  (COND (SCREEN-ARRAY
	 (PREPARE-SHEET (SELF)
	   (%DRAW-RECTANGLE LEFT-MARGIN-SIZE HEIGHT
			    0 0 ERASE-ALUF SELF)
	   (%DRAW-RECTANGLE RIGHT-MARGIN-SIZE HEIGHT
			    (SHEET-INSIDE-RIGHT) 0 ERASE-ALUF SELF)
	   (%DRAW-RECTANGLE WIDTH TOP-MARGIN-SIZE
			    0 0 ERASE-ALUF SELF)
	   (%DRAW-RECTANGLE WIDTH BOTTOM-MARGIN-SIZE
			    0 (SHEET-INSIDE-BOTTOM) ERASE-ALUF SELF))))))


(DEFUN MAKE-SHEET-BIT-ARRAY (SHEET X Y &REST MAKE-ARRAY-OPTIONS)
  (LET* ((TYPE (ARRAY-TYPE (WITHOUT-INTERRUPTS
			     (OR (TV:SHEET-SCREEN-ARRAY (TV:SHEET-GET-SCREEN SHEET))
				 (TV:SHEET-OLD-SCREEN-ARRAY (TV:SHEET-GET-SCREEN SHEET))))))
	 (ROUND-TO (// 32. (OR (CDR (ASSQ TYPE ARRAY-BITS-PER-ELEMENT)) 32.))))
    (LEXPR-FUNCALL #'MAKE-ARRAY (LIST (* (// (+ X ROUND-TO -1) ROUND-TO) ROUND-TO) Y)
		   ':TYPE TYPE
		   MAKE-ARRAY-OPTIONS)))

(DEFUN GROW-BIT-ARRAY (ARRAY WIDTH HEIGHT &OPTIONAL (REAL-WIDTH WIDTH)
			                  &AUX (AWIDTH (ARRAY-DIMENSION-N 1 ARRAY))
					       (AHEIGHT (ARRAY-DIMENSION-N 2 ARRAY)))
  (LET ((WWIDTH (LOGAND -40 (+ WIDTH 37)))	;Width as even number of words
	(REAL-ARRAY ARRAY))
    (COND ((AND (= WWIDTH AWIDTH) (= HEIGHT AHEIGHT)))	;Already the right size
	  (T
	   (SI:PAGE-IN-ARRAY ARRAY)
	   (IF (OR (> WWIDTH AWIDTH) (> HEIGHT AHEIGHT))
	       ;;Need bigger array, make it and copy in the old one
	       (LET ((NARRAY (MAKE-ARRAY NIL (ARRAY-TYPE ARRAY) (LIST WWIDTH HEIGHT))))
;                (SI:PAGE-IN-ARRAY NARRAY)  ;Just created it; it's as "in" as its gonna get
		 (BITBLT ALU-SETA (MIN REAL-WIDTH AWIDTH) (MIN HEIGHT AHEIGHT)
			 ARRAY 0 0 NARRAY 0 0)
		 (SI:PAGE-OUT-ARRAY ARRAY)
		 (STRUCTURE-FORWARD ARRAY NARRAY)
		 (SETQ REAL-ARRAY NARRAY))
	       ;; Need smaller in both dimensions, clear out bits outside of new area in
	       ;; case make large again
	       (BITBLT ALU-SETZ (- AWIDTH REAL-WIDTH) HEIGHT
		       ARRAY REAL-WIDTH 0 ARRAY REAL-WIDTH 0)
	       (OR (= AHEIGHT HEIGHT)
		   (BITBLT ALU-SETZ AWIDTH (- AHEIGHT HEIGHT) ARRAY 0 HEIGHT ARRAY 0 HEIGHT)))
	   (SI:PAGE-OUT-ARRAY ARRAY)))
    REAL-ARRAY))

(DEFUN SHEET-SET-DEEXPOSED-POSITION (NEW-X NEW-Y)
  "Called to set the position of a deexposed sheet.  Sheet must be locked.  Can be called
on deexposed screens."
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
    (AND EXPOSED-P
	 (FERROR NIL "Wrong function called to set position of exposed sheet ~A" SELF))
    (SETQ X-OFFSET NEW-X
	  Y-OFFSET NEW-Y)
    (OR BIT-ARRAY (NULL SUPERIOR)
	(LET ((SUP-ARRAY (SHEET-SUPERIOR-SCREEN-ARRAY)))
	  (REDIRECT-ARRAY OLD-SCREEN-ARRAY (ARRAY-TYPE OLD-SCREEN-ARRAY)
			  (LIST (ARRAY-DIMENSION-N 1 SUP-ARRAY)
				(ARRAY-DIMENSION-N 2 OLD-SCREEN-ARRAY))
			  SUP-ARRAY
			  (+ NEW-X (* NEW-Y
				      (ARRAY-DIMENSION-N 1 SUP-ARRAY))))))
    (FUNCALL-SELF ':UPDATE-TIME-STAMP)))

(DEFUN SHEET-SET-EXPOSED-POSITION (NEW-X NEW-Y &AUX OX OY)
  "Called to set the position of an exposed sheet.  Sheet must be locked.  The bits"
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
    (PREPARE-SHEET (SELF)
      (SETQ OX X-OFFSET
	    OY Y-OFFSET
	    X-OFFSET NEW-X
	    Y-OFFSET NEW-Y)
      (LET ((SUP-ARRAY (SHEET-SUPERIOR-SCREEN-ARRAY)))
	(REDIRECT-ARRAY SCREEN-ARRAY (ARRAY-TYPE SCREEN-ARRAY)
			(LIST (ARRAY-DIMENSION-N 1 SUP-ARRAY)
			      (ARRAY-DIMENSION-N 2 SCREEN-ARRAY))
			SUP-ARRAY
			(+ NEW-X (* NEW-Y (ARRAY-DIMENSION-N 1 SUP-ARRAY))))
	(BITBLT ALU-SETA
		(IF (> OX NEW-X) WIDTH (- WIDTH))
		(IF (> OY NEW-Y) HEIGHT (- HEIGHT))
		SUP-ARRAY OX OY
		SUP-ARRAY NEW-X NEW-Y))
      (SETQ MOUSE-RECONSIDER T))
    (FUNCALL-SELF ':UPDATE-TIME-STAMP)))

;;; This may need some work to really work right if locations-per-line changes
(DEFMETHOD (SHEET :SET-SUPERIOR) (NEW-SUPERIOR &AUX ACTIVE-P)
  (OR (EQ NEW-SUPERIOR SUPERIOR)
      (DELAYING-SCREEN-MANAGEMENT
	(AND EXPOSED-P (FUNCALL-SELF ':DEEXPOSE))
	(WITHOUT-INTERRUPTS
	  (COND ((SETQ ACTIVE-P (MEMQ SELF (SHEET-INFERIORS SUPERIOR)))
		 (SETF (SHEET-INFERIORS SUPERIOR) (DELQ SELF (SHEET-INFERIORS SUPERIOR)))
		 (FUNCALL SUPERIOR ':ORDER-INFERIORS)
		 (SCREEN-AREA-HAS-CHANGED SELF)))
	  (SETQ SUPERIOR NEW-SUPERIOR
		LOCATIONS-PER-LINE (SHEET-LOCATIONS-PER-LINE NEW-SUPERIOR))
	  (SHEET-SET-SUPERIOR-PARAMS SELF LOCATIONS-PER-LINE)
	  (COND (BIT-ARRAY
		 (SETQ BIT-ARRAY
		       (GROW-BIT-ARRAY BIT-ARRAY
				       (// (* LOCATIONS-PER-LINE 32.)
					   (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SELF)))
				       HEIGHT WIDTH))
		 (REDIRECT-ARRAY SCREEN-ARRAY (ARRAY-TYPE SCREEN-ARRAY)
				 (LIST (// (* LOCATIONS-PER-LINE 32.)
					   (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SELF)))
				       HEIGHT)
				 BIT-ARRAY 0))		 
		(T
		 (REDIRECT-ARRAY OLD-SCREEN-ARRAY (ARRAY-TYPE OLD-SCREEN-ARRAY)
				 (LIST (// (* LOCATIONS-PER-LINE 32.)
					   (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SELF)))
				       HEIGHT)
				 (SHEET-SUPERIOR-SCREEN-ARRAY)
				 (+ X-OFFSET (// (* LOCATIONS-PER-LINE 32. Y-OFFSET)
						 (SCREEN-BITS-PER-PIXEL
						   (SHEET-GET-SCREEN SELF)))))))
	  (COND (ACTIVE-P
		 (SHEET-CONSING
		   (SETF (SHEET-INFERIORS NEW-SUPERIOR)
			 (CONS SELF (COPYLIST (SHEET-INFERIORS NEW-SUPERIOR)))))
		 (FUNCALL NEW-SUPERIOR ':ORDER-INFERIORS)
		 (SCREEN-AREA-HAS-CHANGED SELF)))
	  (FUNCALL-SELF ':UPDATE-TIME-STAMP)))))

(DEFUN SHEET-SET-SUPERIOR-PARAMS (SHEET LOC-PER-LINE)
  (SETF (SHEET-LOCATIONS-PER-LINE SHEET) LOC-PER-LINE)
  (DOLIST (I (SHEET-INFERIORS SHEET))
    (SHEET-SET-SUPERIOR-PARAMS I LOC-PER-LINE)))

;;; Sheet exposure/deexposure

;;; Normal sheets ignore notification about exposure/deexposure/change-of-edges
;;; (Sheets themselves never send these messages, but it is possible that
;;; sheets be superiors of things which do (the case of screens is an example))
(DEFMETHOD (SHEET :INFERIOR-EXPOSE) (SHEET) SHEET)
(DEFMETHOD (SHEET :INFERIOR-DEEXPOSE) (SHEET) SHEET)
(DEFMETHOD (SHEET :INFERIOR-SET-EDGES) (SHEET &REST IGNORE) SHEET)
(DEFMETHOD (SHEET :INFERIOR-BURY) (SHEET) SHEET)

(DEFWRAPPER (SHEET :EXPOSE) (IGNORE . BODY)
  `(SHEET-EXPOSE SI:.DAEMON-CALLER-ARGS. #'(LAMBDA (SI:.DAEMON-CALLER-ARGS.) . ,BODY)))

(DEFVAR *SHEETS-MADE-INVISIBLE-TO-MOUSE*)
(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SHEET-EXPOSE (DAEMON-ARGS INTERNALS &AUX (*SHEETS-MADE-INVISIBLE-TO-MOUSE* NIL)
		     VAL1 VAL2 VAL3)
  (DELAYING-SCREEN-MANAGEMENT
    (UNWIND-PROTECT
      (DO ((DONE NIL) ERROR) (DONE)
	(LEXPR-FUNCALL #'SHEET-PREPARE-FOR-EXPOSE SELF NIL (CDR DAEMON-ARGS))
	(SETQ ERROR
	      (*CATCH 'SHEET-ABORT-EXPOSE
		(LOCK-SHEET (SELF)
		  (MULTIPLE-VALUE (VAL1 VAL2 VAL3) (FUNCALL INTERNALS DAEMON-ARGS))
		  (SETQ DONE T)
		  NIL)))
	(AND (NOT DONE) ERROR
	     (APPLY #'FERROR ERROR)))
      (DOLIST (SHEET *SHEETS-MADE-INVISIBLE-TO-MOUSE*)
	(SETF (SHEET-INVISIBLE-TO-MOUSE-P SHEET) NIL))
      (MOUSE-WAKEUP)))
  (VALUES VAL1 VAL2 VAL3)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(LOCAL-DECLARE ((SPECIAL *REQUESTOR*))
(DEFUN SHEET-PREPARE-FOR-EXPOSE (SHEET INSIDE-EXPOSE-METHOD
				 &OPTIONAL TURN-ON-BLINKERS BITS-ACTION
				 	   (X X-OFFSET) (Y Y-OFFSET))
  TURN-ON-BLINKERS
  (PROG ABORT ((INHIBIT-SCHEDULING-FLAG T) SUPERIOR-HAS-SCREEN-ARRAY RESULT)
     MAIN-LOOP
	(SETQ INHIBIT-SCHEDULING-FLAG T)
	(COND ((NOT (SHEET-CAN-GET-LOCK SHEET))
	       (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	       (PROCESS-WAIT "Lock" #'SHEET-CAN-GET-LOCK SHEET)
	       (GO MAIN-LOOP)))
	(AND EXPOSED-P (RETURN-FROM ABORT T BITS-ACTION NIL))
	(OR (NOT INSIDE-EXPOSE-METHOD)
	    (NULL SUPERIOR)
	    (MEMQ SELF (SHEET-INFERIORS SUPERIOR))
	    ;; We can only be exposed if we are activated
	    (RETURN-FROM ABORT NIL BITS-ACTION
			 (LIST NIL "Attempt to expose deactivated sheet ~S" SELF)))
	(SETQ SUPERIOR-HAS-SCREEN-ARRAY (OR (NULL SUPERIOR) (SHEET-SCREEN-ARRAY SUPERIOR)))
	(COND ((OR ( X-OFFSET X) ( Y-OFFSET Y))
	       (AND INSIDE-EXPOSE-METHOD (RETURN-FROM ABORT NIL BITS-ACTION NIL))
	       (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	       (SHEET-SET-DEEXPOSED-POSITION X Y)
	       (GO MAIN-LOOP)))
	(OR (NULL SUPERIOR)
	    (NOT INSIDE-EXPOSE-METHOD)
	    (SHEET-WITHIN-SHEET-P SELF SUPERIOR)
	    (RETURN-FROM ABORT NIL BITS-ACTION
			 (LIST NIL "Attempt to expose ~S outside of its superior" SELF)))
	;; If our superior is temp locked, see if we will overlap any
	;; of the temp windows.  If we will, then wait until the temp window is
	;; deexposed then try again
	(COND ((AND SUPERIOR
		    (LISTP (SHEET-LOCK SUPERIOR))
		    (SETQ RESULT
			  (DOLIST (TEMP-SHEET (SHEET-LOCK SUPERIOR))
			    (AND (SHEET-OVERLAPS-SHEET-P TEMP-SHEET SELF)
				 (RETURN TEMP-SHEET)))))
	       (AND INSIDE-EXPOSE-METHOD (RETURN-FROM ABORT NIL BITS-ACTION NIL))
	       (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	       (PROCESS-WAIT "Sheet Deexpose"
			     #'(LAMBDA (TEMP-SHEET SUP)
				 (NOT (MEMQ TEMP-SHEET (SHEET-LOCK SUP))))
			     RESULT SUPERIOR)
	       (GO MAIN-LOOP)))
	(COND ((SHEET-TEMPORARY-P)
	       (SETQ RESULT
		     (*CATCH 'SHEET-EXPOSE-CANT-GET-LOCK
		       (LET ((*REQUESTOR* SELF))
			 ;; Check to make sure we can get all the locks at once
			 (MAP-OVER-EXPOSED-SHEET
			   #'(LAMBDA (TARGET)
			       (AND ;; Can't be us, we aren't exposed yet
				 (NEQ TARGET (SHEET-SUPERIOR *REQUESTOR*))
				 ;; Sheet may be on EXPOSED-INFERIORS, but not
				 ;; in actuality exposed
				 (SHEET-EXPOSED-P TARGET)
				 (SHEET-OVERLAPS-SHEET-P *REQUESTOR* TARGET)
				 (OR (SHEET-CAN-GET-TEMPORARY-LOCK TARGET *REQUESTOR*)
				     (*THROW 'SHEET-EXPOSE-CANT-GET-LOCK TARGET))
				 ;; If this window owns the mouse, must force
				 ;; mouse out of it
				 (EQ TARGET MOUSE-WINDOW)
				 (*THROW 'SHEET-EXPOSE-CANT-GET-LOCK TARGET)))
			   SUPERIOR)
			 ;; We can, get them all and win totally, but only do this if
			 ;; we are inside the expose method proper
			 (AND INSIDE-EXPOSE-METHOD
			      (LET ((*REQUESTOR* SELF))
				(MAP-OVER-EXPOSED-SHEET
				  #'(LAMBDA (TARGET)
				      (COND ((AND ;; Can't be us, we aren't exposed yet
					       (NEQ TARGET (SHEET-SUPERIOR *REQUESTOR*))
					       ;; Sheet may be on EXPOSED-INFERIORS, but not
					       ;; in actuality exposed
					       (SHEET-EXPOSED-P TARGET)
					       (SHEET-OVERLAPS-SHEET-P *REQUESTOR* TARGET))
					     ;; All blinkers must get turned off on this sheet
					     (SHEET-OPEN-BLINKERS TARGET)
					     (OR (SHEET-GET-TEMPORARY-LOCK TARGET *REQUESTOR*)
						 (FERROR NIL
             "Internal error, can't get lock on ~A, but we already verified we could get lock"
	     						 TARGET))
					     (PUSH TARGET TEMPORARY-WINDOWS-LOCKED))))
				  SUPERIOR)))
			 ;; Return NIL indicating that we are winning
			 NIL)))
	       (COND ((NULL RESULT)
		      (AND INSIDE-EXPOSE-METHOD
			   ;; For temporary windows, we must open the blinkers of our
			   ;; superiors to all levels
			   (SHEET-OPEN-ALL-BLINKERS SUPERIOR)))
		     (INSIDE-EXPOSE-METHOD (RETURN-FROM ABORT NIL BITS-ACTION NIL))
		     ((EQ RESULT MOUSE-WINDOW)
		      (SETQ MOUSE-RECONSIDER T)
		      (PUSH RESULT *SHEETS-MADE-INVISIBLE-TO-MOUSE*)
		      (SETF (SHEET-INVISIBLE-TO-MOUSE-P RESULT) T)
		      (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		      (PROCESS-WAIT "Mouse Out"
				    #'(LAMBDA (SHEET) (NEQ MOUSE-WINDOW SHEET))
				    RESULT)
		      (GO MAIN-LOOP))
		     (T
		      ;; One we couldn't get: wait for it
		      (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		      (PROCESS-WAIT "Temp Lock"
				    #'(LAMBDA (TARGET SHEET)
					(OR (NOT (SHEET-EXPOSED-P TARGET))
					    (NOT (SHEET-OVERLAPS-SHEET-P SHEET TARGET))
					    (SHEET-CAN-GET-TEMPORARY-LOCK TARGET SHEET)))
				    RESULT SELF)
		      (GO MAIN-LOOP))))
	      (SUPERIOR
	       ;; Deexpose all we will overlap, then loop again as the world may have
	       ;; changed out from under us
	       (DOLIST (SIBLING (SHEET-EXPOSED-INFERIORS SUPERIOR))
		 (COND ((SHEET-OVERLAPS-SHEET-P SELF SIBLING)
			(AND INSIDE-EXPOSE-METHOD (RETURN-FROM ABORT NIL BITS-ACTION NIL))
			(SETQ INHIBIT-SCHEDULING-FLAG NIL)
			(FUNCALL SIBLING ':DEEXPOSE))))
	       (OR INHIBIT-SCHEDULING-FLAG
		   ;; If had to deexpose someone, world may have changed
		   (GO MAIN-LOOP))))
	;; We have successfully met all of the requirements, be successful
	(RETURN T BITS-ACTION)))))

;;; TURN-ON-BLINKERS means that this window will soon become the SELECTED-WINDOW,
;;; so it is not necessary to change blinkers from :BLINK to their
;;; DESELECTED-BLINKER-VISIBILITY.
(DEFMETHOD (SHEET :EXPOSE) (&OPTIONAL TURN-ON-BLINKERS BITS-ACTION (X X-OFFSET) (Y Y-OFFSET)
			    &AUX (INHIBIT-SCHEDULING-FLAG T) SUPERIOR-HAS-SCREEN-ARRAY
			         OK ERROR)
  "Expose a sheet (place it on the physical screen)"
  (PROG ()
	(SETQ RESTORED-BITS-P T)
	(OR BITS-ACTION (SETQ BITS-ACTION (IF BIT-ARRAY ':RESTORE ':CLEAN)))
	(AND EXPOSED-P (RETURN NIL))
	(SETQ RESTORED-BITS-P NIL)
	(SETQ SUPERIOR-HAS-SCREEN-ARRAY (OR (NULL SUPERIOR) (SHEET-SCREEN-ARRAY SUPERIOR)))
	(MULTIPLE-VALUE (OK BITS-ACTION ERROR)
	  (SHEET-PREPARE-FOR-EXPOSE SELF T TURN-ON-BLINKERS BITS-ACTION X Y))
	(OR OK (*THROW 'SHEET-ABORT-EXPOSE ERROR))
	;; Have made our area of the screen safe for us.  We'll now call ourselves
	;; "exposed", even though we haven't put our bits on the screen at all.  This
	;; will win, because we have ourself locked, and if someone wants to cover us
	;; he'll have to go blocked until we are done -- it's a cretinous thing to have
	;; happen, but the system shouldn't come crashing to the ground because of it.
	;; *** INHIBIT-SCHEDULING-FLAG had better still be T ***
	(OR INHIBIT-SCHEDULING-FLAG
	    (FERROR NIL "Hairy part of expose finished with INHIBIT-SCHEDULING-FLAG off"))
	;; Lie by saying that we are exposed, because we aren't really, but we are
	;; locked so it doesn't matter
	(AND SUPERIOR-HAS-SCREEN-ARRAY (SETQ EXPOSED-P T))
	(AND SUPERIOR
	     (OR (NOT (MEMQ SELF (SHEET-EXPOSED-INFERIORS SUPERIOR)))
		 ;; Must always reorder in the case of temporary windows since they
		 ;; are the only type of window that can be exposed and overlapping some
		 ;; other exposed window
		 (SHEET-TEMPORARY-P))
	     (SHEET-CONSING
	       (SETF (SHEET-EXPOSED-INFERIORS SUPERIOR)
		     (CONS SELF (COPYLIST (DELQ SELF (SHEET-EXPOSED-INFERIORS SUPERIOR)))))))
	(COND ((AND SUPERIOR-HAS-SCREEN-ARRAY BIT-ARRAY)
	       (SETF (SHEET-OUTPUT-HOLD-FLAG) 0)
	       (PREPARE-SHEET (SELF) )
	       (LET ((ARRAY (IF SUPERIOR
				(SHEET-SUPERIOR-SCREEN-ARRAY)
				(SCREEN-BUFFER SELF))))
		 (REDIRECT-ARRAY SCREEN-ARRAY (ARRAY-TYPE SCREEN-ARRAY)
				 (LIST (ARRAY-DIMENSION-N 1 ARRAY)
				       (ARRAY-DIMENSION-N 2 SCREEN-ARRAY))
				 ARRAY
				 (+ X-OFFSET (* Y-OFFSET
						(ARRAY-DIMENSION-N 1 ARRAY))))))
	      (SUPERIOR-HAS-SCREEN-ARRAY
	       (SETQ SCREEN-ARRAY OLD-SCREEN-ARRAY)
	       (SETF (SHEET-OUTPUT-HOLD-FLAG) 0)))
	(COND ((SHEET-TEMPORARY-P)
	       (IF (EQ TEMPORARY-BIT-ARRAY T)
		   (SETQ TEMPORARY-BIT-ARRAY
			 (MAKE-ARRAY NIL (SHEET-ARRAY-TYPE SELF)
				     (LIST (LOGAND -40 (+ 37 WIDTH)) HEIGHT)))
		   (SI:PAGE-IN-ARRAY TEMPORARY-BIT-ARRAY NIL (LIST WIDTH HEIGHT)))
	       (BITBLT ALU-SETA WIDTH HEIGHT SCREEN-ARRAY 0 0 TEMPORARY-BIT-ARRAY 0 0)
	       (SI:PAGE-OUT-ARRAY TEMPORARY-BIT-ARRAY NIL (LIST WIDTH HEIGHT))))
	(DOLIST (SHEET *SHEETS-MADE-INVISIBLE-TO-MOUSE*)
	  (SETF (SHEET-INVISIBLE-TO-MOUSE-P SHEET) NIL))
	(SETQ *SHEETS-MADE-INVISIBLE-TO-MOUSE* NIL)
	(MOUSE-WAKEUP)
	;; This goes after preceeding code so that blinkers won't accidentally
	;; turn on before the bits get BITBLT'ed into the temporary array
	(SETQ INHIBIT-SCHEDULING-FLAG NIL)
	(COND (SUPERIOR-HAS-SCREEN-ARRAY
	       (SELECTQ BITS-ACTION
		 (:NOOP NIL)
		 (:RESTORE
		  (FUNCALL-SELF ':REFRESH ':USE-OLD-BITS))
		 (:CLEAN
		  (SHEET-HOME SELF)
		  (FUNCALL-SELF ':REFRESH ':COMPLETE-REDISPLAY))
		 (OTHERWISE
		  (FERROR NIL "Unknown BITS-ACTION ~S" BITS-ACTION)))
	       (OR TURN-ON-BLINKERS
		   (DESELECT-SHEET-BLINKERS SELF))
	       (OR BIT-ARRAY
		   ;; Expose in opposite order for the sake of temporary windows
		   (DOLIST (INFERIOR (REVERSE EXPOSED-INFERIORS))
		     (FUNCALL INFERIOR ':EXPOSE NIL)))
	       (RETURN T)))))

(DEFWRAPPER (SHEET :DEEXPOSE) (IGNORE . BODY)
  `(SHEET-DEEXPOSE SI:.DAEMON-CALLER-ARGS. #'(LAMBDA (SI:.DAEMON-CALLER-ARGS.) . ,BODY)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SHEET-DEEXPOSE (DAEMON-ARGS INTERNALS)
  (UNWIND-PROTECT
    (PROGN
      ;; Always make ourselves invisible to the mouse
      (SETF (SHEET-INVISIBLE-TO-MOUSE-P SELF) T)
      (LET ((INHIBIT-SCHEDULING-FLAG T))
	(COND ((SHEET-ME-OR-MY-KID-P MOUSE-SHEET SELF)
	       ;; The mouse is currently on me or one of my inferiors, get it out of there
	       (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	       (IF SUPERIOR
		   (MOUSE-SET-SHEET SUPERIOR)
		   (IF (NEQ SELF DEFAULT-SCREEN)
		       (MOUSE-SET-SHEET DEFAULT-SCREEN)
		       (FERROR NIL
		    "Attempt to deexpose sheet ~S, which is top level sheet that owns mouse"
		    	       SELF)))
	       (SETQ INHIBIT-SCHEDULING-FLAG T)))
	(COND ((AND (TYPEP MOUSE-WINDOW 'SHEET) (SHEET-ME-OR-MY-KID-P MOUSE-WINDOW SELF))
	       ;; Me or my inferior is the current mouse sheet, so force it out
	       (SETQ MOUSE-RECONSIDER T)
	       (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	       (PROCESS-WAIT "Mouse Out"
			     #'(LAMBDA (SHEET)
				 (OR (NOT (TYPEP MOUSE-WINDOW 'SHEET))
				     (NOT (SHEET-ME-OR-MY-KID-P MOUSE-WINDOW SHEET))))
			     SELF))))
      (LOCK-SHEET (SELF)
	(FUNCALL INTERNALS DAEMON-ARGS)))
    (SETF (SHEET-INVISIBLE-TO-MOUSE-P SELF) NIL))))

(DEFMETHOD (SHEET :DEEXPOSE)  (&OPTIONAL (SAVE-BITS-P ':DEFAULT) SCREEN-BITS-ACTION
					 (REMOVE-FROM-SUPERIOR T))
  "Deexpose a sheet (removing it virtually from the physical screen, some bits may remain)"
  (DELAYING-SCREEN-MANAGEMENT
    (COND ((AND (EQ SAVE-BITS-P ':DEFAULT) (NOT (ZEROP (SHEET-FORCE-SAVE-BITS))) EXPOSED-P)
	   (SETQ SAVE-BITS-P ':FORCE)
	   (SETF (SHEET-FORCE-SAVE-BITS) 0)))
    (LET ((SW SELECTED-WINDOW))
      (AND SW (SHEET-ME-OR-MY-KID-P SW SELF)
	   (FUNCALL SW ':DESELECT NIL)))
    (OR SCREEN-BITS-ACTION (SETQ SCREEN-BITS-ACTION ':NOOP))
    (COND (EXPOSED-P
	   (OR BIT-ARRAY	;If we do not have a bit-array, take our inferiors off screen
	       (EQ SAVE-BITS-P ':FORCE)	;but leave them in EXPOSED-INFERIORS
	       (DOLIST (INFERIOR EXPOSED-INFERIORS)
		 (FUNCALL INFERIOR ':DEEXPOSE SAVE-BITS-P ':NOOP NIL)))
	   (WITHOUT-INTERRUPTS
	     (AND (EQ SAVE-BITS-P ':FORCE)
		  (NULL BIT-ARRAY)
		  (SETQ BIT-ARRAY
			(MAKE-ARRAY (LIST (LOGAND (+ (// (* LOCATIONS-PER-LINE 32.)
							 (SCREEN-BITS-PER-PIXEL
							   (SHEET-GET-SCREEN SELF)))
						     37)
						  -40)
					  HEIGHT)
				    ':TYPE (SHEET-ARRAY-TYPE SELF))
			OLD-SCREEN-ARRAY NIL))
	     (PREPARE-SHEET (SELF)
	       (AND SAVE-BITS-P BIT-ARRAY
		    (PROGN (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT))
			   (BITBLT ALU-SETA WIDTH HEIGHT SCREEN-ARRAY 0 0 BIT-ARRAY 0 0)
			   (SI:PAGE-OUT-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT)))))
	     (COND ((SHEET-TEMPORARY-P)
		    (SI:PAGE-IN-ARRAY TEMPORARY-BIT-ARRAY NIL (LIST WIDTH HEIGHT))
		    (BITBLT ALU-SETA WIDTH HEIGHT TEMPORARY-BIT-ARRAY 0 0 SCREEN-ARRAY 0 0)
		    (SI:PAGE-OUT-ARRAY TEMPORARY-BIT-ARRAY NIL (LIST WIDTH HEIGHT))
		    (DOLIST (SHEET TEMPORARY-WINDOWS-LOCKED)
		      (SHEET-RELEASE-TEMPORARY-LOCK SHEET SELF))
		    (SETQ TEMPORARY-WINDOWS-LOCKED NIL))
		   (T
		    (SELECTQ SCREEN-BITS-ACTION
		      (:NOOP)
		      (:CLEAN
		       (%DRAW-RECTANGLE WIDTH HEIGHT 0 0 ALU-ANDCA SELF))
		      (OTHERWISE
		       (FERROR NIL "~S is not a valid bit action" SCREEN-BITS-ACTION)))))
	     (SETQ EXPOSED-P NIL)
	     (AND REMOVE-FROM-SUPERIOR SUPERIOR
		  (SETF (SHEET-EXPOSED-INFERIORS SUPERIOR)
			(DELQ SELF (SHEET-EXPOSED-INFERIORS SUPERIOR))))
	     (IF (NULL BIT-ARRAY)
		 (SETQ OLD-SCREEN-ARRAY SCREEN-ARRAY SCREEN-ARRAY NIL)
		 (REDIRECT-ARRAY SCREEN-ARRAY (ARRAY-TYPE BIT-ARRAY)
				 (CDR (ARRAYDIMS BIT-ARRAY)) BIT-ARRAY 0))
	     (SETF (SHEET-OUTPUT-HOLD-FLAG) 1)))
	  (REMOVE-FROM-SUPERIOR
	   (AND SUPERIOR
		(SETF (SHEET-EXPOSED-INFERIORS SUPERIOR)
		      (DELQ SELF (SHEET-EXPOSED-INFERIORS SUPERIOR))))))))

(DEFMETHOD (SHEET :REFRESH) (&OPTIONAL (TYPE ':COMPLETE-REDISPLAY))
  (SETQ RESTORED-BITS-P (AND BIT-ARRAY (NEQ TYPE ':COMPLETE-REDISPLAY)))
  (COND (RESTORED-BITS-P
	  (AND EXPOSED-P		;If we are deexposed, this is a big no-op!
	       (PREPARE-SHEET (SELF)
		 (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT))
	         (BITBLT ALU-SETA WIDTH HEIGHT BIT-ARRAY 0 0 SCREEN-ARRAY 0 0)))
	  (COND ((NEQ TYPE ':USE-OLD-BITS)
		 (OR EXPOSED-P (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT)))
		 (ERASE-MARGINS)
		 (FUNCALL-SELF ':REFRESH-MARGINS))))
	(T
	 (PREPARE-SHEET (SELF)
	   (OR EXPOSED-P (AND BIT-ARRAY (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT))))
	   (%DRAW-RECTANGLE WIDTH HEIGHT 0 0 ERASE-ALUF SELF))
	 (FUNCALL-SELF ':REFRESH-MARGINS)
	 (DOLIST (INFERIOR INFERIORS)
	   (AND (SHEET-EXPOSED-P INFERIOR)	;EXPOSED-INFERIORS may not all be on screen
		(FUNCALL INFERIOR ':REFRESH ':COMPLETE-REDISPLAY)))
;	 (FUNCALL-SELF ':SCREEN-MANAGE)
	 (SCREEN-MANAGE-QUEUE SELF 0 0 WIDTH HEIGHT)
	 ))
  (AND BIT-ARRAY (SI:PAGE-OUT-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT))))

(DEFMETHOD (SHEET :REFRESH-MARGINS) () )

;;;Exceptions
(DEFUN SHEET-HANDLE-EXCEPTIONS (SHEET)
  "Called when an exception occurs on a sheet.  The appropriate exception handling 
routines are called"
  (OR (ZEROP (SHEET-OUTPUT-HOLD-FLAG SHEET))
      (FUNCALL SHEET ':OUTPUT-HOLD-EXCEPTION))
  (OR (ZEROP (SHEET-END-PAGE-FLAG SHEET))
      (FUNCALL SHEET ':END-OF-PAGE-EXCEPTION))
  (OR (ZEROP (SHEET-MORE-FLAG SHEET))
      (COND (MORE-PROCESSING-GLOBAL-ENABLE
	     (FUNCALL SHEET ':MORE-EXCEPTION)
	     (OR (ZEROP (SHEET-END-PAGE-FLAG SHEET))
		 (FUNCALL SHEET ':END-OF-PAGE-EXCEPTION)))
	    (T (SETF (SHEET-MORE-FLAG SHEET) 0))))
  (OR (ZEROP (SHEET-EXCEPTIONS SHEET))
      (FERROR NIL "Exceptions (~O) on sheet ~S won't go away"
	      (SHEET-EXCEPTIONS SHEET)
	      SHEET))
  NIL)

;Called by typeout routines when they discover there is not enough space to output another
;character.  Sheet has already been prepared when this is called.
(DEFMETHOD (SHEET :END-OF-LINE-EXCEPTION) ()
  ;; Put an "!" in the right margin if called for.
  (OR (ZEROP (SHEET-RIGHT-MARGIN-CHARACTER-FLAG))
      (SHEET-TYO-RIGHT-MARGIN-CHARACTER SELF CURSOR-X CURSOR-Y #/!))
  ;; Move to left margin, next line, and clear it
  (SHEET-INCREMENT-BITPOS SELF (- CURSOR-X) LINE-HEIGHT)
  (SHEET-CLEAR-EOL SELF)			;If at end of page, this will home up first
  (OR (ZEROP (SHEET-EXCEPTIONS SELF))		;Take care of any residual **more**
      (SHEET-HANDLE-EXCEPTIONS SELF)))		;since caller is about to type out

;This used to put continuation-line marks in the margin
;Note that when using variable-width fonts, the mark is placed relative to the
;right margin rather than relative to the text that is already there.  Hope this is right.
(DEFUN SHEET-TYO-RIGHT-MARGIN-CHARACTER (SHEET XPOS YPOS CH
					 &AUX (FONT (AREF (SHEET-FONT-MAP SHEET) 0))
					      (ALUF (SHEET-CHAR-ALUF SHEET))
					      (WID (SHEET-CHARACTER-WIDTH SHEET CH FONT)) FIT)
  XPOS ;Ignored now, but supplied in case I decide to change where the character goes
  (PREPARE-SHEET (SHEET)
    (COND ((SETQ FIT (FONT-INDEXING-TABLE FONT))
	   (DO ((CH (AREF FIT CH) (1+ CH))
		(LIM (AREF FIT (1+ CH)))
		(BPP (SHEET-BITS-PER-PIXEL SHEET))
		(XPOS (- (SHEET-INSIDE-RIGHT SHEET) WID)
		      (+ XPOS (// (FONT-RASTER-WIDTH FONT) BPP))))
	       ((= CH LIM))
	     (%DRAW-CHAR FONT CH XPOS YPOS ALUF SHEET)))
	   (T (%DRAW-CHAR FONT CH (- (SHEET-INSIDE-RIGHT SHEET) WID) YPOS ALUF SHEET)))))

(DEFMETHOD (SHEET :END-OF-PAGE-EXCEPTION) ()
  (COND ((NOT (ZEROP (SHEET-END-PAGE-FLAG)))
	 (LET ((M-VP MORE-VPOS))	;SHEET-HOME smashes this, since it moves the cursor
	   ;; Wrap around to top of sheet
	   (SHEET-HOME SELF)
	   (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))))))))

(DEFMETHOD (SHEET :MORE-EXCEPTION) ()
  (OR (ZEROP (SHEET-MORE-FLAG))
      (SHEET-MORE-HANDLER)))

;;; This is the default more handler, it takes an operation, which can be something like
;;; :MORE-TYI, and returns the character that unMOREd, in case you want to UNTYI it sometimes.
;;; Note that this always returns with the cursor at the beginning of a blank line,
;;; on which you may type "flushed" if you like.  Sheet-end-page-flag will be set if
;;; this is the last line in the window, so that normal typeout will not come out on
;;; that line but will wrap-around instead.
(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SHEET-MORE-HANDLER (&OPTIONAL (OPERATION ':TYI) &AUX (CURRENT-X CURSOR-X) HANDLER CHAR)
  (SETF (SHEET-MORE-FLAG) 0)		;"Won't need MORE processing no more"
  (SETQ MORE-VPOS (+ 100000 MORE-VPOS))	;Defer more's while typing **MORE**
  (SHEET-CLEAR-EOL SELF)
  (LET ((OLD-FONT CURRENT-FONT)
	(OLD-CHAR-WIDTH CHAR-WIDTH))
    (UNWIND-PROTECT
      (PROGN
	(SETQ CURRENT-FONT (AREF FONT-MAP 0))
	(SETQ CHAR-WIDTH (FONT-CHAR-WIDTH CURRENT-FONT))
	(SHEET-STRING-OUT SELF "**MORE**"))
      (SETQ CURRENT-FONT OLD-FONT)
      (SETQ CHAR-WIDTH OLD-CHAR-WIDTH)))

  (AND (SETQ HANDLER (GET-HANDLER-FOR SELF OPERATION))
       (SETQ CHAR (SHEET-MORE-LOCK-KLUDGE #'(LAMBDA (HANDLER OPERATION)
					      (FUNCALL HANDLER OPERATION))
					  HANDLER OPERATION)))

  (SETQ CURSOR-X CURRENT-X)		;Wipe out the **MORE**
  (SHEET-CLEAR-EOL SELF)
  (COND (( (+ CURSOR-Y LINE-HEIGHT)
	    (+ TOP-MARGIN-SIZE (1- (* (1- (SHEET-NUMBER-OF-INSIDE-LINES)) LINE-HEIGHT))))
	 (SETQ MORE-VPOS 0)
	 (SETF (SHEET-END-PAGE-FLAG) 1))	;Wrap around unless flushed
	;At bottom, wrap around (or scroll)
	;Next MORE will happen at same place
	(T (FUNCALL-SELF ':NOTICE ':INPUT-WAIT)))	;Otherwise, MORE one line up next time
  CHAR))

(DEFMETHOD (SHEET :OUTPUT-HOLD-EXCEPTION) ()
  (OR (ZEROP (SHEET-OUTPUT-HOLD-FLAG))
      EXPOSED-P				;Output held due to deexposure
      (SELECTQ DEEXPOSED-TYPEOUT-ACTION
	(:NORMAL)
	(:ERROR				;Give error if attempting typeout?
	  (FERROR 'OUTPUT-ON-DEEXPOSED-SHEET
		  "Attempt to typeout on ~S, which is deexposed"
		  SELF))
	(:PERMIT
	 ;; OUTPUT-HOLD gets cleared at this level, rather than never getting set when 
	 ;; deexposing, so that software knows if a sheet actually did typeout, as opposed to
	 ;; it being permitted.  This allows software to know if it needs to update a
	 ;; partially exposed window's bits, for example.  It is similar to a page-fault
	 ;; handler's setting the write-protect bit on write enabled pages to detect when a
	 ;; page is actually modified (READ-WRITE-FIRST)
	 (AND SCREEN-ARRAY (SETF (SHEET-OUTPUT-HOLD-FLAG) 0)))
	(:EXPOSE
	 (FUNCALL-SELF ':EXPOSE))
	(:NOTIFY
	 (FUNCALL-SELF ':NOTICE ':OUTPUT))	;Consider notifying the user
	(OTHERWISE
	 (IF (LISTP DEEXPOSED-TYPEOUT-ACTION)
	     (LEXPR-FUNCALL-SELF DEEXPOSED-TYPEOUT-ACTION)
	     (FERROR NIL "~S is not a recognized DEEXPOSED-TYPEOUT-ACTION"
		     DEEXPOSED-TYPEOUT-ACTION)))))
  (PROCESS-WAIT "Output Hold"
		#'(LAMBDA (SHEET)
		    (NOT (SHEET-OUTPUT-HELD-P SHEET))) ;Wait until no output hold
		SELF))

;;; This is the default method for :NOTICE, which is always called last
;;; if all other methods have returned NIL.  It provides the default handling
;;; for deexposed input and output in notify mode, handles :INPUT-WAIT,
;;; and provides the special handling for errors vis a vis the window system.
;;; Other events are completely ignored; presumably they shouldn't be noticed by windows
;;; which don't have flavors to handle them.
;;; No currently-defined events use the ARGS argument, but it is there for
;;; future extensibility.
(DEFMETHOD (SHEET :NOTICE) (EVENT &REST ARGS)
  ARGS ;ignored
  (SELECTQ EVENT
    ((:INPUT :OUTPUT)		;Deexposed window needs some attention
     ;; Wait for there to be a place to notify
     (PROCESS-WAIT "A Selected Window" #'(LAMBDA () SELECTED-WINDOW))
     ;; Now, if this window is visible we don't need to bother notifying
     (OR (LOOP FOR W = SELF THEN (SHEET-SUPERIOR W) UNTIL (NULL W)
	       ALWAYS (SHEET-EXPOSED-P W))
	 (NOTIFY SELF "Process ~A wants ~A" (PROCESS-NAME CURRENT-PROCESS)
		 (IF (EQ EVENT ':OUTPUT) "to type out" "typein")))
     T)
    (:INPUT-WAIT		;Hanging up waiting for input.
     (SETF (SHEET-MORE-FLAG) 0)			;Decide when we need to **more** next
     (COND ((NULL MORE-VPOS))			;Unless MORE inhibited entirely
	   ((< (* (- (SHEET-INSIDE-BOTTOM) CURSOR-Y) 4)	;More than 3/4 way down window?
	       (SHEET-INSIDE-HEIGHT))
	    ;; Wrap around and more just before the current line
	    (SETQ MORE-VPOS (+ 100000 (- CURSOR-Y LINE-HEIGHT))))
	   (T ;; More at bottom 
	    (SETQ MORE-VPOS (SHEET-DEDUCE-MORE-VPOS SELF))))
     (AND (NOT EXPOSED-P)			;Send a notification if desired
	  (NOT (ZEROP (SHEET-DEEXPOSED-TYPEIN-NOTIFY)))
	  (FUNCALL-SELF ':NOTICE ':INPUT))
     T)
    (:ERROR			;Error in process using this window as its TERMINAL-IO.
				;Notify if possible, and decide whether to use this
				;window or the cold-load stream.
     (COND ((OR (< (SHEET-INSIDE-WIDTH) (* CHAR-WIDTH 35.))
		(< (SHEET-INSIDE-HEIGHT) (* LINE-HEIGHT 5)))
	    'COLD-LOAD-STREAM)			;If window absurdly small, don't use it
	   ((LOOP FOR W = SELF THEN (SHEET-SUPERIOR W) UNTIL (NULL W)
		  ALWAYS (SHEET-EXPOSED-P W))	;If window visible, use unless locked
	    (OR (SHEET-CAN-GET-LOCK SELF) 'COLD-LOAD-STREAM))
	   ((CAREFUL-NOTIFY SELF T "Process ~A got an error" (PROCESS-NAME CURRENT-PROCESS))
	    ;; If notifying for an error, remain "in error" until selected
	    (LET ((PROCESS-IS-IN-ERROR SELF))
	      (PROCESS-WAIT "Selected" #'(LAMBDA (W) (EQ SELECTED-WINDOW W)) SELF))
	    T)
	   (T 'COLD-LOAD-STREAM)))		;Unable to notify, use cold-load-stream
    (OTHERWISE NIL)))		;Ignore unknown events (could signal error instead?)

;;;Blinkers
;;; Define a blinker on a piece of paper
(DEFUN DEFINE-BLINKER (SHEET &OPTIONAL (TYPE 'RECTANGULAR-BLINKER) &REST OPTIONS
			     &AUX PLIST BLINKER)
  (SETQ OPTIONS (COPYLIST OPTIONS)
	PLIST (LOCF OPTIONS))
  (PUTPROP PLIST SHEET ':SHEET)
  (SETQ BLINKER (INSTANTIATE-FLAVOR TYPE PLIST T NIL BLINKER-AREA))
  (WITHOUT-INTERRUPTS
    (PUSH BLINKER (SHEET-BLINKER-LIST SHEET)))
  BLINKER)

(DEFMETHOD (BLINKER :INIT) (IGNORE)
  (OR FOLLOW-P X-POS
      (SETQ X-POS (SHEET-CURSOR-X SHEET)
	    Y-POS (SHEET-CURSOR-Y SHEET))))

(DEFMETHOD (RECTANGULAR-BLINKER :BEFORE :INIT) (IGNORE &AUX FONT)
  (SETQ FONT (AREF (SHEET-FONT-MAP SHEET) 0))
  (OR WIDTH (SETQ WIDTH (FONT-BLINKER-WIDTH FONT)))
  (OR HEIGHT (SETQ HEIGHT (FONT-BLINKER-HEIGHT FONT))))

(DEFMETHOD (RECTANGULAR-BLINKER :SIZE) ()
  (PROG () (RETURN WIDTH HEIGHT)))

;;; Make a blinker temporarily disappear from the screen.
;;; Anything that moves it or changes its parameters should call this.
;;; When the next clock interrupt happens with INHIBIT-SCHEDULING-FLAG clear,
;;; the blinker will come back on.  This is independent of the time until next
;;; blink, in order to provide the appearance of fast response.
;;; Anyone who calls this should have lambda-bound INHIBIT-SCHEDULING-FLAG to T.
;;; This is a noop if the sheet the blinker is on is output held.
(DEFUN OPEN-BLINKER (BLINKER)
  (COND ((AND (BLINKER-PHASE BLINKER) 		;If blinker on, turn it off
	      (NOT (SHEET-OUTPUT-HELD-P (BLINKER-SHEET BLINKER))))
	 (BLINK BLINKER)
	 (SETF (BLINKER-TIME-UNTIL-BLINK BLINKER) 0))))

;;; This function should get called by the clock about every 60th of a second.
;;; Any blinkers which are supposed to be on but are off are turned on.
;;; Any blinkers which are supposed to be flashed are flashed if it is time.
;;; Note: we depend on the fact that blinkers temporarily turned off
;;; have their BLINKER-TIME-UNTIL-BLINK fields set to 0.
(LOCAL-DECLARE ((SPECIAL BLINKER-DELTA-TIME))
(DEFUN BLINKER-CLOCK (BLINKER-DELTA-TIME)
  (DOLIST (S ALL-THE-SCREENS)
    (BLINKER-CLOCK-INTERNAL S)))

(DEFUN BLINKER-CLOCK-INTERNAL (SHEET)
  (COND ((AND (SHEET-EXPOSED-P SHEET)
	      (ZEROP (SHEET-DONT-BLINK-BLINKERS-FLAG SHEET)))
	 (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET))
	   (AND (SELECTQ (BLINKER-VISIBILITY BLINKER)
		  ((NIL :OFF)
		   (BLINKER-PHASE BLINKER))
		  ((T :ON)
		   (NULL (BLINKER-PHASE BLINKER)))
		  (:BLINK
		   (LET ((NEW-TIME (- (BLINKER-TIME-UNTIL-BLINK BLINKER) BLINKER-DELTA-TIME)))
		     (SETF (BLINKER-TIME-UNTIL-BLINK BLINKER) NEW-TIME)
		     ( NEW-TIME 0))))
		(NOT (SHEET-OUTPUT-HELD-P SHEET))
		(LET ((LV (SHEET-LOCK SHEET)))
		  (OR (NULL LV) (LISTP LV)))
		(BLINK BLINKER)))
	 (DOLIST (S (SHEET-EXPOSED-INFERIORS SHEET))
	   (BLINKER-CLOCK-INTERNAL S))))))

(DEFWRAPPER (BLINKER :BLINK) (IGNORE . BODY)
  `(SHEET-IS-PREPARED (SHEET)
      . ,BODY))

(DEFMETHOD (BLINKER :BEFORE :BLINK) ()
  (SETQ PREPARED-SHEET NIL)			;Blinking any blinker makes us forget
  (SETQ TIME-UNTIL-BLINK HALF-PERIOD)		;Schedule the next blink (wink??)
  (AND FOLLOW-P (SETQ X-POS (SHEET-CURSOR-X SHEET)
		      Y-POS (SHEET-CURSOR-Y SHEET))))

(DEFMETHOD (BLINKER :AFTER :BLINK) ()
  (SETQ PHASE (NOT PHASE)))

(DEFMETHOD (BLINKER :SET-CURSORPOS) (X Y &AUX (INHIBIT-SCHEDULING-FLAG T)
					      OLD-PHASE)
  "Set the position of a blinker relative to the sheet it is on.  Args in terms of
raster units.  If blinker was following cursor, it will no longer be doing so."
  (DO () ((OR (NULL (SETQ OLD-PHASE PHASE))
	      (NOT (SHEET-OUTPUT-HELD-P SHEET))))
    (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    (FUNCALL SHEET ':OUTPUT-HOLD-EXCEPTION)
    (SETQ INHIBIT-SCHEDULING-FLAG T))
  (SETQ X (MIN (+ (MAX (FIX X) 0) (SHEET-INSIDE-LEFT SHEET)) (SHEET-INSIDE-RIGHT SHEET))
	Y (MIN (+ (MAX (FIX Y) 0) (SHEET-INSIDE-TOP SHEET)) (SHEET-INSIDE-BOTTOM SHEET)))
  (COND ((OR (NEQ X X-POS)	;Only blink if actually moving blinker
	     (NEQ Y Y-POS))
	 (OPEN-BLINKER SELF)
	 (SETQ X-POS X Y-POS Y FOLLOW-P NIL)
	 (AND VISIBILITY
	      (NEQ VISIBILITY ':BLINK)		;If non-blinking, don't disappear
	      OLD-PHASE				; for a long time
	      (BLINK SELF)))))

(DEFMETHOD (BLINKER :SET-FOLLOW-P) (NEW-FOLLOW-P &AUX (INHIBIT-SCHEDULING-FLAG T))
  "Turn on or off whether the blinker follows the sheet's typeout cursor."
  (COND ((NEQ FOLLOW-P NEW-FOLLOW-P)
	 (DO () ((OR (NULL PHASE)
		     (NOT (SHEET-OUTPUT-HELD-P SHEET))))
	   (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	   (FUNCALL SHEET ':OUTPUT-HOLD-EXCEPTION)
	   (SETQ INHIBIT-SCHEDULING-FLAG T))
	 (OPEN-BLINKER SELF)
	 (SETQ FOLLOW-P NEW-FOLLOW-P))))

(DEFMETHOD (BLINKER :READ-CURSORPOS) ()
  "Returns the position of a blinker in raster units relative to the margins of the
sheet it is on"
  (PROG ()
    (RETURN (- (OR X-POS (SHEET-CURSOR-X SHEET))
	       (SHEET-INSIDE-LEFT SHEET))
	    (- (OR Y-POS (SHEET-CURSOR-Y SHEET))
	       (SHEET-INSIDE-TOP SHEET)))))

(DEFMETHOD (BLINKER :SET-VISIBILITY) (NEW-VISIBILITY &AUX (INHIBIT-SCHEDULING-FLAG T))
  "Carefully alter the visibility of a blinker"
  (OR (MEMQ NEW-VISIBILITY '(T NIL :BLINK :ON :OFF))
      (FERROR NIL "Unknown visibility type ~S" NEW-VISIBILITY))
  (COND ((EQ VISIBILITY NEW-VISIBILITY))
	((EQ PHASE NEW-VISIBILITY)
	 (SETQ VISIBILITY NEW-VISIBILITY))
	(T
	 (DO () ((NOT (SHEET-OUTPUT-HELD-P SHEET)))
	     (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	     (FUNCALL SHEET ':OUTPUT-HOLD-EXCEPTION)
	     (SETQ INHIBIT-SCHEDULING-FLAG T))
	 (OR NEW-VISIBILITY (OPEN-BLINKER SELF))
	 (SETQ VISIBILITY NEW-VISIBILITY)
	 ;; Blinker clock will fix the screen
	 (SETQ TIME-UNTIL-BLINK 0))))

(DEFMETHOD (RECTANGULAR-BLINKER :SET-SIZE) (NWIDTH NHEIGHT &AUX (INHIBIT-SCHEDULING-FLAG T))
  (COND ((OR ( WIDTH NWIDTH)
	     ( HEIGHT NHEIGHT))
	 (DO () ((OR (NOT (SHEET-OUTPUT-HELD-P SHEET))
		     (NULL PHASE)))
	   (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	   (FUNCALL SHEET ':OUTPUT-HOLD-EXCEPTION)
	   (SETQ INHIBIT-SCHEDULING-FLAG T))
	 (OPEN-BLINKER SELF)
	 (SETQ WIDTH NWIDTH HEIGHT NHEIGHT))))

(DEFMETHOD (BLINKER :SET-SHEET) (NEW-SHEET &AUX (INHIBIT-SCHEDULING-FLAG T)
						 EXCH-FLAG S-SUP S-INF)
  (COND ((NEQ NEW-SHEET SHEET)
	 ;; Only need to turn off blinker if it is turned on
	 (DO () ((OR (NOT (SHEET-OUTPUT-HELD-P SHEET))
		     (NULL PHASE)))
	   (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	   (FUNCALL SHEET ':OUTPUT-HOLD-EXCEPTION)
	   (SETQ INHIBIT-SCHEDULING-FLAG T))
	 (OPEN-BLINKER SELF)
	 (SETF (SHEET-BLINKER-LIST SHEET) (DELQ SELF (SHEET-BLINKER-LIST SHEET)))
	 (PUSH SELF (SHEET-BLINKER-LIST NEW-SHEET))
	 (IF (SHEET-ME-OR-MY-KID-P SHEET NEW-SHEET)
	     (SETQ S-SUP NEW-SHEET
		   S-INF SHEET
		   EXCH-FLAG 1)
	     (SETQ S-SUP SHEET
		   S-INF NEW-SHEET
		   EXCH-FLAG -1))
	 (COND ((OR (= EXCH-FLAG 1)
		    (SHEET-ME-OR-MY-KID-P S-INF S-SUP))
		(MULTIPLE-VALUE-BIND (X-OFF Y-OFF)
		    (SHEET-CALCULATE-OFFSETS S-INF S-SUP)
		  (SETQ X-POS
			(MIN (MAX 0 (+ X-POS (* EXCH-FLAG X-OFF)))
			     (1- (SHEET-WIDTH NEW-SHEET))))
		  (SETQ Y-POS
			(MIN (MAX 0 (+ Y-POS (* EXCH-FLAG Y-OFF)))
			     (1- (SHEET-HEIGHT NEW-SHEET))))))			
	       (T
		;; The sheets aren't related so directly, just put the blinker in the middle
		(SETQ X-POS (// (SHEET-WIDTH NEW-SHEET) 2)
		      Y-POS (// (SHEET-HEIGHT NEW-SHEET) 2))))
	 (SETQ SHEET NEW-SHEET))))

(DEFMETHOD (RECTANGULAR-BLINKER :BLINK) ()
  "Standard style, rectangular blinker"
  ;; Should this insure blinker in range?
  (%DRAW-RECTANGLE-CLIPPED WIDTH HEIGHT X-POS Y-POS ALU-XOR SHEET))

(DEFFLAVOR HOLLOW-RECTANGULAR-BLINKER () (RECTANGULAR-BLINKER))

;This sticks out by 1 pixel on the top and left but not on the bottom and
;right since that seems to be the right thing for boxing text -- this may be a crock
(DEFMETHOD (HOLLOW-RECTANGULAR-BLINKER :BLINK) ()
  (LET ((X-POS (1- X-POS)) (Y-POS (1- Y-POS)) (HEIGHT (1+ HEIGHT)) (WIDTH (1+ WIDTH)))
    (%DRAW-RECTANGLE-CLIPPED 1 HEIGHT X-POS Y-POS ALU-XOR SHEET)
    (%DRAW-RECTANGLE-CLIPPED (- WIDTH 1) 1 (+ X-POS 1) Y-POS ALU-XOR SHEET)
    (%DRAW-RECTANGLE-CLIPPED 1 (- HEIGHT 1) (+ X-POS WIDTH -1) (+ Y-POS 1) ALU-XOR SHEET)
    (%DRAW-RECTANGLE-CLIPPED (- WIDTH 2) 1 (+ X-POS 1) (+ Y-POS HEIGHT -1) ALU-XOR SHEET)))

(DEFFLAVOR BOX-BLINKER () (RECTANGULAR-BLINKER))

(DEFMETHOD (BOX-BLINKER :BLINK) ()
  (%DRAW-RECTANGLE-CLIPPED 2 HEIGHT X-POS Y-POS ALU-XOR SHEET)
  (%DRAW-RECTANGLE-CLIPPED (- WIDTH 2) 2 (+ X-POS 2) Y-POS ALU-XOR SHEET)
  (%DRAW-RECTANGLE-CLIPPED 2 (- HEIGHT 2) (+ X-POS WIDTH -2) (+ Y-POS 2) ALU-XOR SHEET)
  (%DRAW-RECTANGLE-CLIPPED (- WIDTH 4) 2 (+ X-POS 2) (+ Y-POS HEIGHT -2) ALU-XOR SHEET))

;Mixin that causes a blinker to stay inside its sheet
(DEFFLAVOR STAY-INSIDE-BLINKER-MIXIN () ()
  (:INCLUDED-FLAVORS BLINKER))

(DEFWRAPPER (STAY-INSIDE-BLINKER-MIXIN :SET-CURSORPOS) (XY . BODY)
  `(PROGN (SETF (FIRST XY) (MIN (FIRST XY) (- (SHEET-INSIDE-WIDTH SHEET) WIDTH)))
	  (SETF (SECOND XY) (MIN (SECOND XY) (- (SHEET-INSIDE-HEIGHT SHEET) HEIGHT)))
	  . ,BODY))

(DEFFLAVOR IBEAM-BLINKER
	((HEIGHT NIL))
	(BLINKER)
  (:INITABLE-INSTANCE-VARIABLES HEIGHT))

(DEFMETHOD (IBEAM-BLINKER :BEFORE :INIT) (IGNORE)
  (OR HEIGHT (SETQ HEIGHT (SHEET-LINE-HEIGHT SHEET))))

(DEFMETHOD (IBEAM-BLINKER :SIZE) ()
  (PROG () (RETURN 9. HEIGHT)))

(DEFMETHOD (IBEAM-BLINKER :BLINK) (&AUX X0)
  (%DRAW-RECTANGLE-CLIPPED 2 HEIGHT (MAX 0 (1- X-POS)) Y-POS ALU-XOR SHEET)
  (SETQ X0 (MAX 0 (- X-POS 4)))
  (%DRAW-RECTANGLE-CLIPPED (- (+ X-POS 5) X0) 2 X0 (MAX 0 (- Y-POS 2)) ALU-XOR SHEET)
  (%DRAW-RECTANGLE-CLIPPED (- (+ X-POS 5) X0) 2 X0 (+ Y-POS HEIGHT) ALU-XOR SHEET))

(DEFFLAVOR CHARACTER-BLINKER
	(FONT
	 CHAR)
	(BLINKER)
  (:INITABLE-INSTANCE-VARIABLES FONT CHAR))

(DEFMETHOD (CHARACTER-BLINKER :BEFORE :INIT) (IGNORE)
  (SETQ FONT (FUNCALL (SHEET-GET-SCREEN SHEET) ':PARSE-FONT-DESCRIPTOR FONT)))

(DEFMETHOD (CHARACTER-BLINKER :SIZE) ()
  (PROG () (RETURN (SHEET-CHARACTER-WIDTH SHEET CHAR FONT) (FONT-BLINKER-HEIGHT FONT))))

(DEFMETHOD (CHARACTER-BLINKER :BLINK) (&AUX (FIT (FONT-INDEXING-TABLE FONT)))
  "Use a character as a blinker.  Any font, any character"
  (IF (NULL FIT)
      (%DRAW-CHAR FONT CHAR X-POS Y-POS ALU-XOR SHEET)
      ;;Wide character, draw in segments
      (DO ((CH (AREF FIT CHAR) (1+ CH))
	   (LIM (AREF FIT (1+ CHAR)))
	   (BPP (SHEET-BITS-PER-PIXEL SHEET))
	   (X X-POS (+ X (// (FONT-RASTER-WIDTH FONT) BPP))))
	  ((= CH LIM))
	(%DRAW-CHAR FONT CH X Y-POS ALU-XOR SHEET))))

(DEFMETHOD (CHARACTER-BLINKER :SET-CHARACTER) (NCHAR &OPTIONAL (NFONT FONT))
  (SETQ NFONT (FUNCALL (SHEET-GET-SCREEN SHEET) ':PARSE-FONT-DESCRIPTOR NFONT))
  (AND (OR (NEQ NCHAR CHAR) (NEQ NFONT FONT))
       (WITHOUT-INTERRUPTS
	 (OPEN-BLINKER SELF)
	 (SETQ CHAR NCHAR FONT NFONT))))

(DEFMETHOD (CHARACTER-BLINKER :CHARACTER) () (VALUES CHAR FONT))

(COMPILE-FLAVOR-METHODS RECTANGULAR-BLINKER CHARACTER-BLINKER IBEAM-BLINKER
			BOX-BLINKER HOLLOW-RECTANGULAR-BLINKER)