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

;;; The screen manager, an unseen entity that many have cursed and
;;; many have praised, is herewithin presented for all to see.

;;; Priorities:
;;; Each sheet has a priority (which is basically how hard it tries to be on the screen).
;;; The priorities are used for ordering the list of inferiors of a sheet, and therefore
;;; affect what windows the mouse sees, how the screen manager works, and how the automatic
;;; exposing decides what to expose.  If the priority is null, then it is considered
;;; to have a priority smaller than that of any with explicit priorities (this includes
;;; negative priorities, but that doesn't really matter).  Positive priorities mean an
;;; absolute priority as compared to all other sheets with a numerical priority -- namely,
;;; the larger the number, the more important the sheet is considered to be.  A negative
;;; priority indicates that the sheet is to be considered "inactive" by various routines
;;; when it is not exposed.  -1 means only be considered inactive by the screen manager,
;;; and -2 or less means don't even be a candidate for auto-exposure.  Exposed sheets
;;; are always uncovered, and therefore are guaranteed to have the largest priority
;;; (virtually, and since they don't overlap, all exposed sheets are considered the same).

;;; Notes: A set of rectangles is a list of rectangles.  All functions that
;;; operate on sets expect them in the canonical form (a list of rectangles
;;; that don't mutually overlap).  All user-level functions that return sets
;;; canonicalize them first.

;;; A rectangle is a four-list of (SOURCE LEFT TOP RIGHT BOTTOM)
;;; SOURCE where the rectangle came from.  Rectangles cannot have
;;; their LEFT, TOP, RIGHT, or BOTTOM destructively altered.

(DEFUN CANONICALIZE-RECTANGLE-SET (S)
  "Given a set of rectangles, returns a set in canonical form (that have no overlaps)."
  (DO ((NEW NIL NIL))
      (NIL)
;;; It's not clear whether the sorting helps at all
;    (SETQ S
;	  (SORT S #'(LAMBDA (X Y)
;		      (NOT (< (* (- (RECT-RIGHT X) (RECT-LEFT X))
;				 (- (RECT-BOTTOM X) (RECT-TOP X)))
;			      (* (- (RECT-RIGHT Y) (RECT-LEFT Y))
;				 (- (RECT-BOTTOM Y) (RECT-TOP Y))))))))
    (DO ((R (CAR S) (CAR L))
	 (L (CDR S) (CDR L))
	 (S-TEM))
	((NULL L))
      (DOLIST (RA L)
	(COND ((RECT-NOT-OVERLAP-RECT-P R RA)
	       ;; No overlap, ok
	       )
	      ((RECT-WITHIN-RECT-P R RA)
	       ;; R completely within RA, throw R away
	       (SETQ S (DELQ R S))
	       (RETURN NIL))
	      ((RECT-WITHIN-RECT-P RA R)
	       ;; RA completely within R, throw RA away
	       (SETQ S (DELQ RA S))
	       (RETURN NIL))
	      (T
		(SETQ S-TEM
		      ;; Get all sections of RA not inside of R
		      (RECTANGLE-NOT-INTERSECTION R RA))
		(OR S-TEM
		    ;; No result can't happen if above checks don't succeed
		    (FERROR NIL "Null not-intersection impossible: ~S ~S" R RA))
		(DOLIST (RB S-TEM)
		  (AND (RECT-WITHIN-RECT-P RB R)
		       (SETQ S-TEM (DELQ RB S-TEM))))
		(SETQ NEW (NCONC S-TEM NEW)
		      S (DELQ RA S))))))
    ;; When no new rectangles generated, return the old list
    (OR NEW (RETURN S))
    (SETQ S (NCONC NEW S))))

(DEFUN RECTANGLE-NOT-INTERSECTION (RPRIME RAUX &AUX SET)
  "Return a set of rectangles which consists of all the area in RAUX that
is not also in RPRIME.  The set is garunteed to be canonical."
  (COND ((RECT-NOT-OVERLAP-RECT-P RPRIME RAUX)
	 ;; No intersection at all, just return RAUX
	 (NCONS RAUX))
	((RECT-WITHIN-RECT-P RAUX RPRIME)
	 ;; No area that isn't in RPRIME
	 NIL)
	(T
	 (AND (< (RECT-TOP RAUX) (RECT-TOP RPRIME))
	      (PUSH (LIST (RECT-SOURCE RAUX)
			  (RECT-LEFT RAUX) (RECT-TOP RAUX)
			  (RECT-RIGHT RAUX) (RECT-TOP RPRIME))
		    SET))
	 (AND (> (RECT-BOTTOM RAUX) (RECT-BOTTOM RPRIME))
	      (PUSH (LIST (RECT-SOURCE RAUX)
			  (RECT-LEFT RAUX) (RECT-BOTTOM RPRIME)
			  (RECT-RIGHT RAUX) (RECT-BOTTOM RAUX))
		    SET))
	 (AND (< (RECT-LEFT RAUX) (RECT-LEFT RPRIME))
	      (PUSH (LIST (RECT-SOURCE RAUX)
			  (RECT-LEFT RAUX) (MAX (RECT-TOP RPRIME) (RECT-TOP RAUX))
			  (RECT-LEFT RPRIME) (MIN (RECT-BOTTOM RPRIME) (RECT-BOTTOM RAUX)))
		    SET))
	 (AND (> (RECT-RIGHT RAUX) (RECT-RIGHT RPRIME))
	      (PUSH (LIST (RECT-SOURCE RAUX)
			  (RECT-RIGHT RPRIME) (MAX (RECT-TOP RPRIME) (RECT-TOP RAUX))
			  (RECT-RIGHT RAUX) (MIN (RECT-BOTTOM RPRIME) (RECT-BOTTOM RAUX)))
		    SET))
	 SET)))

;;; The real screen manager:
(DEFRESOURCE SCREEN-MANAGER-BIT-ARRAY-RESOURCE ()
   :CONSTRUCTOR (MAKE-ARRAY (LIST (SHEET-WIDTH DEFAULT-SCREEN) (SHEET-HEIGHT DEFAULT-SCREEN))
			    ':TYPE 'ART-1B)
   :INITIAL-COPIES 0)

(DEFUN SCREEN-MANAGE-SHEET (SHEET &OPTIONAL BOUND-RECTANGLES ARRAY-TO-DRAW-ON (X 0) (Y 0) ALU
				  &AUX RECTANGLE-LIST NOT-WHOLE)
  "Perform screen management on a sheet.  Should be called with the sheet locked, and
inferiors ordered, and inside a method handling a message to that sheet.  The rectangles
passed in here better be destructable."
  (LET ((LEFT (SHEET-INSIDE-LEFT SHEET))
	(TOP (SHEET-INSIDE-TOP SHEET))
	(RIGHT (SHEET-INSIDE-RIGHT SHEET))
	(BOTTOM (SHEET-INSIDE-BOTTOM SHEET)))
    (DOLIST (R BOUND-RECTANGLES)
      (SETF (RECT-LEFT R) (MAX LEFT (RECT-LEFT R)))
      (SETF (RECT-TOP R) (MAX TOP (RECT-TOP R)))
      (SETF (RECT-RIGHT R) (MIN RIGHT (RECT-RIGHT R)))
      (SETF (RECT-BOTTOM R) (MIN BOTTOM (RECT-BOTTOM R)))
      ;; Is this now an illegal rectangle?  If so, then punt it altogether
      (OR (AND (< (RECT-LEFT R) (RECT-RIGHT R)) (< (RECT-TOP R) (RECT-BOTTOM R)))
	  (SETQ BOUND-RECTANGLES (DELQ R BOUND-RECTANGLES)))))
  (COND (BOUND-RECTANGLES
	 (SETQ NOT-WHOLE T
	       BOUND-RECTANGLES (CANONICALIZE-RECTANGLE-SET BOUND-RECTANGLES)))
	(T
	 (SETQ BOUND-RECTANGLES
	       (LIST (LIST (LIST SHEET 0 0)
			   (SHEET-INSIDE-LEFT SHEET) (SHEET-INSIDE-TOP SHEET)
			   (SHEET-INSIDE-RIGHT SHEET) (SHEET-INSIDE-BOTTOM SHEET))))))

  ;; Figure out what should be visible
  ;; This loop is executed with S each of the inferiors then with S the sheet itself
  (DO ((INFS (SHEET-INFERIORS SHEET) (CDR INFS))
       (S) (R-TEM) (S-TEM))
      ((NULL BOUND-RECTANGLES))
    (AND (NULL INFS)
	 (RETURN (SETQ RECTANGLE-LIST (NCONC BOUND-RECTANGLES RECTANGLE-LIST))))
    (SETQ S (CAR INFS))
    (SETQ S-TEM (SCREEN-MANAGE-SHEET-RECTANGLES S BOUND-RECTANGLES))
    ;; S-TEM is the set of rectangles which are visible portions of S
    (IF (NULL S-TEM)
	NIL
	(DOLIST (R S-TEM)
	  (DOLIST (RA BOUND-RECTANGLES)
	    (SETQ BOUND-RECTANGLES (DELQ RA BOUND-RECTANGLES)
		  R-TEM (RECTANGLE-NOT-INTERSECTION R RA))
	    (AND R-TEM (SETQ BOUND-RECTANGLES (NCONC R-TEM BOUND-RECTANGLES))))
	  (OR BOUND-RECTANGLES (RETURN T)))
	(OR (AND (SHEET-EXPOSED-P S) (SHEET-SCREEN-ARRAY SHEET))
	    ;; Never need to restore exposed sheets if superior
	    ;; has a screen image
	    (SETQ RECTANGLE-LIST (NCONC S-TEM RECTANGLE-LIST)))))

  (SCREEN-MANAGE-FLUSH-KNOWLEDGE SHEET)

  ;; Now do the updates
  (AND RECTANGLE-LIST
       (IF ARRAY-TO-DRAW-ON
	   (SCREEN-MANAGE-SHEET-FINAL SHEET RECTANGLE-LIST ARRAY-TO-DRAW-ON X Y ALU)
	   (SHEET-FORCE-ACCESS (SHEET)
	     (SCREEN-MANAGE-SHEET-FINAL SHEET RECTANGLE-LIST ARRAY-TO-DRAW-ON X Y ALU)))))

(DEFUN SCREEN-MANAGE-SHEET-FINAL (SHEET RECTANGLE-LIST ARRAY-TO-DRAW-ON X Y ALU)
  (OR ARRAY-TO-DRAW-ON (SETQ ARRAY-TO-DRAW-ON (SHEET-SCREEN-ARRAY SHEET)))
  (DO ((MASTER (CAR RECTANGLE-LIST) (CAR RECTANGLE-LIST))
       (CURRENT-SHEET))
      ((NULL MASTER))
    ;; For all deexposed windows that are of interest, tell them to put their bits up
    ;; (all the sheets are locked by us, so no problem with change of state).  If it's
    ;; an inferior, put up its bits, but if it's the sheet being managed, it means
    ;; there is nothing there.  This is rather misleading; it means there are no
    ;; inferiors there, but not that it is really necessarily blank! See
    ;; comments on SCREEN-MANAGE-MAYBE-BLT-RECTANGLE.
    (SETQ CURRENT-SHEET (CAR (RECT-SOURCE MASTER)))
    (COND ((EQ SHEET CURRENT-SHEET)
	   (SETQ RECTANGLE-LIST
		 (FUNCALL-SELF ':SCREEN-MANAGE-UNCOVERED-AREA
			       RECTANGLE-LIST ARRAY-TO-DRAW-ON X Y ALU)))
	  (T
	   (SETQ RECTANGLE-LIST
		 (FUNCALL CURRENT-SHEET ':SCREEN-MANAGE-RESTORE-AREA
			  RECTANGLE-LIST ARRAY-TO-DRAW-ON X Y ALU))))))

(DEFUN SCREEN-MANAGE-FLUSH-KNOWLEDGE (SHEET)
  (SETF (SHEET-SCREEN-MANAGER-SCREEN-IMAGE SHEET) NIL))

(DEFUN SCREEN-MANAGE-SHEET-RECTANGLES (SHEET BOUND-RECTANGLES
				        &AUX (X-OFF (SHEET-X-OFFSET SHEET))
					     (Y-OFF (SHEET-Y-OFFSET SHEET))
					     (SUPERIOR (SHEET-SUPERIOR SHEET))
				             (LEFT -1) (TOP -1)
					     (RIGHT (1- 1_23.)) (BOTTOM (1- 1_23.))
					     RECTS)
  (COND ((OR (MEMQ SHEET (SHEET-EXPOSED-INFERIORS SUPERIOR))
	     (FUNCALL SHEET ':SCREEN-MANAGE-DEEXPOSED-VISIBILITY))
	 (COND (SUPERIOR
		(SETQ LEFT (SHEET-INSIDE-LEFT SUPERIOR)
		      TOP (SHEET-INSIDE-TOP SUPERIOR)
		      RIGHT (SHEET-INSIDE-RIGHT SUPERIOR)
		      BOTTOM (SHEET-INSIDE-BOTTOM SUPERIOR))))
	 
	 ;; Intersect the rectangles with the bounds of the specified sheet,
	 ;; and return a list of the resulting rectangles.
	 ;; Include in the source description the bit array so we force an update if that
	 ;; changes.
	 (DOLIST (BOUND BOUND-RECTANGLES)
	   (AND (SHEET-OVERLAPS-P SHEET
				  (RECT-LEFT BOUND) (RECT-TOP BOUND)
				  (- (RECT-RIGHT BOUND) (RECT-LEFT BOUND))
				  (- (RECT-BOTTOM BOUND) (RECT-TOP BOUND)))
		(PUSH (LIST (LIST SHEET X-OFF Y-OFF (SHEET-BIT-ARRAY SHEET))
			    (MAX X-OFF (RECT-LEFT BOUND) LEFT)
			    (MAX Y-OFF (RECT-TOP BOUND) TOP)
			    (MIN (+ X-OFF (SHEET-WIDTH SHEET)) (RECT-RIGHT BOUND) RIGHT)
			    (MIN (+ Y-OFF (SHEET-HEIGHT SHEET)) (RECT-BOTTOM BOUND) BOTTOM))
		      RECTS)))
	 RECTS)))

;;; Subroutines used by bit restorers and blank area managers

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SCREEN-MANAGE-MAYBE-BLT-RECTANGLE (R ARRAY X Y ALU)
  "This is a reasonable screen management protocol for blank areas for sheets which
might have bit save arrays and get screen managed, such as LISP-LISTENERS with inferiors."
  (COND (BIT-ARRAY
	 (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT))
	 (BITBLT (OR ALU ALU-SETA)
		 (- (RECT-RIGHT R) (RECT-LEFT R)) (- (RECT-BOTTOM R) (RECT-TOP R))
		 ;; The rectangle is defined to be zero based
		 BIT-ARRAY (RECT-LEFT R) (RECT-TOP R)
		 ARRAY (+ X (RECT-LEFT R)) (+ Y (RECT-TOP R))))
	(T
	 (SCREEN-MANAGE-CLEAR-RECTANGLE R ARRAY X Y ALU)))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SCREEN-MANAGE-CLEAR-AREA (RECTS ARRAY X Y ALU)
  (DOLIST (R RECTS)
    (COND ((EQ SELF (CAR (RECT-SOURCE R)))
           (SCREEN-MANAGE-CLEAR-RECTANGLE R ARRAY X Y ALU)
	   (SETQ RECTS (DELQ R RECTS)))))
  RECTS))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SCREEN-MANAGE-CLEAR-RECTANGLE (R ARRAY X Y ALU)
  (BITBLT (OR ALU ERASE-ALUF)
	  (- (RECT-RIGHT R) (RECT-LEFT R)) (- (RECT-BOTTOM R) (RECT-TOP R))
	  ARRAY (+ X (RECT-LEFT R)) (+ Y (RECT-TOP R))
	  ARRAY (+ X (RECT-LEFT R)) (+ Y (RECT-TOP R)))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN SCREEN-MANAGE-RESTORE-AREA (RECTANGLE-LIST TO-ARRAY X Y ALU &OPTIONAL CLEAR-AREA)
  (COND (BIT-ARRAY
	 (SCREEN-MANAGE-RESTORE-AREA-FROM-BIT-ARRAY RECTANGLE-LIST
						    BIT-ARRAY
						    TO-ARRAY X Y
						    T (OR ALU ALU-SETA)))
	(CLEAR-AREA
	 (SCREEN-MANAGE-CLEAR-AREA RECTANGLE-LIST TO-ARRAY X Y ALU))
	(T
	 ;; If no saved bits, Refresh into a temporary array and use that as the bits
	 (UNWIND-PROTECT
	   (USING-RESOURCE (ARRAY SCREEN-MANAGER-BIT-ARRAY-RESOURCE)
	     (SETQ SCREEN-ARRAY ARRAY)
	     (SI:PAGE-IN-ARRAY ARRAY NIL (LIST WIDTH HEIGHT))
	     (SHEET-FORCE-ACCESS (SELF T)
	       (FUNCALL-SELF ':REFRESH))
	     (SCREEN-MANAGE-RESTORE-AREA-FROM-BIT-ARRAY RECTANGLE-LIST
							ARRAY
							TO-ARRAY X Y
							NIL (OR ALU ALU-SETA)))
	  (SETQ SCREEN-ARRAY NIL))))))

(DEFUN SCREEN-MANAGE-RESTORE-AREA-FROM-BIT-ARRAY (RECTANGLE-LIST ARRAY TO-ARRAY X Y
								 PAGE-FLAG ALU
						  &AUX (FROM (LIST 0 0)) (TO (LIST 0 0)))
  (DOLIST (R RECTANGLE-LIST)
    (COND ((EQ (CAR (RECT-SOURCE R)) SELF)
	   (SETF (CAR FROM) (- (RECT-LEFT R) (CADR (RECT-SOURCE R))))
	   (SETF (CADR FROM) (- (RECT-TOP R) (CADDR (RECT-SOURCE R))))
	   (SETF (CAR TO) (+ (CAR FROM) (- (RECT-RIGHT R) (RECT-LEFT R))))
	   (SETF (CADR TO) (+ (CADR FROM) (- (RECT-BOTTOM R) (RECT-TOP R))))
	   (AND PAGE-FLAG (SI:PAGE-IN-ARRAY ARRAY FROM TO))
	   (BITBLT (OR ALU ALU-SETA)
		   (- (RECT-RIGHT R) (RECT-LEFT R))
		   (- (RECT-BOTTOM R) (RECT-TOP R))
		   ARRAY
		   ;; Take chunk offset to rectangle origin
		   (CAR FROM) (CADR FROM)
		   TO-ARRAY (+ X (RECT-LEFT R)) (+ Y (RECT-TOP R)))
	   (SETQ RECTANGLE-LIST (DELQ R RECTANGLE-LIST)))))
  (SI:PAGE-OUT-ARRAY ARRAY)
  RECTANGLE-LIST)

;;; Screen manager message handlers and flavors

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

;;; Deexposed sheets are defaultly "visible" -- they will show through if they can
;;; and if their priority allows them to
;;; If you redefine this to return T even if there is no bit-array, the right thing
;;; will happen (the window will be refreshed into a temporary array and the
;;; results of that will show through).
(DEFWRAPPER (SHEET :SCREEN-MANAGE-DEEXPOSED-VISIBILITY) (IGNORE . BODY)
  `(AND (OR (NULL PRIORITY) ( PRIORITY 0))
	(PROGN . ,BODY)))

(DEFMETHOD (SHEET :SCREEN-MANAGE-DEEXPOSED-VISIBILITY) ()
  (NOT (NULL BIT-ARRAY)))

(DEFMETHOD (SHEET :SCREEN-MANAGE) (&REST ARGS)
  "This performs screen management on a sheet.  This always works, even if screen management
is inhibited.  It will also do autoexposure on the sheet, unless screen management is
inhibited.  This allows you to batch a series of screen manages without running autoexposure
each time.  It is expected that autoexposure gets run explicitly in this case."
  (FUNCALL-SELF ':ORDER-INFERIORS)
  (FUNCALL-SELF ':SCREEN-MANAGE-AUTOEXPOSE-INFERIORS)
  (LEXPR-FUNCALL #'SCREEN-MANAGE-SHEET SELF ARGS))

;;; Note: Rectangles given to :SCREEN-MANAGE-UNCOVERED-AREA are 0 origin and
;;;       point into SELF.  This is guaranteed, and need not be checked for.
(DEFMETHOD (SHEET :SCREEN-MANAGE-UNCOVERED-AREA) (RECTS ARRAY X Y ALU)
  ARRAY X Y ALU					;Unused
  (DOLIST (R RECTS)
    (AND (EQ (CAR (RECT-SOURCE R)) SELF)
	 (SETQ RECTS (DELQ R RECTS))))
  RECTS)

(DEFMETHOD (SCREEN :SCREEN-MANAGE-UNCOVERED-AREA) SCREEN-MANAGE-CLEAR-UNCOVERED-AREA)
(DEFUN SCREEN-MANAGE-CLEAR-UNCOVERED-AREA (IGNORE RECTS ARRAY X Y ALU)
  "Default is to clear area.  This can be redefined if that isn't desireable."
  (DOLIST (R RECTS)
    (COND ((EQ (CAR (RECT-SOURCE R)) SELF)
	   (SCREEN-MANAGE-CLEAR-RECTANGLE R ARRAY X Y ALU)
	   (SETQ RECTS (DELQ R RECTS)))))
  RECTS)

(DEFMETHOD (SHEET :SCREEN-MANAGE-RESTORE-AREA) (RECTS ARRAY X Y ALU)
  "Default way to restore bits.
If there is a bit array, restore from there.  If there is no bit array, simply
clear the area, unless :SCREEN-MANAGE-DEEXPOSED-VISIBILITY returns T in which
case refresh the bits into a temporary array and restore from that"
  (SCREEN-MANAGE-RESTORE-AREA RECTS ARRAY X Y ALU
			      (NOT (FUNCALL-SELF ':SCREEN-MANAGE-DEEXPOSED-VISIBILITY))))


(DEFFLAVOR NO-SCREEN-MANAGING-MIXIN () ())

(DEFMETHOD (NO-SCREEN-MANAGING-MIXIN :SCREEN-MANAGE) (&REST IGNORE) NIL)
(DEFMETHOD (NO-SCREEN-MANAGING-MIXIN :SCREEN-MANAGE-UNCOVERED-AREA) (&REST IGNORE) NIL)

(DEFFLAVOR SHOW-PARTIALLY-VISIBLE-MIXIN () ())

(DEFMETHOD (SHOW-PARTIALLY-VISIBLE-MIXIN :SCREEN-MANAGE-DEEXPOSED-VISIBILITY) () T)

;;; Graying stuff

;;; This function creates a gray pattern with a horizontal period of
;;; up to 8 bits.  The rest args are the successive rows of pattern.
;;; The pattern arguments are in "octal binary".

(DEFUN MAKE-GRAY (HEIGHT WIDTH &REST PATTERNS &AUX GRAY RWIDTH PAT)
  (CHECK-ARG HEIGHT (= HEIGHT (LENGTH PATTERNS)) "equal to number of patterns")
  (CHECK-ARG WIDTH (< WIDTH 32.) "less than or equal to 31")
  (DO L PATTERNS (CDR L) (NULL L)			;CONVERT OCTAL BINARY TO BINARY
    (RPLACA L (DO ((W (CAR L) (LSH W -3))
		   (M 1 (LSH M 1))
		   (R 0))
		  ((ZEROP W) R)
		(AND (BIT-TEST 1 W) (SETQ R (LOGIOR R M))))))
  (DOTIMES (I WIDTH)
    (AND (ZEROP (\ (* 32. (1+ I)) WIDTH))
	 (RETURN (SETQ RWIDTH (* 32. (1+ I))))))
  (SETQ GRAY (MAKE-ARRAY NIL 'ART-1B (LIST RWIDTH HEIGHT)))
  (DOTIMES (H HEIGHT)
    (SETQ PAT (NTH H PATTERNS))
    (DOTIMES (W RWIDTH)
      (ASET (LSH PAT (- (1+ (\ W WIDTH)) WIDTH)) GRAY W H)))
  GRAY)

;;; Some common grays
(DEFVAR 50%-GRAY (MAKE-GRAY 2 2 01 10))
(DEFVAR 25%-GRAY (MAKE-GRAY 4 4 1000 0010 0100 0001))
(DEFVAR 75%-GRAY (MAKE-GRAY 4 4 0111 1101 1011 1110))
(DEFVAR 33%-GRAY (MAKE-GRAY 3 3 100 010 001))
(DEFVAR HES-GRAY (MAKE-GRAY 4 4 1000 0000 0010 0000))

(DEFFLAVOR GRAY-DEEXPOSED-WRONG-MIXIN ((GRAY-ARRAY HES-GRAY)) ()
  :GETTABLE-INSTANCE-VARIABLES
  :SETTABLE-INSTANCE-VARIABLES
  :INITABLE-INSTANCE-VARIABLES
  (:INCLUDED-FLAVORS SHEET)
  (:DOCUMENTATION :MIXIN "Grayed over when deexposed"))

(DEFWRAPPER (GRAY-DEEXPOSED-WRONG-MIXIN :SCREEN-MANAGE-RESTORE-AREA)
	        ((RECTS ARRAY X Y ALU) . BODY)
  `(LET ((SI:.DAEMON-CALLER-ARGS. (LIST NIL RECTS ARRAY X Y (OR ALU CHAR-ALUF))))
     (DOLIST (R RECTS)
       (AND (EQ (CAR (RECT-SOURCE R)) SELF)
	    (SCREEN-MANAGE-GRAY-RECTANGLE R ARRAY X Y ALU-SETA)))
     . ,BODY))

(DEFMETHOD (GRAY-DEEXPOSED-WRONG-MIXIN :SCREEN-MANAGE-UNCOVERED-AREA) (RECTS ARRAY X Y IGNORE)
  (DOLIST (R RECTS)
    (COND ((EQ (CAR (RECT-SOURCE R)) SELF)
	   (SCREEN-MANAGE-GRAY-RECTANGLE R ARRAY X Y ALU-SETA)
	   (SETQ RECTS (DELQ R RECTS)))))
  RECTS)

;;; This flavor causes the deexposed window to be grayed over.  It works for windows
;;; which have inferiors, as well as those which do not.
(DEFFLAVOR GRAY-DEEXPOSED-RIGHT-MIXIN ((GRAY-ARRAY HES-GRAY)) ()
  :GETTABLE-INSTANCE-VARIABLES
  :SETTABLE-INSTANCE-VARIABLES
  :INITABLE-INSTANCE-VARIABLES
  (:INCLUDED-FLAVORS SHEET)
  (:DOCUMENTATION :MIXIN "Grayed over when deexposed"))

(DEFMETHOD (GRAY-DEEXPOSED-RIGHT-MIXIN :SCREEN-MANAGE-UNCOVERED-AREA) (RECTS ARRAY X Y IGNORE)
  (DOLIST (R RECTS)
    (COND ((EQ (CAR (RECT-SOURCE R)) SELF)
	   (SCREEN-MANAGE-GRAY-RECTANGLE R ARRAY X Y ALU-SETA)
	   (SETQ RECTS (DELQ R RECTS)))))
  RECTS)

(DEFWRAPPER (GRAY-DEEXPOSED-RIGHT-MIXIN :SCREEN-MANAGE-RESTORE-AREA)
	        ((RECTS ARRAY X Y ALU) . BODY)
  `(USING-RESOURCE (KLUDGE-ARRAY SCREEN-MANAGER-BIT-ARRAY-RESOURCE)
     (SI:PAGE-IN-ARRAY KLUDGE-ARRAY NIL (LIST WIDTH HEIGHT))
     ;; This is a kludge -- fudge the arguments to all methods inside
     (LET ((SI:.DAEMON-CALLER-ARGS. (LIST NIL (COPYLIST RECTS) KLUDGE-ARRAY
					  (- X-OFFSET) (- Y-OFFSET) ALU)))
       . ,BODY)
     (GRAY-DEEXPOSED-RIGHT-RESTORE-INTERNAL RECTS KLUDGE-ARRAY ARRAY X Y ALU)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAY-DEEXPOSED-RIGHT-MIXIN)
(DEFUN GRAY-DEEXPOSED-RIGHT-RESTORE-INTERNAL (RECTS KLUDGE-ARRAY ARRAY X Y ALU)
  "This is an internal function for the wrapper of the grayer.  It grays the
window in the internal bit array, and then causes the appropriate rectangles
to be blted onto the screen."
  (SCREEN-MANAGE-GRAY-RECTANGLE `((,SELF 0 0) 0 0 ,WIDTH ,HEIGHT)
				KLUDGE-ARRAY 0 0 CHAR-ALUF)
  (SCREEN-MANAGE-RESTORE-AREA-FROM-BIT-ARRAY RECTS KLUDGE-ARRAY ARRAY X Y NIL
					     (OR ALU ALU-SETA))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAY-DEEXPOSED-RIGHT-MIXIN)
(DEFUN SCREEN-MANAGE-GRAY-RECTANGLE (RECT ARRAY X Y ALU)
  "Gray the specified rectangle on the specified array.  All graying is relative
to (0, 0) on the sheet that the rectangle is on."
  (LET ((X-OFF (- (RECT-LEFT RECT) (SECOND (RECT-SOURCE RECT))))
	(Y-OFF (- (RECT-TOP RECT) (THIRD (RECT-SOURCE RECT)))))
    (BITBLT (OR ALU CHAR-ALUF)
	    (- (RECT-RIGHT RECT) (RECT-LEFT RECT)) (- (RECT-BOTTOM RECT) (RECT-TOP RECT))
	    GRAY-ARRAY (\ X-OFF (ARRAY-DIMENSION-N 1 GRAY-ARRAY))
	    	       (\ Y-OFF (ARRAY-DIMENSION-N 2 GRAY-ARRAY))
	    ARRAY (+ X (RECT-LEFT RECT)) (+ Y (RECT-TOP RECT))))))

;;; Interfaces to the other software
(DEFVAR SCREEN-MANAGE-TRACE-OUTPUT NIL)

(DEFUN SCREEN-ACTIVITY-HAS-CHANGED (WINDOW ON-P)
  ON-P						;Isn't very interesting
  (AND SCREEN-MANAGE-TRACE-OUTPUT
       (FORMAT SCREEN-MANAGE-TRACE-OUTPUT
	       "~&Activity change: window ~S, ~:[Deactivate~;Activate~]~%"
	       WINDOW ON-P))
  (COND ((FUNCALL WINDOW ':SCREEN-MANAGE-DEEXPOSED-VISIBILITY)
	 ;; If window is visible when deexposed, then screen management is useful
	 (SCREEN-MANAGE-WINDOW-AREA WINDOW))
	(T (SCREEN-MANAGE-FLUSH-KNOWLEDGE WINDOW))))

(DEFUN SCREEN-CONFIGURATION-HAS-CHANGED (WINDOW &OPTIONAL (WHY ':FORCE)
						&AUX DO-IT (SUP (SHEET-SUPERIOR WINDOW)))
  
  (COND ((MEMQ WINDOW (SHEET-INFERIORS SUP))
	 ;; Only consider active windows
	 (SELECTQ WHY
	   (:EXPOSE
	    ;; Just exposed a window, don't need to hack it's area any (except that one can
	    ;; optimize by removing all areas from consideration for screen management
	    ;; that it subsumes)
	    (LET ((RECT (LIST NIL (SHEET-X-OFFSET WINDOW) (SHEET-Y-OFFSET WINDOW)
			          (+ (SHEET-X-OFFSET WINDOW) (SHEET-WIDTH WINDOW))
				  (+ (SHEET-Y-OFFSET WINDOW) (SHEET-HEIGHT WINDOW)))))
	      (WITHOUT-INTERRUPTS
	        (DOLIST (QE SCREEN-MANAGER-QUEUE)
		  (AND (EQ (CAR (RECT-SOURCE QE)) SUP)
		       (RECT-WITHIN-RECT-P QE RECT)
		       (SETQ SCREEN-MANAGER-QUEUE (DELQ QE SCREEN-MANAGER-QUEUE)))))))
	   ((:DEEXPOSE :FORCE)
	    ;; Deexposing, things may have changed underneath it, so screen manage even
	    ;; if it is temporary
	    (SETQ DO-IT T)))
	 (AND SUP (FUNCALL SUP ':ORDER-INFERIORS))
	 (AND SCREEN-MANAGE-TRACE-OUTPUT
	      (FORMAT SCREEN-MANAGE-TRACE-OUTPUT
		      "~&Configuration change: window ~S, reason ~A~%"
		      WINDOW WHY))		      
	 (COND (DO-IT
		(SCREEN-MANAGE-WINDOW-AREA WINDOW))
	       (T (SCREEN-MANAGE-FLUSH-KNOWLEDGE SUP))))))

(DEFUN SCREEN-AREA-HAS-CHANGED (WINDOW &REST RECT
				       &AUX (SUP (SHEET-SUPERIOR WINDOW)))
  (COND ((MEMQ WINDOW (SHEET-INFERIORS SUP))
	 (AND SUP (FUNCALL SUP ':ORDER-INFERIORS))
	 (COND ((OR (AND RECT (SHEET-EXPOSED-P WINDOW))	;Explicit rectangle, and exposed
		    (FUNCALL WINDOW ':SCREEN-MANAGE-DEEXPOSED-VISIBILITY))
		(AND SCREEN-MANAGE-TRACE-OUTPUT
		     (FORMAT SCREEN-MANAGE-TRACE-OUTPUT
			     "~&Area change: window ~S~%"
			     WINDOW))
		(LEXPR-FUNCALL #'SCREEN-MANAGE-WINDOW-AREA WINDOW RECT))))))

(DEFUN SCREEN-MANAGE-WINDOW-AREA (WINDOW
				  &OPTIONAL (LEFT (SHEET-X-OFFSET WINDOW))
				  	    (TOP (SHEET-Y-OFFSET WINDOW))
					    (RIGHT (+ (SHEET-X-OFFSET WINDOW)
						      (SHEET-WIDTH WINDOW)))
					    (BOTTOM (+ (SHEET-Y-OFFSET WINDOW)
						       (SHEET-HEIGHT WINDOW)))
				  &AUX (SUP (SHEET-SUPERIOR WINDOW)))
  (AND SUP (SCREEN-MANAGE-QUEUE SUP LEFT TOP RIGHT BOTTOM)))

(DEFUN SCREEN-MANAGE-QUEUE (SHEET &OPTIONAL LEFT TOP RIGHT BOTTOM
				  &AUX E (INHIBIT-SCHEDULING-FLAG T))
  (SETQ E (IF (LISTP SHEET)
	      SHEET
	      (LIST (LIST SHEET 0 0) LEFT TOP RIGHT BOTTOM)))
  ;; Add to queue, eliminating redundant entries
  (COND ((DOLIST (QE SCREEN-MANAGER-QUEUE)
	   (COND ((EQ (CAR (RECT-SOURCE E)) (CAR (RECT-SOURCE QE)))
		  (AND (RECT-WITHIN-RECT-P E QE)
		       (RETURN T))
		  (AND (RECT-WITHIN-RECT-P QE E)
		       (SETQ SCREEN-MANAGER-QUEUE (DELQ QE SCREEN-MANAGER-QUEUE)))))))
	(T
	 (AND SCREEN-MANAGE-TRACE-OUTPUT
	      (FORMAT SCREEN-MANAGE-TRACE-OUTPUT
		      "~&Queueing rectangle ~S, inhibit ~A~%"
		      E INHIBIT-SCREEN-MANAGEMENT))
	 (PUSH E SCREEN-MANAGER-QUEUE)
	 ;; Do right away if possible, otherwise leave on queue
	 (OR INHIBIT-SCREEN-MANAGEMENT
	     (SCREEN-MANAGE-DEQUEUE-ENTRY E)))))

(DEFUN SCREEN-MANAGE-DELAYING-SCREEN-MANAGEMENT-INTERNAL (;&OPTIONAL OLD-STYLE
							  &AUX (INHIBIT-SCHEDULING-FLAG T))
  "Called if stuff got queued during a DELAYING-SCREEN-MANAGEMENT.
If now at top level dequeue them all, but never wait for a lock."
  (OR INHIBIT-SCREEN-MANAGEMENT
      ;; Only try to dequeue if not delaying anymore
      (SCREEN-MANAGE-DEQUEUE)))

(DEFUN SCREEN-MANAGE-DEQUEUE (&AUX (INHIBIT-SCHEDULING-FLAG T))
  (DO ((Q SCREEN-MANAGER-QUEUE))
      ((NULL Q))
    (IF (SCREEN-MANAGE-DEQUEUE-ENTRY (CAR Q))
	;; If the entry actually got dequeued, then interrupts were allowed and so the
	;; queue might have gotten hacked.  Restart from the beginning.
	(SETQ Q SCREEN-MANAGER-QUEUE)
	(SETQ Q (CDR Q)))))

;The difference from the above is that this one will wait for a lock, rather than punting
(DEFUN SCREEN-MANAGE-DEQUEUE-DELAYED-ENTRIES (&AUX (INHIBIT-SCHEDULING-FLAG T))
  (DO ((Q SCREEN-MANAGER-QUEUE SCREEN-MANAGER-QUEUE))
      ((NULL Q))
    (SCREEN-MANAGE-DEQUEUE-ENTRY (CAR Q) T)))	;This reenables scheduling if it does anything

(DEFUN SCREEN-MANAGE-DEQUEUE-ENTRY (ENTRY &OPTIONAL UNCOND &AUX ALL)
  "Handle one entry from the screen manager's queue.  Interrupts must be bound and inhibit.
Though it may turn off INHIBIT-SCHEDULING-FLAG, this routine will always return with
it turned back on.  The code returns T if it actually dequeued the entry, else NIL."
  (COND ((OR UNCOND (SHEET-CAN-GET-LOCK (CAR (RECT-SOURCE ENTRY))))
	 ;; May as well do all rectangles on this sheet together.  ALL gets a list of them.
	 (SETQ SCREEN-MANAGER-QUEUE (DELQ ENTRY SCREEN-MANAGER-QUEUE)
	       ALL (NCONS ENTRY))
	 (DOLIST (E SCREEN-MANAGER-QUEUE)
	   (COND ((EQ (CAR (RECT-SOURCE ENTRY)) (CAR (RECT-SOURCE E)))
		  (SETQ SCREEN-MANAGER-QUEUE (DELQ E SCREEN-MANAGER-QUEUE))
		  (PUSH E ALL))))
	 (AND SCREEN-MANAGE-TRACE-OUTPUT
	      (FORMAT SCREEN-MANAGE-TRACE-OUTPUT
		      "~&Dequeueing ~S~%Queue is ~S~%" ALL SCREEN-MANAGER-QUEUE))

	 (LET ((SHEET (CAR (RECT-SOURCE ENTRY))))
	   (IF (SHEET-SCREEN-ARRAY SHEET)
	       ;; FORCE-ACCESS so that PREPARE-SHEET won't look at the output-hold flag.
	       (SHEET-FORCE-ACCESS (SHEET :NO-PREPARE)
	         (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		 (FUNCALL (CAR (RECT-SOURCE ENTRY)) ':SCREEN-MANAGE ALL))
	       ;; If can't screen manage (no screen!), then just do autoexposure
	       (LOCK-SHEET (SHEET)
	         (SETQ INHIBIT-SCHEDULING-FLAG NIL)
		 (FUNCALL SHEET ':ORDER-INFERIORS)
		 (FUNCALL SHEET ':SCREEN-MANAGE-AUTOEXPOSE-INFERIORS)))
	   (SETQ INHIBIT-SCHEDULING-FLAG T)
	   T))
	(T NIL)))

;;; Note that this message does not mean automatically expose this sheet.
;;; It means consider the inferiors of this sheet for automatic exposing.
(DEFMETHOD (SHEET :SCREEN-MANAGE-AUTOEXPOSE-INFERIORS) ()
  (SCREEN-MANAGE-AUTOEXPOSE-INFERIORS SELF))

(DEFUN SCREEN-MANAGE-AUTOEXPOSE-INFERIORS (SHEET &AUX INTERESTING-INFERIORS)
  "Expose all sheets that are uncovered but not exposed.  No need to do any screen management,
since exposure always does the right thing, and this can never cause a sheet to become
deexposed.  Should be called with the sheet locked."
  ;; First, get an ordered list of all sheets of interest
  ;; SHEET-INFERIORS has been ordered by priority.
  (LOCK-SHEET (SHEET)
    (DOLIST (I (SHEET-INFERIORS SHEET))
      (OR (MEMQ I (SHEET-EXPOSED-INFERIORS SHEET))
;	  (NOT (FUNCALL I ':SCREEN-MANAGE-DEEXPOSED-VISIBILITY))
	  (NOT (SHEET-WITHIN-SHEET-P I SHEET))
	  ( (OR (SHEET-PRIORITY I) 0) -1)
	  (PUSH I INTERESTING-INFERIORS)))
    (SETQ INTERESTING-INFERIORS (NREVERSE INTERESTING-INFERIORS))
    (AND SCREEN-MANAGE-TRACE-OUTPUT
	 (FORMAT SCREEN-MANAGE-TRACE-OUTPUT
		 "~&Autoexpose-inferiors: ~S~%" INTERESTING-INFERIORS))
    ;; Now, we have a list of interesting: deexposed and active
    ;; Expose them one by one if they aren't covered.
    (DOLIST (I INTERESTING-INFERIORS)
      (COND ((DOLIST (EI (SHEET-EXPOSED-INFERIORS SHEET))
	       (AND (SHEET-OVERLAPS-SHEET-P EI I)
		    (RETURN T))))		;This clause if covered: do nothing
	    ;; Don't expose if it would cover anything earlier in the list.  What this
	    ;; does is prevent violations of priority; something earlier in the list
	    ;; might not be exposed because some other part of it was covered.
	    ((DOLIST (HP INTERESTING-INFERIORS)
	       (AND (EQ I HP)
		    (RETURN T))
	       (AND (FUNCALL HP ':SCREEN-MANAGE-DEEXPOSED-VISIBILITY)
		    (SHEET-OVERLAPS-SHEET-P I HP)
		    (RETURN NIL)))
	     (FUNCALL I ':EXPOSE)
	     (SETQ INTERESTING-INFERIORS (DELQ I INTERESTING-INFERIORS)))))
    (AND (EQ SHEET MOUSE-SHEET)
	 (NULL SELECTED-WINDOW)
	 (SETQ INTERESTING-INFERIORS (SHEET-EXPOSED-INFERIORS SHEET))
	 ;; If hacking the sheet the mouse is on, and there is no window currently selected,
	 ;; select a window
	 (DOLIST (I INTERESTING-INFERIORS)
	   (AND (FUNCALL I ':NAME-FOR-SELECTION)
		(RETURN (FUNCALL I ':SELECT)))))))

;;; Screen manager's background process

;;; The background process is responsible for trying to handle the pending queue of
;;; screen manages, as well as updating windows which are in :PERMIT mode, deexposed,
;;; and have actually done typeout since we were last here

(DEFVAR SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS NIL)	;NIL not to do it, or time to sleep
(DEFVAR SCREEN-MANAGE-TIME-BETWEEN-DEQUEUES 10.)	;Check queue every 1/6 second
							;while it is non-empty (i.e. try
							;again to get locks this often)

(DEFUN SCREEN-MANAGE-BACKGROUND-TOP-LEVEL ()
  (DO ((HEAD-OF-QUEUE SCREEN-MANAGER-QUEUE SCREEN-MANAGER-QUEUE)
       (SLEEP-TIME))
      (())
    (SETQ SLEEP-TIME (COND (SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS
			     (COND ((NULL HEAD-OF-QUEUE)
				    SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS)
				   (T (MIN SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS
					   SCREEN-MANAGE-TIME-BETWEEN-DEQUEUES))))
			   (INHIBIT-SCREEN-MANAGEMENT NIL)
			   ((NULL HEAD-OF-QUEUE) NIL)
			   (T SCREEN-MANAGE-TIME-BETWEEN-DEQUEUES)))
    ;; Wait until queue has changed, and screen management not inhibited
    ;; Except SLEEP-TIME if non-null is a timeout
    (PROCESS-WAIT "Screen Manage"
		  #'(LAMBDA (SLEEP-TIME LAST-TIME HEAD-OF-QUEUE)
		      (OR (AND SLEEP-TIME
			       (> (TIME-DIFFERENCE (TIME) LAST-TIME) SLEEP-TIME))
			  (AND (NULL SLEEP-TIME) SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS)
			  (AND (NOT INHIBIT-SCREEN-MANAGEMENT)
			       (NEQ SCREEN-MANAGER-QUEUE HEAD-OF-QUEUE))))
		  SLEEP-TIME (TIME) HEAD-OF-QUEUE)
    (OR INHIBIT-SCREEN-MANAGEMENT (SCREEN-MANAGE-DEQUEUE))
    (AND SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS
	 (WITHOUT-INTERRUPTS
	   (DOLIST (S ALL-THE-SCREENS)
	     (AND (SHEET-EXPOSED-P S)
		  (SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS S)))))))

(DEFUN SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS (SHEET &AUX (EXPSD-INFS
							    (SHEET-EXPOSED-INFERIORS SHEET)))
  (DOLIST (I (SHEET-INFERIORS SHEET))
    (SCREEN-MANAGE-UPDATE-PERMITTED-WINDOWS I)
    (COND ((AND (NOT (MEMQ I EXPSD-INFS))
		( (OR (SHEET-PRIORITY I) 0) 0)
		(EQ (SHEET-DEEXPOSED-TYPEOUT-ACTION I) ':PERMIT)
		(ZEROP (SHEET-OUTPUT-HOLD-FLAG I)))
	   ;; Sheet is permitted, deexposed, and has been typed on.  Update it on screen.
	   (SETF (SHEET-OUTPUT-HOLD-FLAG I) 1)
	   (SCREEN-CONFIGURATION-HAS-CHANGED I)))))

(DEFVAR SCREEN-MANAGER-BACKGROUND-PROCESS
	(PROCESS-RUN-RESTARTABLE-FUNCTION "Screen Manager Background"
					  'SCREEN-MANAGE-BACKGROUND-TOP-LEVEL))