;;; -*- 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
      (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :NO-POINTER)	;Do %POINTER explicitly
	(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)
       (VALUES 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)
    (AND (SHEET-EXPOSED-P SCREEN)
	 (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 ((OSUP SUP SUP))
					    (())
					  (SETQ SUP (SHEET-SUPERIOR OSUP))
					  (AND (OR (NULL SUP)
						   (> LC (SHEET-LOCK-COUNT SUP)))
					       ;; Found where the buck stops, return the sheet
					       (RETURN OSUP)))))
		 (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) ()
  (VALUES X-OFFSET Y-OFFSET (+ X-OFFSET WIDTH) (+ Y-OFFSET HEIGHT)))

(DEFMETHOD (SHEET :SIZE) ()
  (VALUES WIDTH HEIGHT))

(DEFMETHOD (SHEET :INSIDE-SIZE) ()
  (VALUES (SHEET-INSIDE-WIDTH) (SHEET-INSIDE-HEIGHT)))

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

(DEFMETHOD (SHEET :POSITION) ()
  (VALUES X-OFFSET Y-OFFSET))

(DEFMETHOD (SHEET :MARGINS) ()
  (VALUES 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-S2)
	 ;; 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 MAKE-WINDOW (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))

(DEFF WINDOW-CREATE 'MAKE-WINDOW)
(COMPILER:MAKE-OBSOLETE WINDOW-CREATE "it has been renamed to TV:MAKE-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 #'MAKE-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 DEFAULT-FONT (FUNCALL-SELF ':PARSE-FONT-DESCRIPTOR DEFAULT-FONT))
  (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 "SYS: FONTS; ~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))))))
      ))))

(DEFMETHOD (SCREEN :BEFORE :CHANGE-OF-DEFAULT-FONT) (OLD-FONT NEW-FONT)
  (IF (EQ DEFAULT-FONT OLD-FONT) (SETQ DEFAULT-FONT NEW-FONT)))

;This is the default method, which those who don't want their fonts changed may replace
;perhaps by including the NO-CHANGE-OF-DEFAULT-FONT-MIXIN
(DEFMETHOD (SHEET :CHANGE-OF-DEFAULT-FONT) (OLD-FONT NEW-FONT &AUX CHANGE CURRENT)
  (DOTIMES (I (ARRAY-LENGTH FONT-MAP))
    (IF (EQ (AREF FONT-MAP I) CURRENT-FONT) (SETQ CURRENT I))
    (COND ((EQ (AREF FONT-MAP I) OLD-FONT)
	   (ASET NEW-FONT FONT-MAP I)
	   (SETQ CHANGE T))))
  (COND (CHANGE (FUNCALL-SELF ':SET-FONT-MAP FONT-MAP)
		(IF CURRENT (FUNCALL-SELF ':SET-CURRENT-FONT CURRENT))))
  (FUNCALL-SELF ':UPDATE-TIME-STAMP)
  (DOLIST (I INFERIORS)
    (FUNCALL I ':CHANGE-OF-DEFAULT-FONT OLD-FONT NEW-FONT)))

(DEFFLAVOR NO-CHANGE-OF-DEFAULT-FONT-MIXIN () ()
  (:INCLUDED-FLAVORS SHEET)
  (:DOCUMENTATION :MIXIN
    "Prevent SET-DEFAULT-FONT from changing the fonts of this sheet and its inferiors"))

(DEFMETHOD (NO-CHANGE-OF-DEFAULT-FONT-MIXIN :CHANGE-OF-DEFAULT-FONT) (OLD-FONT NEW-FONT)
  OLD-FONT NEW-FONT
  NIL)

(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)
  (MIN (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")))
       (IF SUPERIOR (SHEET-INSIDE-WIDTH SUPERIOR) 1000000))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN DECODE-CHARACTER-HEIGHT-SPEC (SPEC &OPTIONAL WIDTH-ALSO &AUX WID)
  (AND WIDTH-ALSO (STRINGP SPEC)
       (SETQ WID (- (DECODE-CHARACTER-WIDTH-SPEC SPEC) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))
  (MIN (COND ((NUMBERP SPEC)
	      (+ (* SPEC LINE-HEIGHT)
		 TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
	     ((STRINGP SPEC)
	      (MULTIPLE-VALUE-BIND (IGNORE HT)
		  (SHEET-COMPUTE-MOTION SELF 0 0 SPEC 0 NIL T 0 1000000 1000000 WID)
		(+ HT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)))
	     (T (FERROR NIL "~S illegal as :CHARACTER-HEIGHT; use NIL, number, or string")))
       (IF SUPERIOR (SHEET-INSIDE-HEIGHT SUPERIOR) 1000000))))

(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 ((OLD-INHIBIT-SCHEDULING-FLAG INHIBIT-SCHEDULING-FLAG)
	       (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
	       (LET ((FLAG NIL))
		 (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 OLD-INHIBIT-SCHEDULING-FLAG
				FLAG T)
			  (FUNCALL SIBLING ':DEEXPOSE))))
		 (AND 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 (OLD-INHIBIT-SCHEDULING-FLAG INHIBIT-SCHEDULING-FLAG)
				 (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 ((AND SUPERIOR-HAS-SCREEN-ARRAY (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-DISCARD-CLICKAHEAD)
	(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 OLD-INHIBIT-SCHEDULING-FLAG)
	(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))))
	 (IF (NOT (NULL MORE-VPOS))		;Might have been disabled while waiting!!
	     (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 MAKE-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)

(DEFF DEFINE-BLINKER 'MAKE-BLINKER) ;Keep old name for compatibility.
(COMPILER:MAKE-OBSOLETE DEFINE-BLINKER "it has been renamed to TV:MAKE-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) ()
  (VALUES 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)))
  (IF (EQ BLINKER MOUSE-BLINKER) (%OPEN-MOUSE-CURSOR)))

;;; 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)
    (AND (SHEET-EXPOSED-P S)
	 (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)))
	 (AND (EQ SHEET MOUSE-SHEET)
	      (= MOUSE-CURSOR-STATE 1)
	      (= MOUSE-CURSOR-CLOSED-STATE 2)
	      (NEQ WINDOW-OWNING-MOUSE 'STOP)
	      (NOT (SHEET-OUTPUT-HELD-P SHEET))
	      (LET ((LV (SHEET-LOCK SHEET)))
		(OR (NULL LV) (LISTP LV)))
	      (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE
		    PREPARED-SHEET NIL))
	 (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 (OLD-PHASE 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."
  (WITH-BLINKER-READY 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 ((NULL VISIBILITY)   ;Don't open if visibility NIL (especially the mouse cursor!)
	   (SETQ X-POS X Y-POS Y FOLLOW-P NIL))
	  ((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)
	   ;; If this is the mouse blinker, and it is not being tracked by microcode,
	   ;; then it is important to turn it back on immediately.
	   (AND (NEQ VISIBILITY ':BLINK)
		OLD-PHASE
		(BLINK SELF))))))

(DEFMETHOD (RECTANGULAR-BLINKER :SET-SIZE) (NWIDTH NHEIGHT)
  (COND ((OR ( WIDTH NWIDTH)
	     ( HEIGHT NHEIGHT))
	 (WITH-BLINKER-READY ()
	   (SETQ WIDTH NWIDTH HEIGHT NHEIGHT)))))

(DEFMETHOD (RECTANGULAR-BLINKER :SET-SIZE-AND-CURSORPOS) (NWIDTH NHEIGHT X Y)
  "This is like :SET-SIZE and :SET-CURSORPOS together, in order to prevent
the user from seeing the intermediate state.  This prevents occasional
spasticity in menu blinkers, which looks terrible."
  (WITH-BLINKER-READY 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 ((NULL VISIBILITY)   ;Don't open if visibility NIL (especially the mouse cursor!)
	   (SETQ X-POS X Y-POS Y FOLLOW-P NIL WIDTH NWIDTH HEIGHT NHEIGHT))
	  ((OR (NEQ X X-POS)			;Only blink if actually moving blinker
	       (NEQ Y Y-POS)
	       (NEQ WIDTH NWIDTH)
	       (NEQ HEIGHT NHEIGHT))
	   (OPEN-BLINKER SELF)
	   (SETQ X-POS X Y-POS Y FOLLOW-P NIL WIDTH NWIDTH HEIGHT NHEIGHT)))))

(DEFMETHOD (BLINKER :SET-FOLLOW-P) (NEW-FOLLOW-P)
  "Turn on or off whether the blinker follows the sheet's typeout cursor."
  (COND ((NEQ FOLLOW-P NEW-FOLLOW-P)
	 (WITH-BLINKER-READY ()
	   (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"
  (VALUES (- (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 (BLINKER :SET-SHEET) (NEW-SHEET &AUX EXCH-FLAG S-SUP S-INF)
  (COND ((NEQ NEW-SHEET SHEET)
	 ;; Only need to turn off blinker if it is turned on
	 (WITH-BLINKER-READY ()
	   (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) ()
  (VALUES 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) ()
  (VALUES (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))

(DEFFLAVOR BITBLT-BLINKER
	((WIDTH NIL)
	 (HEIGHT NIL)
	 (ARRAY NIL)
	 (DELTA-X 0)
	 (DELTA-Y 0))
	(BLINKER)
  :INITABLE-INSTANCE-VARIABLES)

(DEFMETHOD (BITBLT-BLINKER :BEFORE :INIT) (IGNORE)
  (IF (NULL ARRAY)
      (FERROR NIL "Attept to create a BITBLT-BLINKER without specifying any array"))
  (IF (NULL WIDTH)
      (SETQ WIDTH (ARRAY-DIMENSION-N 1 ARRAY)))
  (IF (NULL HEIGHT)
      (SETQ WIDTH (ARRAY-DIMENSION-N 2 ARRAY))))

(DEFMETHOD (BITBLT-BLINKER :SIZE) ()
  (VALUES WIDTH HEIGHT))

(DEFMETHOD (BITBLT-BLINKER :BLINK) ()
  (BITBLT ALU-XOR WIDTH HEIGHT
	  ARRAY 0 0
	  (SHEET-SCREEN-ARRAY SHEET) (+ DELTA-X X-POS) (+ DELTA-Y Y-POS)))

(DEFFLAVOR REVERSE-CHARACTER-BLINKER
	((CHARACTER NIL)
	 (FONT T))
	(BITBLT-BLINKER)
  (:INITABLE-INSTANCE-VARIABLES CHARACTER FONT))

(DEFMETHOD (REVERSE-CHARACTER-BLINKER :BEFORE :INIT) (IGNORE)
  (IF (NULL CHARACTER) (FERROR NIL "You must specify a character"))
  (FUNCALL-SELF ':SET-CHARACTER NIL))

(DEFMETHOD (REVERSE-CHARACTER-BLINKER :SET-CHARACTER) (NEW-CHARACTER &OPTIONAL NEW-FONT)
  (IF NEW-CHARACTER (SETQ CHARACTER NEW-CHARACTER))
  (IF NEW-FONT (SETQ FONT NEW-FONT))
  (SETQ FONT (IF (EQ FONT T)
		 (SHEET-CURRENT-FONT SHEET)
		 (FUNCALL (SHEET-GET-SCREEN SHEET) ':PARSE-FONT-DESCRIPTOR FONT)))
  (SETQ WIDTH (LET ((CWT (FONT-CHAR-WIDTH-TABLE FONT)))
		(IF CWT (AREF CWT CHARACTER) (FONT-CHAR-WIDTH FONT))))
  (SETQ HEIGHT (FONT-BLINKER-HEIGHT FONT))
  (SETQ ARRAY (MAKE-SHEET-BIT-ARRAY SHEET WIDTH HEIGHT))
  (SETQ DELTA-X
	(- (LET ((LKT (FONT-LEFT-KERN-TABLE FONT)))
	     (IF LKT (AREF LKT CHARACTER) 0))))
  (%DRAW-RECTANGLE WIDTH HEIGHT 0 0 TV:ALU-IOR ARRAY)
  (LET ((FIT (FONT-INDEXING-TABLE FONT)))
    (IF (NULL FIT)
	(%DRAW-CHAR FONT CHARACTER 0 0 ALU-ANDCA ARRAY)
	(LOOP FOR CH FROM (AREF FIT CHARACTER) BELOW (AREF FIT (+ CHARACTER 1))
	      WITH BPP = (SHEET-BITS-PER-PIXEL SHEET)
	      FOR X = 0 THEN (+ X (// (FONT-RASTER-WIDTH FONT) BPP))
	      DO (%DRAW-CHAR FONT CH X 0 ALU-ANDCA ARRAY)))))

(DEFMETHOD (REVERSE-CHARACTER-BLINKER :SET-SIZE) (NEW-WIDTH NEW-HEIGHT)
  NEW-WIDTH NEW-HEIGHT
  ;no can do
  NIL)

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