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

;;; Superior that supports its inferiors as panes -- windows which are managed
;;; by the superior in some way

;;; Each window that is a pane (an inferior of a frame), should include
;;; the PANE-MIXIN flavor so as to interact correctly
(DEFFLAVOR PANE-MIXIN () ()
  (:INCLUDED-FLAVORS ESSENTIAL-WINDOW)
  (:DOCUMENTATION :MIXIN "Included in windows that are to be inferiors of a frame"))

(DEFFLAVOR PANE-NO-MOUSE-SELECT-MIXIN () (PANE-MIXIN DONT-SELECT-WITH-MOUSE-MIXIN))

(DEFWRAPPER (PANE-MIXIN :EXPOSE) (IGNORE . BODY)
  "Notify the superior before the :EXPOSE is done.  A value of NIL returned
means to punt the expose."
  `(AND (FUNCALL SUPERIOR ':INFERIOR-EXPOSE SELF)
	(PROGN . ,BODY)))

(DEFWRAPPER (PANE-MIXIN :DEEXPOSE) (IGNORE . BODY)
  "Notify the superior about :DEEXPOSE."
  `(AND (FUNCALL SUPERIOR ':INFERIOR-DEEXPOSE SELF)
	(PROGN . ,BODY)))

(DEFWRAPPER (PANE-MIXIN :BURY) (IGNORE . BODY)
  "Notify the superior about :BURY."
  `(AND (FUNCALL SUPERIOR ':INFERIOR-BURY SELF)
	(PROGN . ,BODY)))

(DEFWRAPPER (PANE-MIXIN :SET-EDGES) ((NL NT NR NB OPTION) . BODY)
  `(LET ((LIST (MULTIPLE-VALUE-LIST
		(FUNCALL SUPERIOR ':INFERIOR-SET-EDGES SELF NL NT NR NB OPTION))))
     (IF (NOT (CAR LIST))
	 (PROG () (RETURN-LIST (CDR LIST)))
	 . ,BODY)))

(DEFWRAPPER (PANE-MIXIN :SELECT) (IGNORE . BODY)
  `(AND (FUNCALL SUPERIOR ':INFERIOR-SELECT SELF)
	;; Not all of the flavors we are combined with can be selected -- this prevents
	;; a gratuitous error from the compiler
	(PROGN SI:.DAEMON-CALLER-ARGS. . ,BODY)))

(DEFMETHOD (PANE-MIXIN :MOUSE-SELECT) (&REST ARGS)
  "When selecting a pane with the mouse, pass the selection request to the frame."
  (LEXPR-FUNCALL SUPERIOR ':MOUSE-SELECT ARGS))

(DEFMETHOD (PANE-MIXIN :ALIAS-FOR-SELECTED-WINDOWS) ()
  (FUNCALL SUPERIOR ':ALIAS-FOR-SELECTED-WINDOWS))

(DEFMETHOD (PANE-MIXIN :SQUARE-PANE-SIZE) (MAX-WIDTH MAX-HEIGHT IGNORE IGNORE STACKING)
  (SELECTQ STACKING
    (:VERTICAL MAX-WIDTH)
    (:HORIZONTAL MAX-HEIGHT)))

(DEFMETHOD (PANE-MIXIN :SQUARE-PANE-INSIDE-SIZE) (MAX-WIDTH MAX-HEIGHT IGNORE IGNORE STACKING)
  (SELECTQ STACKING
    (:VERTICAL
     (+ TOP-MARGIN-SIZE (- MAX-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE) BOTTOM-MARGIN-SIZE))
    (:HORIZONTAL
     (+ LEFT-MARGIN-SIZE (- MAX-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE) RIGHT-MARGIN-SIZE))
    ))

(DEFFLAVOR WINDOW-PANE () (PANE-MIXIN WINDOW)
  (:DOCUMENTATION :COMBINATION "Plain window within a frame"))

(DEFFLAVOR LISP-LISTENER-PANE () (PANE-MIXIN LISP-LISTENER)
  (:DOCUMENTATION :COMBINATION "Lisp listener within a frame"))

(DEFFLAVOR COMMAND-MENU-PANE () (PANE-MIXIN COMMAND-MENU)
  (:DOCUMENTATION :COMBINATION "Command menu within a frame"))

;;; Basic frame contains methods that are used by most frames
;;; Recursion variable keeps track of whether or not we are performing an operation
;;;  that will cause us to get notified.  If RECURSION is set, the routine
;;;  should ignore the notification and return immediatly a value of T.  This
;;;  will be the standard.
(DEFFLAVOR BASIC-FRAME ((SELECTED-PANE NIL) (RECURSION NIL))
  (ESSENTIAL-EXPOSE ESSENTIAL-ACTIVATE ESSENTIAL-SET-EDGES POP-UP-NOTIFICATION-MIXIN
   ESSENTIAL-WINDOW)
  (:REQUIRED-METHODS :INFERIOR-SET-EDGES)
  (:GETTABLE-INSTANCE-VARIABLES SELECTED-PANE)
  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :MORE-P NIL)
  (:DOCUMENTATION :LOWLEVEL-MIXIN "Pane handling messages used by most frames"))

;This sets what pane should be selected if this window is selected.
;The computation of whether this window is currently selected is not
;completely reliable (does not work for nested frames).  This could be fixed
;by changing the way the system does selection. *******
(DEFMETHOD (BASIC-FRAME :SELECT-PANE) (PANE)
  (OR (MEMQ PANE EXPOSED-INFERIORS)
      (NULL PANE)
      (FERROR NIL "Cannot select ~S, which is not a pane of ~S" PANE SELF))
  (LET ((SELECT-P (AND PANE SELECTED-WINDOW
		       (EQ (FUNCALL SELECTED-WINDOW ':ALIAS-FOR-SELECTED-WINDOWS)
			   (FUNCALL PANE ':ALIAS-FOR-SELECTED-WINDOWS)))))
    ;; Deselect the previous selected pane, since it will no longer receive
    ;; a deselect message from this frame
    (DELAYING-SCREEN-MANAGEMENT
      (AND SELECTED-PANE (NEQ PANE SELECTED-PANE)
	   (FUNCALL SELECTED-PANE ':DESELECT NIL))
      ;; If this frame seems to be selected, select the new selected pane
      (AND SELECT-P (FUNCALL PANE ':SELECT)))
    ;; Remember what pane is selected so select and deselect messages can be forwarded to it
    (SETQ SELECTED-PANE PANE)))

(DEFMETHOD (BASIC-FRAME :SELECT) (&REST ARGS)
  (AND SELECTED-PANE (LEXPR-FUNCALL SELECTED-PANE ':SELECT ARGS)))

(DEFMETHOD (BASIC-FRAME :DESELECT) (&REST ARGS)
  (AND SELECTED-PANE (LEXPR-FUNCALL SELECTED-PANE ':DESELECT ARGS)))

(DEFMETHOD (BASIC-FRAME :NAME-FOR-SELECTION) ()
  (AND SELECTED-PANE (FUNCALL SELECTED-PANE ':NAME-FOR-SELECTION)))

(DEFWRAPPER (BASIC-FRAME :STATUS) (IGNORE . BODY)
  `(COND ((AND SELECTED-PANE (EQ (FUNCALL SELECTED-PANE ':STATUS) ':SELECTED))
	  ':SELECTED)
	 (T . ,BODY)))

(DEFMETHOD (BASIC-FRAME :AFTER :DEACTIVATE) (&REST IGNORE)
  ;; Make sure that none of our inferiors are remembered as selectable
  (DOLIST (I INFERIORS)
    (REMOVE-FROM-PREVIOUSLY-SELECTED-WINDOWS I)))

(DEFMETHOD (BASIC-FRAME :BEFORE :KILL) ()
  (DOLIST (I INFERIORS) (FUNCALL I ':KILL)))

(DEFWRAPPER (BASIC-FRAME :PRINT-NOTIFICATION) (ARGS . BODY)
  `(IF SELECTED-PANE
       (LEXPR-FUNCALL SELECTED-PANE ':PRINT-NOTIFICATION ARGS)
       . ,BODY))

(DEFMETHOD (BASIC-FRAME :ALIAS-FOR-SELECTED-WINDOWS) () SELF)

(DEFMETHOD (BASIC-FRAME :INFERIOR-SELECT) (PANE)
  (SETQ SELECTED-PANE PANE)
  T)

;;; Screen management et. al.
(DEFMETHOD (BASIC-FRAME :SCREEN-MANAGE-RESTORE-AREA) (RECTS ARRAY-TO-DRAW-ON X Y ALU &AUX RS)
  (IF BIT-ARRAY
      (SCREEN-MANAGE-RESTORE-AREA RECTS ARRAY-TO-DRAW-ON X Y ALU T)
      (DOLIST (R RECTS)
	(COND ((EQ (CAR (RECT-SOURCE R)) SELF)
	       (PUSH (LIST (LIST SELF 0 0)
			   (- (RECT-LEFT R) X-OFFSET) (- (RECT-TOP R) Y-OFFSET)
			   (- (RECT-RIGHT R) X-OFFSET) (- (RECT-BOTTOM R) Y-OFFSET))
		     RS)
	       (SETQ RECTS (DELQ R RECTS)))))
      (SCREEN-MANAGE-SHEET SELF RS ARRAY-TO-DRAW-ON (+ X X-OFFSET) (+ Y Y-OFFSET) ALU)
      RECTS))

(DEFWRAPPER (BASIC-FRAME :EXPOSE) (IGNORE . BODY)
  `(LET-GLOBALLY ((RECURSION T))
     . ,BODY))

(DEFWRAPPER (BASIC-FRAME :DEEXPOSE) (IGNORE . BODY)
  `(LET-GLOBALLY ((RECURSION T))
     . ,BODY))

(DEFMETHOD (BASIC-FRAME :SCREEN-MANAGE-DEEXPOSED-VISIBILITY) () T)

(DEFMETHOD (BASIC-FRAME :SCREEN-MANAGE-UNCOVERED-AREA) SCREEN-MANAGE-CLEAR-UNCOVERED-AREA)


(DEFFLAVOR FRAME-FORWARDING-MIXIN () ()
  (:INCLUDED-FLAVORS BASIC-FRAME)
  (:DOCUMENTATION :MIXIN "Used when forwarding of EXPOSE/DEEXPOSE/BURY messages from pane
to frame is desired."))

(DEFMETHOD (FRAME-FORWARDING-MIXIN :INFERIOR-EXPOSE) (PANE)
  PANE
  (COND (RECURSION T)
	(T (FUNCALL-SELF ':EXPOSE)
	   NIL)))

(DEFMETHOD (FRAME-FORWARDING-MIXIN :INFERIOR-DEEXPOSE) (PANE)
  PANE
  (COND (RECURSION T)
	(T (FUNCALL-SELF ':DEEXPOSE)
	   NIL)))

(DEFMETHOD (FRAME-FORWARDING-MIXIN :INFERIOR-BURY) (PANE)
  PANE
  (COND (RECURSION T)
	(T (FUNCALL-SELF ':BURY)
	   NIL)))

(DEFWRAPPER (FRAME-FORWARDING-MIXIN :SCREEN-MANAGE-AUTOEXPOSE-INFERIORS) (IGNORE . BODY)
  `(LET-GLOBALLY ((RECURSION T))
     . ,BODY))

(DEFMETHOD (BASIC-FRAME :PANE-TYPES-ALIST) ()
  NIL)

;;; Simple superior for split-screen
(DEFFLAVOR SPLIT-SCREEN-FRAME () (BASIC-FRAME))

(DEFMETHOD (SPLIT-SCREEN-FRAME :PANE-TYPES-ALIST) ()
  DEFAULT-WINDOW-TYPES-ITEM-LIST)

;;; Constraint frames -- these frames maintain their panes based on a set
;;;  of constraints.  These frames are the right thing for most frame applications.
(DEFFLAVOR BASIC-CONSTRAINT-FRAME (PANES INTERNAL-PANES SELECTED-PANE
				   (EXPOSED-PANES NIL)
				   CONSTRAINTS PARSED-CONSTRAINTS INTERNAL-CONSTRAINTS
				   (SUBSTITUTIONS NIL)
				   (BLANK-RECTANGLES NIL)
				   (CONFIGURATION NIL))
	   (BASIC-FRAME)
  (:INITABLE-INSTANCE-VARIABLES CONSTRAINTS PANES SUBSTITUTIONS SELECTED-PANE CONFIGURATION)
  (:GETTABLE-INSTANCE-VARIABLES CONSTRAINTS PANES CONFIGURATION)
  (:SETTABLE-INSTANCE-VARIABLES EXPOSED-PANES)
  (:DOCUMENTATION :LOWLEVEL-MIXIN "Maintains panes according to specified constraints"))


(DEFFLAVOR CONSTRAINT-FRAME-FORWARDING-MIXIN () (FRAME-FORWARDING-MIXIN))

(DEFMETHOD (CONSTRAINT-FRAME-FORWARDING-MIXIN :INFERIOR-SET-EDGES) (PANE &REST ARGS)
  (COND (RECURSION T)
	(T (LET-GLOBALLY ((RECURSION T))
	     (LEXPR-FUNCALL PANE ':SET-EDGES ARGS)))))


(DEFFLAVOR CONSTRAINT-FRAME-NO-FORWARDING () (BASIC-CONSTRAINT-FRAME BASIC-FRAME)
  (:DOCUMENTATION :COMBINATION "Constraint frame, but with no special handling of FORWARDed
messages such as :EXPOSE."))

(DEFFLAVOR CONSTRAINT-FRAME ()
	   (BASIC-CONSTRAINT-FRAME CONSTRAINT-FRAME-FORWARDING-MIXIN BASIC-FRAME)
  (:DOCUMENTATION :MIXIN "Normal constraint frame"))

(DEFFLAVOR BORDERED-CONSTRAINT-FRAME ()
	   (BASIC-CONSTRAINT-FRAME CONSTRAINT-FRAME-FORWARDING-MIXIN BORDERS-MIXIN BASIC-FRAME)
  (:DEFAULT-INIT-PLIST :BORDER-MARGIN-WIDTH 0)
  (:DOCUMENTATION :COMBINATION "Maintains uniform borders around panes"))


(DEFSTRUCT (CONSTRAINT-NODE :ARRAY)
  CONSTRAINT-NAME			;Name of this node
  (CONSTRAINT-MIN -1)			;Minimum limit
  (CONSTRAINT-MAX 1_20.)		;Maximum limit
  CONSTRAINT-CONSTRAINT			;The constraint as specified by the user
  CONSTRAINT-TYPE			;One of: :WINDOW, :STACKING, :IF, :BLANK
  CONSTRAINT-DATA			;If WINDOW: the window
					;If SPECIAL: (ordering . inferiors)
					;If IF: (conditional . inferiors)
					;If BLANK: function to draw "whitespace"
  (CONSTRAINT-CW 0)			;Current position of this window (if a window)
  (CONSTRAINT-CH 0)
  (CONSTRAINT-CX 0)
  (CONSTRAINT-CY 0)
  (CONSTRAINT-PW 0)			;Proposed position
  (CONSTRAINT-PH 0)
  (CONSTRAINT-PX 0)
  (CONSTRAINT-PY 0))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :AFTER :INIT) (IGNORE)
  (CONSTRAINT-FRAME-PROCESS-CONSTRAINTS)
  (SETF `(,CONFIGURATION . ,INTERNAL-CONSTRAINTS)
	(IF CONFIGURATION
	    (OR (ASSQ CONFIGURATION PARSED-CONSTRAINTS)
		(FERROR NIL "Configuration ~S not found" CONFIGURATION))
	    (FIRST PARSED-CONSTRAINTS)))	;Default initial configuration
  (AND SELECTED-PANE
       (SYMBOLP SELECTED-PANE)
       (SETQ SELECTED-PANE (FUNCALL-SELF ':GET-PANE SELECTED-PANE)))
  (CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :AFTER :REFRESH) (&OPTIONAL TYPE)
  (OR (AND RESTORED-BITS-P (NEQ TYPE ':SIZE-CHANGED))
      (EQ TYPE ':MARGINS-ONLY)
      (CONSTRAINT-FRAME-DRAW-BLANK-SPACE)))

;;; Stuff for dealing with panes by name

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :GET-PANE) (PANE-NAME)
  "Returns the pane with specified name or NIL if not found"
  (CDR (ASSQ PANE-NAME INTERNAL-PANES)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SEND-PANE) (PANE-NAME MESSAGE &REST ARGS &AUX W)
  "Send a message to the pane with specified name (error if not found)"
  (IF (SETQ W (CDR (ASSQ PANE-NAME INTERNAL-PANES)))
      (LEXPR-FUNCALL W MESSAGE ARGS)
      (FERROR NIL "No pane named ~S in this frame" PANE-NAME)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SEND-ALL-PANES) (MESSAGE &REST ARGS)
  "Send a message to all panes, including non-exposed ones"
  (DOLIST (X INTERNAL-PANES)
    (LEXPR-FUNCALL (CDR X) MESSAGE ARGS)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SEND-ALL-EXPOSED-PANES) (MESSAGE &REST ARGS)
  "Send a message to all exposed panes"
  (DOLIST (X INTERNAL-PANES)
    (AND (MEMQ (CDR X) EXPOSED-INFERIORS)
	 (LEXPR-FUNCALL (CDR X) MESSAGE ARGS))))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :PANE-NAME) (PANE)
  "Given a pane, this returns the name for that pane the user gave in his alist.
   NIL if for some reason it is not found."
  (DOLIST (X INTERNAL-PANES)
    (AND (EQ (CDR X) PANE) (RETURN (CAR X)))))


(DEFMETHOD (BASIC-CONSTRAINT-FRAME :GET-CONFIGURATION) (CONFIG-NAME)
  (CDR (ASSQ CONFIG-NAME PARSED-CONSTRAINTS)))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :REDEFINE-CONFIGURATION) (CONFIG-NAME NEW-CONFIG
							     &OPTIONAL (PARSED-P T))
  (OR PARSED-P (SETQ NEW-CONFIG
		     (CONSTRAINT-FRAME-PARSE-CONSTRAINTS NEW-CONFIG INTERNAL-PANES)))
  (LET ((CONFIG (ASSQ CONFIG-NAME PARSED-CONSTRAINTS)))
    (WITHOUT-INTERRUPTS
      (OR CONFIG
	  (IF PARSED-CONSTRAINTS
	      (RPLACD (LAST PARSED-CONSTRAINTS) (SETQ CONFIG (CONS CONFIG-NAME NIL)))
	      (SETQ PARSED-CONSTRAINTS (SETQ CONFIG (CONS CONFIG-NAME NIL))))))
    (RPLACD CONFIG NEW-CONFIG)
    NEW-CONFIG))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :SET-CONFIGURATION) (NEW-CONFIG-NAME)
  (LET ((CONFIG (ASSQ NEW-CONFIG-NAME PARSED-CONSTRAINTS)))
    (OR CONFIG (FERROR NIL "Unknown configuration ~A" NEW-CONFIG-NAME))
    (SETQ CONFIGURATION (CAR CONFIG)
	  INTERNAL-CONSTRAINTS (CDR CONFIG)
	  BLANK-RECTANGLES NIL))
  (CONSTRAINT-FRAME-CLEAR-CURRENT-POSITION INTERNAL-CONSTRAINTS)
  (CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION))

(DEFUN CONSTRAINT-FRAME-CLEAR-CURRENT-POSITION (CONSTRS &AUX NODE)
  (DOLIST (AENTRY (FIRST CONSTRS))
    (SETQ NODE (CDR AENTRY))
    (SELECTQ (CONSTRAINT-TYPE NODE)
      (:WINDOW
       (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
	   (FUNCALL (CONSTRAINT-DATA NODE) ':EDGES)
	 (SETF (CONSTRAINT-CX NODE) LEFT)
	 (SETF (CONSTRAINT-CY NODE) TOP)
	 (SETF (CONSTRAINT-CW NODE) (- RIGHT LEFT))
	 (SETF (CONSTRAINT-CH NODE) (- BOTTOM TOP))))
      (:STACKING
       (CONSTRAINT-FRAME-CLEAR-CURRENT-POSITION (CONSTRAINT-DATA NODE)))
      (:IF (FERROR NIL ":IF node type not yet implemented"))
      (OTHERWISE
       (SETF (CONSTRAINT-CX NODE) 0)
       (SETF (CONSTRAINT-CY NODE) 0)
       (SETF (CONSTRAINT-CW NODE) 0)
       (SETF (CONSTRAINT-CH NODE) 0)))))

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :VERIFY-NEW-EDGES) (IGNORE IGNORE NEW-WIDTH NEW-HEIGHT)
  (COND ((BOUNDP 'INTERNAL-CONSTRAINTS)
	 (IF (NOT (CONSTRAINT-FRAME-DO-CONSTRAINTS SELF INTERNAL-CONSTRAINTS
					  (- NEW-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
					  (- NEW-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)))
	     "Some constraint cannot be satisfied"
	     ;; Change our size temporarily
	     ;; so that panes will check their edges against the new size
	     (WITHOUT-INTERRUPTS
	       (LET-GLOBALLY ((WIDTH NEW-WIDTH) (HEIGHT NEW-HEIGHT) (RECURSION T))
		 (COND ((CONSTRAINT-FRAME-SET-EDGES INTERNAL-CONSTRAINTS ':VERIFY) NIL)
		       (T "Some pane refused to have its size set"))))))))

;;; When the inside-size changes, rethink the constraints and panes' edges
(DEFMETHOD (BASIC-CONSTRAINT-FRAME :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)
  (CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-CONSTRAINT-FRAME)
(DEFUN CONSTRAINT-FRAME-RECOMPUTE-CONFIGURATION ()
  (WITH-SHEET-DEEXPOSED (SELF)
    (LET-GLOBALLY ((RECURSION T))
      (DOLIST (P EXPOSED-PANES)
	(FUNCALL P ':DEEXPOSE ':DEFAULT ':NOOP)
	;; This assures that old panes won't gratuitously reappear if there is
	;; blank space in the new configuration where a pane used to be.  Note that
	;; this is careful not to touch inferiors that aren't "panes" of this
	;; constraint frame.
	(FUNCALL P ':DEACTIVATE))
      (OR (CONSTRAINT-FRAME-DO-CONSTRAINTS SELF INTERNAL-CONSTRAINTS
					   (SHEET-INSIDE-WIDTH) (SHEET-INSIDE-HEIGHT))
	  (FERROR NIL "Some constraint could not be satisfied"))
      (CONSTRAINT-FRAME-SET-EDGES INTERNAL-CONSTRAINTS NIL)
      (DOLIST (P EXPOSED-PANES) (FUNCALL P ':EXPOSE))
      (SETQ BLANK-RECTANGLES NIL)
      (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
	(CONSTRAINT-FRAME-DRAW-BLANK-SPACE))
      (OR (MEMQ SELECTED-PANE EXPOSED-INFERIORS)
	  (SETQ SELECTED-PANE NIL))))))

(DEFWRAPPER (BASIC-CONSTRAINT-FRAME :SCREEN-MANAGE-UNCOVERED-AREA) ((RECTS ARRAY X Y ALU)
								     . BODY)
  `(PROGN (SETF (SECOND SI:.DAEMON-CALLER-ARGS.)
		(CONSTRAINT-FRAME-SCREEN-MANAGE-UNCOVERED-AREA RECTS ARRAY X Y ALU))
	  . ,BODY))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-CONSTRAINT-FRAME)
(DEFUN CONSTRAINT-FRAME-SCREEN-MANAGE-UNCOVERED-AREA (RECTS ARRAY X Y IGNORE)
  "If there is any blank area, it might be covered by some :BLANK type constraints.
Check through the constraint list, and draw onto the array the appropriate swatches
of 'blankness'"
  (OR BLANK-RECTANGLES
      ;; If haven't figured out the blank rectangles, compute them now
      (SETQ BLANK-RECTANGLES
	    (OR (CONSTRAINT-FRAME-MAKE-BLANK-RECTANGLES INTERNAL-CONSTRAINTS)
		T)))
  (AND (NEQ BLANK-RECTANGLES T)
       (DOLIST (R RECTS)
	 (COND ((EQ (CAR (RECT-SOURCE R)) SELF)
		;; This is a blank area, hack appropriate portions of it
		(PROG DONE ((REMAINING-BLANK-RECTS (LIST R)))
		  (DOLIST (BLANK-RECT BLANK-RECTANGLES)
		    (DOLIST (REM-BLANK-RECT REMAINING-BLANK-RECTS)
		      (COND ((RECT-NOT-OVERLAP-RECT-P BLANK-RECT REM-BLANK-RECT))
			    (T
			     (LET ((NODE (FOURTH (RECT-SOURCE BLANK-RECT)))
				   (LEFT) (TOP) (RIGHT) (BOTTOM))
			       ;; Draw the overlapping area
			       (SETQ LEFT (MAX (RECT-LEFT BLANK-RECT)
					       (RECT-LEFT REM-BLANK-RECT))
				     TOP (MAX (RECT-TOP BLANK-RECT) (RECT-TOP REM-BLANK-RECT))
				     RIGHT (MIN (RECT-RIGHT BLANK-RECT)
						(RECT-RIGHT REM-BLANK-RECT))
				     BOTTOM (MIN (RECT-BOTTOM BLANK-RECT)
						 (RECT-BOTTOM REM-BLANK-RECT)))
			       (CONSTRAINT-FRAME-DRAW-A-BLANK
				 (CONSTRAINT-DATA NODE) NODE
				 (+ X LEFT) (+ Y TOP) (- RIGHT LEFT) (- BOTTOM TOP)
				 ARRAY))
			     (SETQ REMAINING-BLANK-RECTS
				   (NCONC (RECTANGLE-NOT-INTERSECTION BLANK-RECT
								      REM-BLANK-RECT)
					  (DELQ REM-BLANK-RECT REMAINING-BLANK-RECTS)))
			     (AND (NULL REMAINING-BLANK-RECTS) (RETURN-FROM DONE))))))
		  (SETQ RECTS (NCONC REMAINING-BLANK-RECTS RECTS)))
		(SETQ RECTS (DELQ R RECTS 1))))))
  RECTS))

(DEFUN CONSTRAINT-FRAME-MAKE-BLANK-RECTANGLES (CONSTR &AUX RECTS)
  (DOLIST (AENTRY (FIRST CONSTR))
    (LET ((NODE (CDR AENTRY))
	  (X) (Y))
      (SELECTQ (CONSTRAINT-TYPE NODE)
	(:BLANK (PUSH (LIST (LIST SELF 0 0 NODE)
			    (SETQ X (CONSTRAINT-CX NODE)) (SETQ Y (CONSTRAINT-CY NODE))
			    (+ X (CONSTRAINT-CW NODE)) (+ Y (CONSTRAINT-CH NODE)))
		      RECTS))
	(:STACKING
	 (SETQ RECTS
	       (NCONC RECTS
		      (CONSTRAINT-FRAME-MAKE-BLANK-RECTANGLES (CONSTRAINT-DATA NODE))))))))
  RECTS)

(DEFVAR CONSTRAINT-FRAME-DEFAULT-STACKING ':VERTICAL)

(DEFUN CONSTRAINT-FRAME-SET-EDGES (CONSTRS OPTION &AUX X Y R)
  "Loop over all panes and hack the edges as specified by the option."
  (NOT
    (DOLIST (AENTRY (FIRST CONSTRS))
      (LET ((NODE (CDR AENTRY)))
	(SELECTQ (CONSTRAINT-TYPE NODE)
	  (:WINDOW
	   (SETQ R (OR (AND (NEQ OPTION ':VERIFY)
			    (= (CONSTRAINT-PX NODE) (CONSTRAINT-CX NODE))
			    (= (CONSTRAINT-PY NODE) (CONSTRAINT-CY NODE))
			    (= (CONSTRAINT-PW NODE) (CONSTRAINT-CW NODE))
			    (= (CONSTRAINT-PH NODE) (CONSTRAINT-CH NODE)))
		       (FUNCALL (CONSTRAINT-DATA NODE) ':SET-EDGES
				(SETQ X (CONSTRAINT-PX NODE)) (SETQ Y (CONSTRAINT-PY NODE))
				(+ X (CONSTRAINT-PW NODE)) (+ Y (CONSTRAINT-PH NODE))
				OPTION))))
	  (:STACKING (SETQ R (CONSTRAINT-FRAME-SET-EDGES (CONSTRAINT-DATA NODE) OPTION)))
	  (:IF (FERROR NIL ":IF is unimplemented option"))
	  (OTHERWISE (SETQ R T)))
	(IF (EQ OPTION ':VERIFY)
	    
	    ;; If verifying, return right away if didn't verify
	    (OR R (RETURN T))
	    
	    ;; If not verifying, proposed data is now current data
	    (SETF (CONSTRAINT-CX NODE) (CONSTRAINT-PX NODE))
	    (SETF (CONSTRAINT-CY NODE) (CONSTRAINT-PY NODE))
	    (SETF (CONSTRAINT-CW NODE) (CONSTRAINT-PW NODE))
	    (SETF (CONSTRAINT-CH NODE) (CONSTRAINT-PH NODE)))))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-CONSTRAINT-FRAME)
(DEFUN CONSTRAINT-FRAME-PROCESS-CONSTRAINTS (&REST IGNORE)
  "CONSTRAINTS contains a list of unprocessed constraints.  Process them.  Entries
look like:

   constraint := ({:LIMIT (min max {[:LINES | :CHARACTERS]})}
		  [:ASK-WINDOW pane-name message . args |
                   :ASK message . args |
		   :FUNCALL function . args |
		   :EVAL form |
		   [:EVEN | fixnum | flonum] {[:LINES | :CHARACTERS]} |
		   :FIXED
		   ])

   desc := (ordering desc-part)
   desc-part := (desc-group) {desc-part}
   desc-group := [ ('window name' . constraint) |
   		   ('special name' [:HORIZONTAL | :VERTICAL] constraint . desc) |
		   ('special name' :IF [conditional | :ELSE] desc)
		   ('special name' :BLANK [:WHITE | :BLACK] constraint)
		   ] {desc-group}


    Fixnum - absolute number of pixels
    Flonum - percentage of available space
    :EVEN - divide remaining space evenly among all :EVEN constraints
            :EVEN's can only be in the last descriptor group, and must be by themselves
            (No other types of constraints allowed)
    :ASK, :ASK-WINDOW, :FUNCALL - sends the message to the pane with the args as shown below,
      and the specified args, and expects back the height or
      the width that the window wants to be.  :ASK-WINDOW takes the
      name of a window as its first arg.

    :EVAL - evals the specified form

    :FIXED - Only for a window: never change the window's size

    For :FUNCALL the first arg is the node.  
    For :EVAL, **CONSTRAINT-NODE** is bound to the node.

      The first five arguments given to the method are as follows:
	**CONSTRAINT-REMAINING-WIDTH** - The maximum width of the window (amount
					 of space remaining for this window)
	**CONSTRAINT-REMAINING-HEIGHT** - The maximum height
	**CONSTRAINT-TOTAL-WIDTH** - The total width of the current section
	**CONSTRAINT-TOTAL-HEIGHT** - The total height of the current section
	**CONSTRAINT-CURRENT-STACKING** - :HORIZONTAL or :VERTICAL, depending upon
					    which dimension is currently being hacked

      (In the case of :EVAL, these special variables are bound)

 A typical frame setup might be (dimension starts out as :HEIGHT):
 ((WA LISP-LISTENER) (WB MENU :ITEM-LIST (foo bar baz quux))
  (WC MY-OWN-LISP-LISTENER) (WD SOME-OTHER-FUNNY-WINDOW :MY-INIT MY-ARG))

 ((WA
   WB
   G0)
  ((WB :ASK :PANE-SIZE))
  ((WA :LIMIT (3 NIL :LINES) :EVEN)
   (G0 :HORIZONTAL (:ASK-WINDOW WD :PANE-SIZE)
       (WD WC)
       ((WC :LIMIT (10. NIL :LINES) :EVEN)
        (WD :LIMIT (10. NIL :LINES) :EVEN)))))
"

  ;; First turn constraint list into nodes
  (SETQ INTERNAL-PANES (LET-GLOBALLY ((RECURSION T)) (CONSTRAINT-FRAME-WINDOWS PANES)))
  (SETQ PARSED-CONSTRAINTS NIL)
  (DOLIST (CONSTR CONSTRAINTS)
    (PUSH (CONS (CAR CONSTR)
		(CONSTRAINT-FRAME-PARSE-CONSTRAINTS (CDR CONSTR) INTERNAL-PANES))
	  PARSED-CONSTRAINTS))
  (SETQ PARSED-CONSTRAINTS (NREVERSE PARSED-CONSTRAINTS))))

(DEFUN CONSTRAINT-FRAME-WINDOWS (DESCS &AUX PARSED)
  (DOLIST (DESC DESCS)
    (PUSH (CONS (FIRST DESC)
		(IF (TYPEP (CDR DESC) 'SHEET)
		    (CDR DESC)
		    (LEXPR-FUNCALL-SELF ':CREATE-PANE DESC)))
	  PARSED))
  PARSED)

(DEFMETHOD (BASIC-CONSTRAINT-FRAME :CREATE-PANE) (IGNORE FLAVOR &REST OPTIONS)
  (LEXPR-FUNCALL #'MAKE-WINDOW FLAVOR ':SUPERIOR SELF OPTIONS))

(DEFFLAVOR CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER ((IO-BUFFER NIL)) (BASIC-CONSTRAINT-FRAME)
  (:INITABLE-INSTANCE-VARIABLES IO-BUFFER))

(DEFMETHOD (CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER :BEFORE :INIT) (IGNORE)
  (OR IO-BUFFER (SETQ IO-BUFFER (MAKE-DEFAULT-IO-BUFFER))))

(DEFMETHOD (CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER :CREATE-PANE) (IGNORE FLAVOR &REST OPTIONS)
  (LEXPR-FUNCALL #'MAKE-WINDOW FLAVOR ':SUPERIOR SELF ':IO-BUFFER IO-BUFFER OPTIONS))

(DEFFLAVOR BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER ()
  (CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER CONSTRAINT-FRAME-FORWARDING-MIXIN
   BORDERS-MIXIN BASIC-FRAME)
  (:DEFAULT-INIT-PLIST :BORDER-MARGIN-WIDTH 0))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-CONSTRAINT-FRAME)
(DEFUN CONSTRAINT-FRAME-SUBSTITUTION (DESC)
  (COND ((LISTP DESC) DESC)
	((SYMBOLP DESC)
	 (OR (CDR (ASSQ DESC SUBSTITUTIONS))
	     (FERROR
	       NIL
	       "~A is a symbol where a list was expected (and it has no substitution)"
	       DESC)))
	(T (FERROR
	     NIL
	     "~A was found where a list (or a symbol with a substitution) was expected"
	     DESC)))))

(DEFUN CONSTRAINT-FRAME-PARSE-CONSTRAINTS (CONSTRAINTS PANES
					    &OPTIONAL (STACKING
							CONSTRAINT-FRAME-DEFAULT-STACKING))
  "Given a list of constraints, returns the internal format."
  (LET ((INTERNAL-ORDERING NIL)
	(ORDERING (CAR CONSTRAINTS))
	(INTERNAL-DESCS NIL))
    (OR (LISTP ORDERING)
	(FERROR NIL "Constraint ~S does not start with an ordering" CONSTRAINTS))
    (DO ((WNS ORDERING (CDR WNS))
	 (WS NIL)
	 (WINDOW))
	((NULL WNS)
	 (SETQ INTERNAL-ORDERING (NREVERSE WS)))
      (PUSH (CONS (CAR WNS)
		  (IF (SETQ WINDOW (ASSQ (CAR WNS) PANES))
		      (CDR WINDOW)		;A window, include the window itself
		      (CAR WNS)))		;Must be a special name, will fill it in later
	    WS))
    (DO ((DESC-GROUPS (CDR CONSTRAINTS) (CDR DESC-GROUPS))
	 (INTERNAL-DESC-GROUP NIL NIL)
	 (EVEN-P NIL NIL)
	 (LAST-GROUP-P))
	((NULL DESC-GROUPS))	 
      ;; Process each descriptor group
      (SETQ LAST-GROUP-P (NULL (CDR DESC-GROUPS)))
      (DOLIST (DESC (CONSTRAINT-FRAME-SUBSTITUTION (CAR DESC-GROUPS)))

	REPARSE					;Yes, this is a GO tag!

	;; For each descriptor, parse it
	(SETQ DESC (CONSTRAINT-FRAME-SUBSTITUTION DESC))
	(LET ((NAME (CAR DESC))
	      (WOS) (AENTRY) (MACRO-P))
	  (OR (SETQ WOS (CDR (SETQ AENTRY (ASSQ NAME INTERNAL-ORDERING))))
	      (FERROR NIL "~A is unspecified in the ordering" NAME))
	  (COND ((TYPEP WOS 'SHEET)
		 ;; A window -- parse the constraint and make the node
		 (MULTIPLE-VALUE-BIND (CONSTR MIN MAX TEM)
		     (PARSE-CONSTRAINT (CDR DESC) PANES WOS LAST-GROUP-P EVEN-P)
		   (SETQ EVEN-P TEM)
		   (PUSH (MAKE-CONSTRAINT-NODE CONSTRAINT-NAME (GET-PNAME NAME)
					       CONSTRAINT-TYPE ':WINDOW
					       CONSTRAINT-CONSTRAINT CONSTR
					       CONSTRAINT-DATA WOS
					       CONSTRAINT-MIN MIN
					       CONSTRAINT-MAX MAX)
			 INTERNAL-DESC-GROUP)))
		((NOT (SYMBOLP WOS))
		 (FERROR NIL "~A is not a valid special name at this point" NAME))
		((MEMQ (SECOND DESC) '(:HORIZONTAL :VERTICAL))
		 (AND (EQ (SECOND DESC) STACKING)
		      (FERROR NIL "Current stacking (~A) same as new stacking" STACKING))
		 (MULTIPLE-VALUE-BIND (CONSTR MIN MAX TEM)
		     (PARSE-CONSTRAINT (THIRD DESC) PANES NIL LAST-GROUP-P EVEN-P)
		   (SETQ EVEN-P TEM)
		   (PUSH (MAKE-CONSTRAINT-NODE
			   CONSTRAINT-NAME (GET-PNAME NAME)
			   CONSTRAINT-TYPE ':STACKING
			   CONSTRAINT-CONSTRAINT CONSTR
			   CONSTRAINT-DATA
			    (CONSTRAINT-FRAME-PARSE-CONSTRAINTS (CDDDR DESC)
								PANES
								(SECOND DESC))
			   CONSTRAINT-MIN MIN
			   CONSTRAINT-MAX MAX)
			 INTERNAL-DESC-GROUP)))
		((EQ (SECOND DESC) ':IF)
		 (FERROR NIL "Conditionals not currently supported"))
		((EQ (SECOND DESC) ':BLANK)
		 (MULTIPLE-VALUE-BIND (CONSTR MIN MAX TEM)
		     (PARSE-CONSTRAINT (CDDDR DESC) PANES NIL LAST-GROUP-P EVEN-P)
		   (SETQ EVEN-P TEM)
		   (PUSH (MAKE-CONSTRAINT-NODE
			   CONSTRAINT-NAME (GET-PNAME NAME)
			   CONSTRAINT-TYPE ':BLANK
			   CONSTRAINT-CONSTRAINT CONSTR
			   CONSTRAINT-DATA (SELECTQ (THIRD DESC)
					     (:WHITE #'CONSTRAINT-FRAME-WHITE-BLANKING)
					     (:BLACK #'CONSTRAINT-FRAME-BLACK-BLANKING)
					     (OTHERWISE (THIRD DESC)))
			   CONSTRAINT-MIN MIN
			   CONSTRAINT-MAX MAX)
			 INTERNAL-DESC-GROUP)))
		((SETQ MACRO-P (GET (SECOND DESC) 'CONSTRAINT-MACRO))
		 ;; A macro: expand it and use its expansion in place of the current
		 ;; description
		 (SETQ DESC (CONS (CAR DESC) (FUNCALL MACRO-P DESC STACKING)))
		 (GO REPARSE))
		(T (FERROR NIL "~A is unknown special keyword, perhaps ~A is missing from TV:PANES" (SECOND DESC) (FIRST DESC))))
	  (RPLACD AENTRY (CAR INTERNAL-DESC-GROUP))))
      (PUSH (NREVERSE INTERNAL-DESC-GROUP) INTERNAL-DESCS))
    (DOLIST (ORD INTERNAL-ORDERING)
      (AND (OR (TYPEP (CDR ORD) 'SHEET) (EQ (CAR ORD) (CDR ORD)))
	   (FERROR NIL "~A was specified in ordering, but not specified in any descriptor"
		   (CAR ORD))))
    (CONS INTERNAL-ORDERING (NREVERSE INTERNAL-DESCS))))

(DEFUNP PARSE-CONSTRAINT (CONSTR PANES WINDOW LG-P EVEN-P &AUX (MIN -1) (MAX 1_15.))
  "Verify correctness of the specified constraint.  Returns the constraint part
of the constraint, as well as the limits if specified."
  (COND ((EQ (FIRST CONSTR) ':LIMIT)
	 (LET ((LIMITS (SECOND CONSTR))
	       (ROUND) (OFFSET))
	   (COND ((> (LENGTH LIMITS) 2)
		  (OR (SETQ WINDOW (OR (PARSE-CONSTRAINT-GET-PANE (FOURTH LIMITS) PANES)
				       WINDOW))
		      (FERROR NIL "Illegal format :LIMIT (no window specified)"))
		  (SELECTQ (THIRD LIMITS)
		    (:CHARACTERS (SETQ ROUND (SHEET-CHAR-WIDTH WINDOW)
				       OFFSET (+ (SHEET-LEFT-MARGIN-SIZE WINDOW)
						 (SHEET-RIGHT-MARGIN-SIZE WINDOW))))
		    (:LINES (SETQ ROUND (SHEET-LINE-HEIGHT WINDOW)
				  OFFSET (+ (SHEET-TOP-MARGIN-SIZE WINDOW)
					    (SHEET-BOTTOM-MARGIN-SIZE WINDOW))))
		    (OTHERWISE (FERROR NIL "~A is illegal rounding specification"
				       (THIRD LIMITS))))))
	   (SETQ MIN (OR (FIRST LIMITS) MIN)
		 MAX (OR (SECOND LIMITS) MAX))
	   (SETQ MIN (IF ROUND (+ (* MIN ROUND) OFFSET) MIN)
		 MAX (IF ROUND (+ (* MAX ROUND) OFFSET) MAX)))
	 (SETQ CONSTR (CDDR CONSTR))))
  (COND ((OR (IF (NUMBERP (FIRST CONSTR))
		 (OR (NULL EVEN-P) (EQ EVEN-P ':NO)
		     (FERROR NIL "Cannot mix :EVEN constraints and other constraints"))
		 NIL)
	     (COND ((EQ (FIRST CONSTR) ':EVEN)
		    (OR LG-P (FERROR NIL ":EVEN not in last descriptor group"))
		    (OR (NULL EVEN-P) (EQ EVEN-P ':YES)
			(FERROR NIL "Cannot mix :EVEN constraints and other constraints"))
		    (SETQ EVEN-P ':YES)
		    T)))
	 (COND ((> (LENGTH CONSTR) 1)
		(LET ((W (PARSE-CONSTRAINT-GET-PANE (THIRD CONSTR) PANES)))
		  (IF W
		      (SETQ WINDOW W
			    CONSTR (LIST (FIRST CONSTR) (SECOND CONSTR) W))
		      (OR WINDOW
			  (FERROR NIL "Illegal format constraint -- no window specified"))))
		(OR (MEMQ (SECOND CONSTR) '(:LINES :CHARACTERS))
		    (FERROR NIL "Illegal rounding specifier ~A" (SECOND CONSTR)))
		(AND (FIXP (FIRST CONSTR))
		     (SETQ CONSTR (LIST (* (FIRST CONSTR)
					   (SELECTQ (SECOND CONSTR)
					     (:LINES (SHEET-LINE-HEIGHT WINDOW))
					     (:CHARACTERS (SHEET-CHAR-WIDTH WINDOW))))
					(SECOND CONSTR)
					WINDOW))))))
	((NOT (OR (NULL EVEN-P) (EQ EVEN-P ':NO)))
	 (FERROR NIL "Cannot mix :EVEN constraints and other constraints"))
	((MEMQ (FIRST CONSTR) '(:ASK :FUNCALL :EVAL :FIXED)))
	((EQ (FIRST CONSTR) ':ASK-WINDOW)
	 (LET ((W (IF (EQ (SECOND CONSTR) 'SELF)
		      SELF
		      (CDR (ASSQ (SECOND CONSTR) PANES)))))
	   (OR W (FERROR NIL "Unknown pane ~A is :ASK-WINDOW constraint"
			 (SECOND CONSTR)))
	   (SETF (SECOND (SETQ CONSTR (COPYLIST CONSTR))) W))))
  (RETURN CONSTR MIN MAX (OR EVEN-P ':NO)))

(DEFUN PARSE-CONSTRAINT-GET-PANE (PANE-NAME PANES)
  (AND PANE-NAME
       (OR (CDR (ASSQ PANE-NAME PANES))
	   (FERROR NIL "Unknown pane name ~A" PANE-NAME))))

(DEFUN CONSTRAINT-FRAME-DO-CONSTRAINTS (FRAME CONSTRS
					&OPTIONAL (W (SHEET-INSIDE-WIDTH FRAME))
					          (H (SHEET-INSIDE-HEIGHT FRAME)))
  (*CATCH ':VERTICAL
    (*CATCH ':HORIZONTAL
      (PROGN
	(CONSTRAINT-FRAME-DO-SIZES W H CONSTRS)
	(FUNCALL FRAME ':SET-EXPOSED-PANES
		 (CONSTRAINT-FRAME-DO-POSITIONS CONSTRS CONSTRAINT-FRAME-DEFAULT-STACKING
						(SHEET-LEFT-MARGIN-SIZE FRAME)
						(SHEET-TOP-MARGIN-SIZE FRAME)))
	T))))

(DEFUN CONSTRAINT-FRAME-DO-SIZES (WIDTH HEIGHT CONSTRS
				   &OPTIONAL (STACKING CONSTRAINT-FRAME-DEFAULT-STACKING))
  "Given that the current width and height of the frame, calculate new values of position
and size for each node.  Constraints are assumed parsed and valid."
;;; **** Does not know about min's or max's yet!
  (LET ((DESC-GROUPS (CDR CONSTRS)))
    (DOLIST (DESC-GROUP DESC-GROUPS)
      ;; For each group, assign widths and heights
      (LET (WIDTH-USED HEIGHT-USED)
	(COND ((NOT (*CATCH STACKING
		      (PROGN
			(MULTIPLE-VALUE (WIDTH-USED HEIGHT-USED)
			  (CONSTRAINT-FRAME-DO-SIZES-INTERNAL DESC-GROUP
							      WIDTH HEIGHT WIDTH HEIGHT
							      STACKING))
			T)))
	       ;; Some constraint couldn't be satisfied.  Try only allowing each constraint
	       ;; to take 1/Nth of the area, where N is the total number of constraints
	       (MULTIPLE-VALUE (WIDTH-USED HEIGHT-USED)
		 (CONSTRAINT-FRAME-DO-SIZES-INTERNAL DESC-GROUP WIDTH HEIGHT
	           (IF (EQ STACKING ':HORIZONTAL) (// WIDTH (LENGTH DESC-GROUP)) WIDTH)
		   (IF (EQ STACKING ':VERTICAL) (// HEIGHT (LENGTH DESC-GROUP)) HEIGHT)
		   STACKING))))
	(SETQ WIDTH (- WIDTH WIDTH-USED)
	      HEIGHT (- HEIGHT HEIGHT-USED))
	(AND (OR (< WIDTH 0) (< HEIGHT 0))
	     (*THROW STACKING NIL))))))

(DEFUN CONSTRAINT-FRAME-DO-SIZES-INTERNAL (DESC-GROUP WIDTH HEIGHT AV-WIDTH AV-HEIGHT STACKING
					   &AUX (WIDTH-USED 0) (HEIGHT-USED 0) W H)
  (DOLIST (NODE DESC-GROUP)
    ;; Amount of room available is the smaller of the total amount of room, or the maximum
    ;; allowed by the caller
    (SETQ AV-WIDTH (MIN (- WIDTH WIDTH-USED) AV-WIDTH)
	  AV-HEIGHT (MIN (- HEIGHT HEIGHT-USED) AV-HEIGHT))
    (SELECTQ (CONSTRAINT-TYPE NODE)
      ;; Dispatch on node type
      ((:WINDOW :BLANK)
       ;; A real window, easy -- compute the new values, stick 'em in, and loop
       ;; Blanks get handled in same way
       (MULTIPLE-VALUE (W H)
	 (CONSTRAINT-FRAME-DO-A-CONSTRAINT NODE AV-WIDTH AV-HEIGHT WIDTH HEIGHT
					   STACKING DESC-GROUP)))
      (:STACKING
       ;; A special thing, some sort of descent needed.  First fill in size
       (MULTIPLE-VALUE (W H)
	 (CONSTRAINT-FRAME-DO-A-CONSTRAINT NODE AV-WIDTH AV-HEIGHT WIDTH HEIGHT
					   STACKING DESC-GROUP))
       ;; Then recurse with new values
       (CONSTRAINT-FRAME-DO-SIZES W H (CONSTRAINT-DATA NODE)
				  (SELECTQ STACKING
				    (:VERTICAL ':HORIZONTAL)
				    (:HORIZONTAL ':VERTICAL))))
      (:IF (FERROR NIL ":IF not yet supported"))
      (OTHERWISE (FERROR NIL "Unknown node type ~A" (CONSTRAINT-TYPE NODE))))
    (SELECTQ STACKING
      (:VERTICAL
       (SETQ HEIGHT-USED (+ HEIGHT-USED H))
       (AND (> HEIGHT-USED HEIGHT)
	    ;; Ran out of room, try alternate algorithm
	    (*THROW ':VERTICAL NIL)))
      (:HORIZONTAL
       (SETQ WIDTH-USED (+ WIDTH-USED W))
       (AND (> WIDTH-USED WIDTH)
	    (*THROW ':HORIZONTAL NIL)))))
  (VALUES WIDTH-USED HEIGHT-USED))


(DEFVAR **CONSTRAINT-NODE**)
(DEFVAR **CONSTRAINT-REMAINING-WIDTH**)
(DEFVAR **CONSTRAINT-REMAINING-HEIGHT**)
(DEFVAR **CONSTRAINT-TOTAL-WIDTH**)
(DEFVAR **CONSTRAINT-TOTAL-HEIGHT**)
(DEFVAR **CONSTRAINT-CURRENT-STACKING**)

(DEFUNP CONSTRAINT-FRAME-DO-A-CONSTRAINT (NODE AV-W AV-H W H STACKING DG &AUX AMOUNT CON)
  "Processes one constraint, setting the proposed width and height in the node to the
ones specified by the constraint."
  (SETQ CON (CONSTRAINT-CONSTRAINT NODE))
  (COND
    ;; Dispatch on type of constraint
    ((EQ (FIRST CON) ':ASK-WINDOW)
     (SETQ AMOUNT (LEXPR-FUNCALL (SECOND CON) (THIRD CON)
				 AV-W AV-H W H STACKING (CDDDR CON))))
    ((EQ (FIRST CON) ':ASK)
     (SETQ AMOUNT (LEXPR-FUNCALL (CONSTRAINT-DATA NODE)
				 (SECOND CON) AV-W AV-H W H STACKING (CDDR CON))))
    ((EQ (FIRST CON) ':FUNCALL)
     (SETQ AMOUNT (LEXPR-FUNCALL (SECOND CON) NODE AV-W AV-H W H STACKING
				 (CDDR CON))))
    ((EQ (FIRST CON) ':EVAL)
     (LET ((**CONSTRAINT-NODE** NODE)
	   (**CONSTRAINT-REMAINING-WIDTH** AV-W)
	   (**CONSTRAINT-REMAINING-HEIGHT** AV-H)
	   (**CONSTRAINT-TOTAL-WIDTH** W)
	   (**CONSTRAINT-TOTAL-HEIGHT** H)
	   (**CONSTRAINT-CURRENT-STACKING** STACKING))
       (SETQ AMOUNT (EVAL (SECOND CON)))))
    ((FIXP (FIRST CON))
     (SETQ AMOUNT (CONSTRAINT-ROUND (FIRST CON) CON NODE)))
    ((FLOATP (FIRST CON))
     (SETQ AMOUNT (CONSTRAINT-ROUND (* (FIRST CON) (SELECTQ STACKING
 						     (:VERTICAL H)
						     (:HORIZONTAL W)))
				    CON NODE)))
    ((EQ (FIRST CON) ':EVEN)
     (SETQ AMOUNT (CONSTRAINT-ROUND (// (SELECTQ STACKING
					  (:HORIZONTAL AV-W)
					  (:VERTICAL AV-H))
					(- (LENGTH DG)
					   (DO ((I 0 (1+ I))
						(L DG (CDR L)))
					       ((NULL L) (FERROR NIL "Node not a node"))
					     (AND (EQ (CAR L) NODE) (RETURN I)))))
				    CON NODE)))
    ((EQ (FIRST CON) ':FIXED)
     (SELECTQ STACKING
       (:VERTICAL (SETQ AMOUNT (SHEET-HEIGHT (CONSTRAINT-DATA NODE))
			W (SHEET-WIDTH (CONSTRAINT-DATA NODE))))
       (:HORIZONTAL (SETQ H (SHEET-HEIGHT (CONSTRAINT-DATA NODE))
			  AMOUNT (SHEET-WIDTH (CONSTRAINT-DATA NODE))))))
    (T (FERROR NIL "Unknown constraint type ~A" CON)))
  (SELECTQ STACKING
    (:VERTICAL (SETF (CONSTRAINT-PW NODE) W)
	       (SETF (CONSTRAINT-PH NODE) (SETQ H AMOUNT)))
    (:HORIZONTAL (SETF (CONSTRAINT-PW NODE) (SETQ W AMOUNT))
		 (SETF (CONSTRAINT-PH NODE) H))
    (OTHERWISE (FERROR NIL "Illegal value for stacking ~A" STACKING)))
  (RETURN W H))

(DEFUN CONSTRAINT-ROUND (SIZE CON NODE &AUX TEM (WINDOW (CONSTRAINT-DATA NODE)))
  "Given a proposed size, a constraint, and the node, don't round, or round to lines
or characters.  Also enforces limits."
  (SETQ SIZE (FIX SIZE))
  (MIN (CONSTRAINT-MAX NODE)
       (MAX (CONSTRAINT-MIN NODE)
	    (COND ((OR (NUMBERP (FIRST CON)) (EQ (FIRST CON) ':EVEN))
		   (SETQ WINDOW (OR (THIRD CON) WINDOW))
		   (SELECTQ (SECOND CON)
		     (:LINES
		      (+ (SHEET-TOP-MARGIN-SIZE WINDOW) (SHEET-BOTTOM-MARGIN-SIZE WINDOW)
			 (* (SETQ TEM (SHEET-LINE-HEIGHT WINDOW))
			    (// SIZE TEM))))
		     (:CHARACTERS
		      (+ (SHEET-LEFT-MARGIN-SIZE WINDOW) (SHEET-RIGHT-MARGIN-SIZE WINDOW)
			 (* (SETQ TEM (SHEET-CHAR-WIDTH WINDOW))
			    (// SIZE TEM))))
		     (T SIZE)))
		  (T SIZE)))))

(DEFUN CONSTRAINT-FRAME-DO-POSITIONS (CONSTRS
				       &OPTIONAL (STACKING CONSTRAINT-FRAME-DEFAULT-STACKING)
				                 (X 0) (Y 0)
				       &AUX NODE PANES)
  "Given that proposed size has been set up, set up the proposed positions.  Returns a list 
of all involved panes."
  (DOLIST (AENTRY (FIRST CONSTRS))
    ;; Loop over windows in order, and assign positions
    (SETQ NODE (CDR AENTRY))
    (SETF (CONSTRAINT-PX NODE) X)
    (SETF (CONSTRAINT-PY NODE) Y)
    (SELECTQ (CONSTRAINT-TYPE NODE)
      (:WINDOW (PUSH (CONSTRAINT-DATA NODE) PANES))
      (:STACKING (SETQ PANES
		       (NCONC (CONSTRAINT-FRAME-DO-POSITIONS (CONSTRAINT-DATA NODE)
							     (SELECTQ STACKING
							       (:VERTICAL ':HORIZONTAL)
							       (:HORIZONTAL ':VERTICAL))
							     X Y)
			      PANES)))
      (:IF (FERROR NIL ":IF not yet supported"))
      (:BLANK)
      (OTHERWISE (FERROR NIL "Unknown node type ~A" (CONSTRAINT-TYPE NODE))))
    (SELECTQ STACKING
      (:VERTICAL (SETQ Y (+ Y (CONSTRAINT-PH NODE))))
      (:HORIZONTAL (SETQ X (+ X (CONSTRAINT-PW NODE))))))
  PANES)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-CONSTRAINT-FRAME)
(DEFUN CONSTRAINT-FRAME-DRAW-BLANK-SPACE (&OPTIONAL (CONSTRS INTERNAL-CONSTRAINTS))
  "Map over the constraint data structure, and draw all blank area."
  (DOLIST (AENTRY (FIRST CONSTRS))
    (LET ((NODE (CDR AENTRY)))
      (SELECTQ (CONSTRAINT-TYPE NODE)
	(:BLANK (PREPARE-SHEET (SELF)
		  (CONSTRAINT-FRAME-DRAW-A-BLANK (CONSTRAINT-DATA NODE) NODE
						 (CONSTRAINT-CX NODE) (CONSTRAINT-CY NODE)
						 (CONSTRAINT-CW NODE) (CONSTRAINT-CH NODE)
						 SCREEN-ARRAY)))
	(:STACKING (CONSTRAINT-FRAME-DRAW-BLANK-SPACE (CONSTRAINT-DATA NODE))))))))

(DEFUN CONSTRAINT-FRAME-DRAW-A-BLANK (BLANK-TYPE NODE X Y W H SCREEN-ARRAY)
  (COND ((FUNCTIONP BLANK-TYPE)
	 ;; An explicit drawing function
	 (FUNCALL BLANK-TYPE NODE X Y W H SCREEN-ARRAY))
	((LISTP BLANK-TYPE)
	 (LEXPR-FUNCALL (CAR BLANK-TYPE) NODE X Y W H SCREEN-ARRAY (CDR BLANK-TYPE)))
	((ARRAYP BLANK-TYPE)
	 ;; Stipple array -- draw in standard way
	 (CONSTRAINT-FRAME-STIPPLE-BLANKING NODE X Y W H SCREEN-ARRAY BLANK-TYPE))
	(T (FERROR NIL "~S is an unknown type of blanking" BLANK-TYPE))))

(DEFVAR BLANKING-ARRAY
	(LET ((A (MAKE-ARRAY NIL 'ART-1B '(32. 1))))
	  (DOTIMES (I 32.) (ASET 1 A I 0))
	  A))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN CONSTRAINT-FRAME-WHITE-BLANKING (IGNORE X Y W H ARRAY)
  (BITBLT ERASE-ALUF W H BLANKING-ARRAY 0 0 ARRAY X Y)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN CONSTRAINT-FRAME-BLACK-BLANKING (IGNORE X Y W H ARRAY)
  (BITBLT CHAR-ALUF W H BLANKING-ARRAY 0 0 ARRAY X Y)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SHEET)
(DEFUN CONSTRAINT-FRAME-STIPPLE-BLANKING (IGNORE X Y W H ARRAY GRAY-ARRAY)
  (BITBLT CHAR-ALUF W H
	  GRAY-ARRAY (\ X (ARRAY-DIMENSION-N 1 GRAY-ARRAY))
	  	     (\ Y (ARRAY-DIMENSION-N 2 GRAY-ARRAY))
          ARRAY X Y)))

;;; Constraint macros

(DEFUN (FIXED-WITH-WHITESPACE CONSTRAINT-MACRO) (OLD-DESC STACKING)
  "A constraint-frame macro to take a window, and giving it the :FIXED attribute
leave whitespace around it on all four sides.  Format is:
    (name FIXED-WITH-WHITESPACE name-of-window color-of-border . constraint)
"
  (LET ((S1 (GENSYM)) (S2 (GENSYM)) (S3 (GENSYM)) (S4 (GENSYM))
	(SN (GENSYM)) (COB (FOURTH OLD-DESC)))
    `(,(SELECTQ STACKING
	 (:VERTICAL ':HORIZONTAL)
	 (:HORIZONTAL ':VERTICAL))
      ,(CDDDDR OLD-DESC)
      (,S1 ,SN ,S2)
      ((,SN ,STACKING (:ASK-WINDOW ,(THIRD OLD-DESC) :PANE-SIZE)
	(,S3 ,(THIRD OLD-DESC) ,S4)
	((,(THIRD OLD-DESC) :FIXED))
	((,S3 :BLANK ,COB :EVEN) (,S4 :BLANK ,COB :EVEN))))
      ((,S1 :BLANK ,COB :EVEN) (,S2 :BLANK ,COB :EVEN)))))

(DEFUN (INTERDIGITATED-WHITESPACE CONSTRAINT-MACRO) (OLD-DESC STACKING)
  "Leave whitespace betweem all specified constraints (alternates stacking):
    (name INTERDIGITATED-WHITESPACE color :INCLUDE-or-:EXCLUDE
          our-constraint
          whitespace-constraint
          . <same as args to a stacking constraint>)

   :EXCLUDE means no whitespace before first and after last, :INCLUDE means include this
whitespace."
  (LET ((COLOR (THIRD OLD-DESC))
	(IOE (FOURTH OLD-DESC))
	(WSPACECON (SIXTH OLD-DESC))
	(INFS (SEVENTH OLD-DESC))
	(WSPACE) (NINFS))
    (OR (MEMQ IOE '(:INCLUDE :EXCLUDE))
	(FERROR NIL "~A must be either :INCLUDE or :EXCLUDE" IOE))
    (DO ((I INFS (CDR I))
	 (GS))
	(NIL)
      (COND ((AND (EQ IOE ':EXCLUDE)
		  (OR (EQ I INFS) (NULL I))))
	    (T
	     (SETQ GS (GENSYM))
	     (PUSH GS NINFS)
	     (PUSH `(,GS :BLANK ,COLOR . ,WSPACECON) WSPACE)))
      (AND I (PUSH (CAR I) NINFS))
      (AND (NULL I) (RETURN)))
    `(,(SELECTQ STACKING
	 (:VERTICAL ':HORIZONTAL)
	 (:HORIZONTAL ':VERTICAL))
      ,(FIFTH OLD-DESC)
      ,(NREVERSE NINFS)
      . ,(LET ((CONSTRS (COPYLIST (NTHCDR 7 OLD-DESC))))
	   (DO ((CS CONSTRS (CDR CS))
		(SEEN-* NIL))
	       ((NULL CS)
		(OR SEEN-* (RPLACD (LAST CONSTRS) (NCONS WSPACE))))
	     (COND ((MEMQ '* (CAR CS))
		    (SETQ SEEN-* T)
		    (RPLACA CS (APPEND (REMQ '* (CAR CS)) WSPACE)))))
	   CONSTRS))))

;;; Support from other flavors

(DEFMETHOD (BASIC-MENU :PANE-SIZE) (REM-WIDTH REM-HEIGHT IGNORE IGNORE STACKING
					      &OPTIONAL N-ROWS N-COLUMNS)
  (MULTIPLE-VALUE-BIND (IGNORE IGNORE NEW-WIDTH NEW-HEIGHT)
      (MENU-DEDUCE-PARAMETERS N-COLUMNS N-ROWS
			      (IF (EQ STACKING ':VERTICAL)
				  (- REM-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
				  ':UNCONSTRAINED)
			      (IF (EQ STACKING ':HORIZONTAL)
				  (- REM-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)
				  ':UNCONSTRAINED)
			      (- REM-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
			      (- REM-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
    (SELECTQ STACKING
      (:VERTICAL (+ NEW-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
      (:HORIZONTAL (+ NEW-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))))

(DEFMETHOD (ESSENTIAL-WINDOW :PANE-SIZE) (REM-WIDTH REM-HEIGHT IGNORE IGNORE STACKING)
  (SELECTQ STACKING
    (:VERTICAL (MIN REM-HEIGHT HEIGHT))
    (:HORIZONTAL (MIN REM-WIDTH WIDTH))))

;These are obsolete, I guess
(DEFMETHOD (PANE-MIXIN :PANE-WIDTH) (&REST ARGS)
  (LEXPR-FUNCALL-SELF ':PANE-SIZE ARGS))
       
(DEFMETHOD (PANE-MIXIN :PANE-HEIGHT) (&REST ARGS)
  (LEXPR-FUNCALL-SELF ':PANE-SIZE ARGS))

(COMPILE-FLAVOR-METHODS LISP-LISTENER-PANE COMMAND-MENU-PANE
			BASIC-FRAME
			CONSTRAINT-FRAME-NO-FORWARDING
			CONSTRAINT-FRAME BORDERED-CONSTRAINT-FRAME
			CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER
			BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER)