;;; -*- 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 &REST IGNORE)
  (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"))))

;;;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))

(DEFUN SHEET-CAN-GET-LOCK (SHEET &OPTIONAL (UNIQUE-ID CURRENT-PROCESS) &AUX CAN-GET LOSER)
  "Returns T if a sheet's lock can be gotten.  Should be called with interrupts
inhibited if it's to be meaningful.  Second value is sheet that lock can't ge gotten on."
  (PROG CANT-GET-LOCK ()
    (COND ((EQ (SHEET-LOCK SHEET) UNIQUE-ID)
	   ;; If we own the lock on this window, we must also own it on all inferiors
	   (RETURN T))
	  ((NULL (SHEET-LOCK SHEET))
	   (DO ((SHEET (SHEET-INFERIORS SHEET) (CDR SHEET)))
	       ((NULL SHEET))
	     (MULTIPLE-VALUE (CAN-GET LOSER)
	       (SHEET-CAN-GET-LOCK (CAR SHEET) UNIQUE-ID))
	     (OR CAN-GET (RETURN-FROM CANT-GET-LOCK NIL LOSER))))
	  (T (RETURN-FROM CANT-GET-LOCK NIL SHEET)))
    (RETURN T)))

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

(DEFUN SHEET-GET-LOCK-INTERNAL (SHEET UNIQUE-ID
				      &AUX (LOCK (LOCF (SHEET-LOCK SHEET))))
  "Really get the lock on a sheet and its inferiors.  Must be INHIBIT-SCHEDULING-FLAG
bound and set to T.  The caller better make sure that PROCESS-LOCK can't block."
  (COND ((EQ UNIQUE-ID (CAR LOCK))
	 (SETF (SHEET-LOCK-COUNT SHEET) (1+ (SHEET-LOCK-COUNT SHEET)))) ;Only unlocked when 0
	(T
	 (PROCESS-LOCK LOCK UNIQUE-ID)
	 (SETF (SHEET-LOCK-COUNT SHEET) 1)))
  (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 (LOCF (SHEET-LOCK SHEET))))
  "Release a lock on a sheet and its inferiors"
  (COND ((EQ UNIQUE-ID (CAR LOCK))
	 (SETF (SHEET-LOCK-COUNT SHEET) (1- (SHEET-LOCK-COUNT SHEET)))
	 (AND (ZEROP (SHEET-LOCK-COUNT SHEET))
	      (PROCESS-UNLOCK LOCK UNIQUE-ID))
	 (DOLIST (INFERIOR (SHEET-INFERIORS SHEET))
	   (SHEET-RELEASE-LOCK INFERIOR UNIQUE-ID)))))

(DEFUN SHEET-CAN-GET-TEMPORARY-LOCK (SHEET)
  "Returns T if the lock can be grabbed.  Probably should be called with interrupts
inhibited for meaningful results"
  (OR (NULL (SHEET-LOCK SHEET))
      (LISTP (SHEET-LOCK SHEET))))

(DEFUN SHEET-GET-TEMPORARY-LOCK (SHEET UNIQUE-ID)
  "Get a temporary lock on a sheet.  UNQIUE-ID should be the locker."
  (DO ((LOC (LOCF (SHEET-LOCK SHEET)))
       (INHIBIT-SCHEDULING-FLAG T T)
       (LOCK))
      ((OR (NULL (SETQ LOCK (CAR LOC))) (LISTP LOCK))
       (PUSH UNIQUE-ID (SHEET-LOCK SHEET)))
    (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    (PROCESS-WAIT "LOCK" #'(LAMBDA (LOC) (OR (NULL (CAR LOC)) (LISTP (CAR LOC)))) LOC)))

(DEFUN SHEET-RELEASE-TEMPORARY-LOCK (SHEET UNIQUE-ID &AUX (INHIBIT-SCHEDULING-FLAG T))
  "Release a temporary lock on a sheet.  UNIQUE-ID should be the locker."
  (SETF (SHEET-LOCK SHEET) (DELQ UNIQUE-ID (SHEET-LOCK SHEET))))

(DEFUN SHEET-FREE-TEMPORARY-LOCKS (SHEET)
  "Free all temporary locks on a sheet by deexposing the sheets that own the lock.
Since the intention is that one wants to get the lock on the sheet, also loop
over all the inferiors."
  (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)))
	  (T (FUNCALL LOCK ':DEEXPOSE))))
  (DOLIST (I (SHEET-INFERIORS SHEET))
    (SHEET-FREE-TEMPORARY-LOCKS I)))

(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-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-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))

(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 (SORT-SHORT-LIST 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 SHEET-AREA))
  (DELAYING-SCREEN-MANAGEMENT
    (FUNCALL WINDOW ':INIT PLIST)
    (AND (SHEET-BIT-ARRAY WINDOW)
	 (SHEET-FORCE-ACCESS (WINDOW T)
	   (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-FCN '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))
	(:RIGHT (SETQ RIGHT VAL))
	(:BOTTOM (SETQ BOTTOM 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-FUNCTION (SETQ BLINK-FCN 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))
	(:TRUNCATE-LINE-OUT-FLAG (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG) VAL))))
  (SHEET-DEDUCE-AND-SET-SIZES RIGHT BOTTOM VSP INTEGRAL-P CHARACTER-WIDTH CHARACTER-HEIGHT)
  (AND SAVE-BITS
       (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))))
  (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-FCN
			     ':FOLLOW-P T ':DESELECTED-VISIBILITY DESELECTED-VISIBILITY
			     (AND (LISTP BLINKER-P) BLINKER-P)))))
  (SETF (SHEET-OUTPUT-HOLD-FLAG) 1)
  (IF REVERSE-VIDEO-P
      (SETQ CHAR-ALUF ALU-ANDCA
	    ERASE-ALUF ALU-IOR)
      (SETQ CHAR-ALUF ALU-IOR
	    ERASE-ALUF ALU-ANDCA))
  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)
	BUFFER-HALFWORD-ARRAY (MAKE-ARRAY NIL 'ART-16B
					  (// (* WIDTH HEIGHT BITS-PER-PIXEL) 16.)
					  ;;Displaced to actual video buffer
					  BUFFER))
  (OR BIT-ARRAY
      (SETQ OLD-SCREEN-ARRAY (MAKE-ARRAY NIL (SHEET-ARRAY-TYPE SELF)
					 (LIST WIDTH HEIGHT)	;Dimensions
					 BUFFER))))

(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.
		       (ERRSET (LOAD (FORMAT NIL "AI: LMFONT; ~A" FD) "FONTS") 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 ((FM (MAKE-ARRAY NIL 'ART-Q '(26.) NIL NIL)))
	   (DO ((I 0 (1+ I))
		(L NEW-MAP (OR (CDR L) L)))
	       ((= I 26.))
	     (AS-1 (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))
;	 (MAXWIDTH 0)
	 (MAXHEIGHT 0)
	 (MAXBASE 0)
	 (FONT))
	((= I 26.)
	 (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
   (COND ((NULL CHARACTER-WIDTH))
	 ((NUMBERP CHARACTER-WIDTH)
	  (SETQ WIDTH (+ (* CHARACTER-WIDTH CHAR-WIDTH) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))
	 ((STRINGP CHARACTER-WIDTH)
	  (SETQ WIDTH (+ (SHEET-STRING-LENGTH SELF CHARACTER-WIDTH)
			 LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))
	 ((FERROR NIL "~S illegal as :CHARACTER-WIDTH; use NIL, number, or string")))
   (COND ((NULL CHARACTER-HEIGHT))
	 ((NUMBERP CHARACTER-HEIGHT)
	  (SETQ HEIGHT (+ (* CHARACTER-HEIGHT LINE-HEIGHT)
			  TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)))
	 ((STRING CHARACTER-HEIGHT)
	  (SETQ HEIGHT (DO ((HT (+ TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE) (+ HT LINE-HEIGHT))
			    (I -1 (STRING-SEARCH-CHAR #\CR CHARACTER-HEIGHT (1+ I))))
			   ((NULL I) HT))))
	 ((FERROR NIL "~S illegal as :CHARACTER-HEIGHT; use NIL, number, or string")))

   ;; 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))

(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))

(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 :CURRENT-FONT) ()
  CURRENT-FONT)

(DEFMETHOD (SHEET :SET-CURRENT-FONT) (NEW-FONT)
  (WITHOUT-INTERRUPTS
    (IF (NUMBERP NEW-FONT)
	(SETQ NEW-FONT (AREF FONT-MAP 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 :SAVE-BITS) ()
  (NOT (NULL BIT-ARRAY)))

(DEFMETHOD (SHEET :SET-SAVE-BITS) (SAVE-BITS)
  (OR SUPERIOR (FERROR NIL "Cannot :SET-SAVE-BITS on a top-level sheet"))
  (LOCK-SHEET (SELF)
   (WITHOUT-INTERRUPTS
    (COND (SAVE-BITS
	   (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))))
	  ((NULL BIT-ARRAY))
	  (T
	   (SETQ BIT-ARRAY NIL)
	   (COND ((NOT EXPOSED-P)
		  (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)))))))
  (AND (NOT EXPOSED-P)
       SAVE-BITS
       (SHEET-FORCE-ACCESS (SELF) (FUNCALL-SELF ':REFRESH))))

(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"
  (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)))

    ;;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
	       (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))
    (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 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))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SHEET-SET-POSITION (NEW-X NEW-Y)
  (LOCK-SHEET (SELF)
   (DELAYING-SCREEN-MANAGEMENT
    (COND ((NOT EXPOSED-P)
	   (SETQ X-OFFSET NEW-X
		 Y-OFFSET NEW-Y)
	   (OR BIT-ARRAY
	       (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)))))))
	  ((SHEET-TEMPORARY-P)
	   (LET ((SELECT-P (EQ SELF SELECTED-WINDOW)))
	     (FUNCALL-SELF ':DEEXPOSE)
	     (FUNCALL-SELF ':EXPOSE NIL NIL NEW-X NEW-Y)
	     (AND SELECT-P (FUNCALL-SELF ':SELECT))))
	  (T
	   (DO ((INHIBIT-SCHEDULING-FLAG T T))
	       (())
	     (OR (SHEET-BOUNDS-WITHIN-SHEET-P NEW-X NEW-Y WIDTH HEIGHT SUPERIOR)
		 (FERROR NIL "Attempt to move sheet ~S outside of superior" SELF))
	     ;; If moving an exposed sheet, make sure everyone under it is deexposed
	     (DOLIST (SISTER (SHEET-EXPOSED-INFERIORS SUPERIOR))
	       (COND ((AND (NEQ SELF SISTER)
			   (SHEET-OVERLAPS-P SISTER NEW-X NEW-Y WIDTH HEIGHT))
		      (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		      (FUNCALL SISTER ':DEEXPOSE))))
	     ;; If not allowing scheduling, then exposed all.  Stop looping.
	     (COND (INHIBIT-SCHEDULING-FLAG 
		    (SETQ 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)))))
		    (RETURN T))))))))))

;;; 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)))))))

(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)))

;;; Activation and deactivation
(DEFWRAPPER (SHEET :DEACTIVATE) (IGNORE . BODY)
  `(LOCK-SHEET (SELF)
     . ,BODY))

(DEFMETHOD (SHEET :ACTIVATE) (&AUX (INHIBIT-SCHEDULING-FLAG T))
  "Activates a sheet.  Should be called by all activate methods to do the actual work"
  (COND ((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))
		 ((OR (NULL (SHEET-LOCK SUPERIOR))
		      (LISTP (SHEET-LOCK SUPERIOR)))
		  ;; Cases one and two: superior is not locked or temp locked, no need
		  ;; to hack locks at all
		  (RETURN T))
		 ((NEQ (SHEET-LOCK SUPERIOR) CURRENT-PROCESS)
		  ;; Case 3: Superior is locked by someone else.  Wait until
		  ;;         case 1 or case 2 occurs
		  (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		  (PROCESS-WAIT "Activate" #'(LAMBDA (SUP W)
					       (OR (NULL (SHEET-LOCK SUP))
						   (LISTP (SHEET-LOCK SUP))
						   (MEMQ W (SHEET-INFERIORS SUP))))
				SUPERIOR SELF)
		  ;; Loop back to prevent timing screws
		  (SETQ INHIBIT-SCHEDULING-FLAG T))
		 (T
		  ;; Case 4: We own the lock on our superior.
		  ;; We will need to merge our locks with that of our superior.
		  (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))))
	 ;; 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)
  `(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."
  (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))
	 (COND ((OR (NULL (SHEET-LOCK SUPERIOR))
		    (LISTP (SHEET-LOCK SUPERIOR)))
		;; Superior not locked or temp locked, simple case
		)
	       (T
		;; Superior is locked by us, must subtract his lock count from ours.
		;; (Note: the superior can't be locked by someone else as in the
		;; activate case because we own the lock on one of his inferiors (namely,
		;; us) preventing this situation from arising)
		(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))

;;; 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)
  `(LOCK-SHEET (SELF)
     . ,BODY))

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

;;; 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 RESULT (INHIBIT-SCHEDULING-FLAG T)
					(SHEETS-MADE-INVISIBLE-TO-MOUSE NIL)
					SUPERIOR-HAS-SCREEN-ARRAY)
  "Expose a sheet (place it on the physical screen)"
  (OR (NULL SUPERIOR)
      (MEMQ SELF (SHEET-INFERIORS SUPERIOR))
      ;; We can only be exposed if we are activated
      (FERROR NIL "Attempt to expose deactivated sheet ~S" SELF))
  (SETQ RESTORED-BITS-P T)
  (OR BITS-ACTION (SETQ BITS-ACTION (IF BIT-ARRAY ':RESTORE ':CLEAN)))
  (DELAYING-SCREEN-MANAGEMENT
   (UNWIND-PROTECT
     (PROG ()
	MAIN-LOOP
	  (SETQ INHIBIT-SCHEDULING-FLAG T)
	  (AND EXPOSED-P (RETURN NIL))
	  (SETQ RESTORED-BITS-P NIL)
	  (SETQ SUPERIOR-HAS-SCREEN-ARRAY (OR (NULL SUPERIOR) (SHEET-SCREEN-ARRAY SUPERIOR)))
	  (AND (NULL SUPERIOR) (OR ( X X-OFFSET) ( Y Y-OFFSET))
	       (FERROR NIL
		       "Attempt to expose toplevel sheet at (~O, ~O) instead of (~O, ~O)"
		       X Y X-OFFSET Y-OFFSET))
	  (COND ((OR ( X-OFFSET X) ( Y-OFFSET Y))
		 (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		 (SHEET-SET-POSITION X Y)
		 (GO MAIN-LOOP)))
	  (COND (SUPERIOR
		 (OR (SHEET-WITHIN-SHEET-P SELF SUPERIOR)
		     (FERROR NIL "Attempt to expose ~S outside of its superior" SELF))
		 (COND ((AND (NOT SUPERIOR-HAS-SCREEN-ARRAY) (SHEET-TEMPORARY-P))
			(SETQ INHIBIT-SCHEDULING-FLAG NIL)
			(FUNCALL SUPERIOR ':EXPOSE BITS-ACTION)
			(AND (EQ BITS-ACTION ':CLEAN)
			     (SETQ BITS-ACTION ':NOOP))
			(GO MAIN-LOOP))
		       (SUPERIOR-HAS-SCREEN-ARRAY
			(SHEET-OPEN-ALL-BLINKERS SUPERIOR)))))

	  ;; 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)))))
		 (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
			       (PROGN
				 ;; 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 SUPERIOR)
					 ;; Sheet may be on EXPOSED-INFERIORS, but not
					 ;; in actuality exposed
					 (SHEET-EXPOSED-P TARGET)
					 (SHEET-OVERLAPS-SHEET-P SELF TARGET)
					 (OR (SHEET-CAN-GET-TEMPORARY-LOCK TARGET)
					     (*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
				 (MAP-OVER-EXPOSED-SHEET
				   #'(LAMBDA (TARGET)
				       (AND ;; Can't be us, we aren't exposed yet
					 (NEQ TARGET SUPERIOR)
					 ;; Sheet may be on EXPOSED-INFERIORS, but not
					 ;; in actuality exposed
					 (SHEET-EXPOSED-P TARGET)
					 (SHEET-OVERLAPS-SHEET-P SELF TARGET)
					 (SHEET-GET-TEMPORARY-LOCK TARGET SELF)
					 (PUSH TARGET TEMPORARY-WINDOWS-LOCKED)))
				   SUPERIOR)
				 ;; Return NIL indicating that we are winning
				 NIL)))
		 (COND ((NULL RESULT))
		       ((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)))
				      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)
			  (SETQ INHIBIT-SCHEDULING-FLAG NIL)
			  (FUNCALL SIBLING ':DEEXPOSE))))
		  (OR INHIBIT-SCHEDULING-FLAG
		      ;; If had to deexpose someone, world may have changed
		      (GO MAIN-LOOP))))

	  ;; 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
	       (NOT (MEMQ SELF (SHEET-EXPOSED-INFERIORS SUPERIOR)))	;This is legit case
	       (SHEET-CONSING
		 (SETF (SHEET-EXPOSED-INFERIORS SUPERIOR)
		       (CONS SELF (COPYLIST (SHEET-EXPOSED-INFERIORS SUPERIOR))))))
	  (AND SUPERIOR-HAS-SCREEN-ARRAY
	       (IF BIT-ARRAY
		   (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)))))
		   (SETQ SCREEN-ARRAY OLD-SCREEN-ARRAY)))
	  (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))))
	  (COND (SUPERIOR-HAS-SCREEN-ARRAY
		 (SETF (SHEET-OUTPUT-HOLD-FLAG) 0)
		 (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)))
		 (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		 (OR TURN-ON-BLINKERS
		     (DESELECT-SHEET-BLINKERS SELF))
		 (OR BIT-ARRAY
		     (DOLIST (INFERIOR EXPOSED-INFERIORS)
		       (FUNCALL INFERIOR ':EXPOSE NIL)))
		 (RETURN T))))
    (DOLIST (SHEET SHEETS-MADE-INVISIBLE-TO-MOUSE)
      (SETF (SHEET-INVISIBLE-TO-MOUSE-P SHEET) NIL))
    (MOUSE-WAKEUP))))

(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
    (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
	     (LET ((SHEETS-MADE-INVISIBLE-TO-MOUSE NIL))
	       (UNWIND-PROTECT
		 (DO () ((OR (NOT (TYPEP MOUSE-WINDOW 'SHEET))
			     (NOT (SHEET-ME-OR-MY-KID-P MOUSE-WINDOW SELF))))
		   ;; Force out the mouse
		   (PUSH MOUSE-WINDOW SHEETS-MADE-INVISIBLE-TO-MOUSE)
		   (SETF (SHEET-INVISIBLE-TO-MOUSE-P MOUSE-WINDOW) T)
		   (SETQ MOUSE-RECONSIDER T)
		   (PROCESS-WAIT "Mouse Out" #'(LAMBDA (SHEET) (NEQ MOUSE-WINDOW SHEET))
				 (PROG1 MOUSE-WINDOW (SETQ INHIBIT-SCHEDULING-FLAG NIL)))
		   (SETQ INHIBIT-SCHEDULING-FLAG T))
		 (DOLIST (SHEET SHEETS-MADE-INVISIBLE-TO-MOUSE)
		   (SETF (SHEET-INVISIBLE-TO-MOUSE-P SHEET) NIL))))
	     (AND (EQ SAVE-BITS-P ':FORCE)
		  (NULL BIT-ARRAY)
		  (SETQ BIT-ARRAY (MAKE-ARRAY NIL (SHEET-ARRAY-TYPE SELF)
					      (LIST (LOGAND -40 (+ 37 WIDTH)) HEIGHT))
			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))	;This will handle MORE, end-of-page, then clear line

;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 :NOTE-INPUT-WAIT) ()
  (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)))))


(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)
  (SHEET-STRING-OUT SELF "**MORE**")


;;; **********************************************************************
;;; ** The following is a total kludge and should not even be looked at **
;;; **********************************************************************
  (AND (SETQ HANDLER (GET-HANDLER-FOR SELF OPERATION))
       (LET ((INHIBIT-SCHEDULING-FLAG T)
	     (OLD-LOCK) (OLD-LOCK-COUNT))
	 (UNWIND-PROTECT
	   (PROGN
	     (SETQ OLD-LOCK (SHEET-LOCK SELF)
		   OLD-LOCK-COUNT (SHEET-LOCK-COUNT SELF))
	     (SETF (SHEET-LOCK SELF) NIL)
	     (SETF (SHEET-LOCK-COUNT SELF) NIL)
	     (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	     (SETQ CHAR (FUNCALL HANDLER OPERATION)))
	   (DO () (())
	     (SETQ INHIBIT-SCHEDULING-FLAG T)
	     (COND ((NULL (SHEET-LOCK SELF))
		    ;; If sheet not locked by anyone, then we can take the lock back
		    (SETF (SHEET-LOCK SELF) OLD-LOCK)
		    (SETF (SHEET-LOCK-COUNT SELF) OLD-LOCK-COUNT)
		    (RETURN T)))
	     (SETQ INHIBIT-SCHEDULING-FLAG NIL)
	     (PROCESS-WAIT "After More Kludge"
			   #'(LAMBDA (LOC) (NULL (CAR LOC)))
			   (LOCF (SHEET-LOCK SELF)))))))
  (PREPARE-SHEET (SELF) )		;Open blinkers.
;;; ******************* End of total, complete, and utter kludge


  (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 ':NOTE-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))
	(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))

;;;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))))))

(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))
  "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."
  (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 ((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 at 0, 0
		(SETQ X-POS 0)
		(SETQ Y-POS 0)))
	 (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))

(DEFMETHOD (HOLLOW-RECTANGULAR-BLINKER :BLINK) ()
  (%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))

(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))))

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