;;; -*- Mode:Lisp; Package:TV; Base:8 -*-
;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;;; New menu system

;Documentation on menu item-lists:
;
;Each item in the item-list may be one of the following:
; 1. A string (or a symbol).  
; 2. Cons of a string (or a symbol) and an atom.
; 3. List of a string (or a symbol) and any object.  The list may
;    not be more than 2 long.
; 4. List of a string (or a symbol), a flavor keyword, and an argument.
;    After the first 3 elements of the list, the rest of the list is
;    a property list of modifier keywords and values.
;The string (or symbol) is displayed in the menu to represent this item.
;The value returned by the :CHOOSE method is the item in case 1, the cdr
;in case 2, the cadr in case 3, and varies in case 4 depending on the flavor.
;Case 4 menu items can also have side-effects.
;The following are the permissible flavor keywords:
;		:VALUE - argument is returned by the :CHOOSE method
;		:EVAL - argument is evaluated then returned
;		:FUNCALL - argument is a function of no args to be called
;		:NO-SELECT - this item cannot be selected
;		:WINDOW-OP - argument is a function of one argument.  This
;			argument is a list of window, mouse-x, mouse-y as they
;			were before the menu popped up.
;		:KBD - argument is forced into keyboard input of appropriate process.
;		:MENU - argument is a new menu to choose from.
;		:BUTTONS - argument is 3 items, which one is used depends on
;			which mouse button was clicked
;The following are the known modifier keywords:
;		:FONT - the font in which to display the item
;		:DOCUMENTATION - a string documenting this item
;This stuff is largely although not entirely controlled by the :EXECUTE method,
;which you may redefine.

;;; These special variables exist so that there are less random numbers
;;; in the code, giving somewhat more chance of understanding it.
;;; You might even want to change them.
(DEFVAR MENU-INTERWORD-SPACING 27.)	;For fill mode.  3 characters in MEDFNT
(DEFVAR MENU-INTERCOLUMN-SPACING 10.)	;For column mode.
(DEFVAR MENU-FILL-BREAKAGE 60.)
(DEFVAR MENU-GOLDEN-RATIO 1.6s0)

(DEFFLAVOR BASIC-MENU
	   (ITEM-LIST			;List of items being displayed.
	    CURRENT-ITEM		;Item being pointed at now.
	    LAST-ITEM			;The last item to have been selected.
	    (CHOSEN-ITEM NIL)		;The same, but it's ok to set this to NIL
					;and wait for it to become non-NIL.
	    SCREEN-ROWS			;Number of rows in menu on screen
	    TOTAL-ROWS			;Total number of rows in menu.
					;If this is greater than SCREEN-ROWS, then the latter
					;represent a window on all the rows.
	    TOP-ROW			;This is first row visible now.
	    ROW-HEIGHT			;Height in dots of a row (including vsp).
	    ROW-MAP			;Array of tails of ITEM-LIST.  For each row
					;in the menu, points to first item on that row.
					;An extra element at the end is NIL.
					;The length is thus (1+ TOTAL-ROWS).
	    (COLUMNS NIL)		;Number of columns (NIL in fill mode).
	    COLUMN-WIDTH		;Width in dots of a column (NIL in fill mode).

	    ;; GEOMETRY is the user specified geometry.  It is a list of:
	    ;; Number of columns or 0 if FILL-P, number of rows, inside width, inside height,
	    ;; maximum width, maximum height.  NIL means it's free to change, as was not
	    ;; explicitly specified by the user.  Default is to leave everything free.
	    (GEOMETRY
	     (LIST NIL NIL NIL NIL NIL NIL))
	    (SET-EDGES-MODE NIL)	;Looked at by :CHANGE-OF-SIZE-OR-MARGINS method
					;NIL means not via SET-EDGES (margin changing, for
					; example)
					;T means via an internal call from the menu system
					;USER means from a user's :SET-EDGES
					;Any other means to recompute parameters, but don't
					; be sticky with respect to new sizes
	   )
	   (MENU-EXECUTE-MIXIN)
  (:REQUIRED-FLAVORS BASIC-SCROLL-BAR)	;Position in component list decided at higher level
  (:GETTABLE-INSTANCE-VARIABLES ITEM-LIST CURRENT-ITEM LAST-ITEM CHOSEN-ITEM GEOMETRY)
  (:SETTABLE-INSTANCE-VARIABLES LAST-ITEM CHOSEN-ITEM)
  (:INITABLE-INSTANCE-VARIABLES ITEM-LIST)
  (:INIT-KEYWORDS :ROWS :COLUMNS :FILL-P :GEOMETRY :DEFAULT-FONT)  ;Set parts of geometry
  (:DEFAULT-INIT-PLIST :BLINKER-FLAVOR 'TV:HOLLOW-RECTANGULAR-BLINKER)
  (:DOCUMENTATION :MIXIN "Regular menu messages
Provides methods and instance variables common to all menus, such as the item-list,
the geometry hacking, a default :choose message, and a scroll bar if necessary."))

(DEFSTRUCT (GEOMETRY :LIST (:CONSTRUCTOR NIL))
  GEOMETRY-N-COLUMNS
  GEOMETRY-N-ROWS
  GEOMETRY-INSIDE-WIDTH
  GEOMETRY-INSIDE-HEIGHT
  GEOMETRY-MAX-WIDTH
  GEOMETRY-MAX-HEIGHT)

(DEFMACRO GEOMETRY-FILL-P (GEO) `(AND (GEOMETRY-N-COLUMNS ,GEO)
				      (ZEROP (GEOMETRY-N-COLUMNS ,GEO))))

(EVAL-WHEN (COMPILE LOAD EVAL)
(DEFPROP GEOMETRY-FILL-P
	 ((GEOMETRY-FILL-P GEO) . (SETF (GEOMETRY-N-COLUMNS GEO) (IF SI:VAL 0 NIL)))
	 SETF))

(DEFFLAVOR MENU ((LABEL NIL))
		(BASIC-MENU BORDERS-MIXIN TOP-BOX-LABEL-MIXIN BASIC-SCROLL-BAR MINIMUM-WINDOW)
  (:DOCUMENTATION :COMBINATION "The simplest instantiatable menu.
Defaults to not having a label, a label whose position is not initially specified will
be at the top, in a small auxiliary box, unlike most windows."))

(DEFFLAVOR POP-UP-MENU () (TEMPORARY-WINDOW-MIXIN MENU)
  (:DOCUMENTATION :COMBINATION "A menu that is temporary
This is not a momentary menu, it must be exposed and deexposed normally, it does save
the state beneath itself when exposed."))

(DEFMETHOD (SCREEN :MENU-FONT) () (FUNCALL-SELF ':PARSE-FONT-DESCRIPTOR 'FONTS:MEDFNT))

(DEFMETHOD (BASIC-MENU :BEFORE :INIT) (INIT-PLIST &AUX (SUP SUPERIOR) TEM)
  (SETQ SUP (OR SUP (GET INIT-PLIST ':SUPERIOR) DEFAULT-SCREEN))
  (OR (BOUNDP 'FONT-MAP)
      (SETQ FONT-MAP
	    (MENU-COMPUTE-FONT-MAP (GET INIT-PLIST ':ITEM-LIST)
				   (OR (GET INIT-PLIST ':DEFAULT-FONT)
				       (FUNCALL (SHEET-GET-SCREEN SUP) ':MENU-FONT)))))
  (PUTPROP INIT-PLIST NIL ':MORE-P)
  (SETQ TEM (GET INIT-PLIST ':GEOMETRY))
  (IF (> (LENGTH TEM) (LENGTH GEOMETRY))
      ;; Longer than we need, take a copy of the list
      (SETQ GEOMETRY (COPYLIST TEM))
      ;; Else copy the appropriate piece of user specified list into our list
      (DO ((TEM TEM (CDR TEM))
	   (GEO GEOMETRY (CDR GEO)))
	  ((NULL TEM))
	(SETF (CAR GEO) (CAR TEM))))
  (AND (GET INIT-PLIST ':FILL-P)
       ;(SETF (GEOMETRY-FILL-P GEOMETRY) T)  ;Compiler gives a gratuitous warning for this
       (SETF (GEOMETRY-N-COLUMNS GEOMETRY) 0))
  (AND (SETQ TEM (GET INIT-PLIST ':ROWS))
       (SETF (GEOMETRY-N-ROWS GEOMETRY) TEM))
  (AND (SETQ TEM (GET INIT-PLIST ':COLUMNS))
       (SETF (GEOMETRY-N-COLUMNS GEOMETRY) TEM))
  ;; We'll handle SAVE-BITS ourselves later
  ;; This is so the bit array doesn't get created until we know the size
  (PUTPROP INIT-PLIST (GET INIT-PLIST ':SAVE-BITS) ':MENU-SAVE-BITS)
  (PUTPROP INIT-PLIST NIL ':SAVE-BITS))

(DEFMETHOD (BASIC-MENU :AFTER :INIT) (INIT-PLIST)
  (SETF (BLINKER-VISIBILITY (CAR BLINKER-LIST)) NIL)
  (MENU-COMPUTE-GEOMETRY NIL)
  (FUNCALL-SELF ':SET-SAVE-BITS (GET INIT-PLIST ':MENU-SAVE-BITS)))

(DEFMETHOD (BASIC-MENU :AFTER :REFRESH) (&OPTIONAL TYPE)
  (OR (AND RESTORED-BITS-P (NEQ TYPE ':SIZE-CHANGED))
      (FUNCALL-SELF ':MENU-DRAW)))

(DEFMETHOD (BASIC-MENU :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)
  (COND ((EQ SET-EDGES-MODE T))  ;Recursive call, caller will take care of it
	((EQ SET-EDGES-MODE ':USER)
	 ;; Some sort of explicit setting of edges -- make the new size sticky
	 (SETF (GEOMETRY-INSIDE-WIDTH GEOMETRY) (SHEET-INSIDE-WIDTH))
	 (SETF (GEOMETRY-INSIDE-HEIGHT GEOMETRY) (SHEET-INSIDE-HEIGHT))
	 (MENU-COMPUTE-GEOMETRY NIL))
	((EQ SET-EDGES-MODE NIL)
	 (MENU-COMPUTE-GEOMETRY NIL))
	(T
	 ;; Some change other than by user or margins or compute geometry -- recompute
	 ;; geometry, use current size, but don't make it sticky.
	 ;; E.g. :MOVE-NEAR-WINDOW
	 (MENU-COMPUTE-GEOMETRY NIL (SHEET-INSIDE-WIDTH) (SHEET-INSIDE-HEIGHT)))))

(DEFWRAPPER (BASIC-MENU :SET-EDGES) (IGNORE . BODY)
  `(LET-GLOBALLY ((SET-EDGES-MODE (OR SET-EDGES-MODE ':USER)))
     . ,BODY))

(DEFMETHOD (BASIC-MENU :SET-ITEM-LIST) (NEW-ITEM-LIST)
  (SETQ ITEM-LIST NEW-ITEM-LIST
	LAST-ITEM NIL
	CURRENT-ITEM NIL)
  (FUNCALL-SELF ':SET-FONT-MAP (MENU-COMPUTE-FONT-MAP NEW-ITEM-LIST))
  (MENU-COMPUTE-GEOMETRY T)		;Recompute parameters, and redraw menu
  NEW-ITEM-LIST)

(DEFMETHOD (BASIC-MENU :SET-DEFAULT-FONT) (FONT)
  (FUNCALL-SELF ':SET-FONT-MAP (MENU-COMPUTE-FONT-MAP ITEM-LIST FONT))
  (MENU-COMPUTE-GEOMETRY T))

(DEFMETHOD (BASIC-MENU :SET-GEOMETRY) (&REST NEW-GEOMETRY)
  (DECLARE (ARGLIST (&OPTIONAL N-COLUMNS N-ROWS INSIDE-WIDTH INSIDE-HEIGHT
			       MAX-WIDTH MAX-HEIGHT)))
  "NIL for an argument means make it unconstrained.  T or unsupplied means leave it alone"
  (OR ( (LENGTH NEW-GEOMETRY) (LENGTH GEOMETRY))
      (FERROR NIL "Too many args to :SET-GEOMETRY"))
  (DO ((G NEW-GEOMETRY (CDR G))
       (CG GEOMETRY (CDR CG)))
      ((NULL G))
    (IF (NEQ (CAR G) T)
	(RPLACA CG (CAR G))))
  (MENU-COMPUTE-GEOMETRY T))

(DEFMETHOD (BASIC-MENU :CURRENT-GEOMETRY) ()
  "Like :GEOMETRY but returns the current state rather than the default"
  (LIST (IF (GEOMETRY-FILL-P GEOMETRY) 0 COLUMNS) TOTAL-ROWS
	(SHEET-INSIDE-WIDTH) (SHEET-INSIDE-HEIGHT)
	(GEOMETRY-MAX-WIDTH GEOMETRY) (GEOMETRY-MAX-HEIGHT GEOMETRY)))

(DEFMETHOD (BASIC-MENU :FILL-P) () (GEOMETRY-FILL-P GEOMETRY))
(DEFMETHOD (BASIC-MENU :SET-FILL-P) (FILL-P)
  (FUNCALL-SELF ':SET-GEOMETRY (IF FILL-P 0 NIL)))

(DEFMETHOD (BASIC-MENU :MOUSE-STANDARD-BLINKER) ()
  ;; Change the mouse cursor to a small X so it doesn't get in the way
  (MOUSE-SET-BLINKER-DEFINITION ':CHARACTER 4 5 ':ON
				':SET-CHARACTER 7))

;;; Mouse handler for menus
(DEFMETHOD (BASIC-MENU :BEFORE :HANDLE-MOUSE) ()
  ;; Forget anything we knew before about the highlight, so it will really be positioned
  (SETQ CURRENT-ITEM NIL))

(DEFMETHOD (BASIC-MENU :AFTER :HANDLE-MOUSE) ()
  ;; When mouse leaves this window, stop flashing any item
  (BLINKER-SET-VISIBILITY (CAR BLINKER-LIST) NIL))

;;; Mouse-click handler for menus.
;;; All buttons are treated the same, select the item you are on.
;;; There are no double-clicks and you can't get to the system command menu.
;;; Clicking when the menu is not exposed just exposes it.

(DEFMETHOD (BASIC-MENU :MOUSE-BUTTONS) (BD X Y)
  BD X Y ;ignored, we don't care where the mouse is, the :MOUSE-MOVES method took care of that
  (COND (CURRENT-ITEM				;Any button, select item.
	  (SETQ LAST-ITEM CURRENT-ITEM
		CHOSEN-ITEM CURRENT-ITEM)
	  (COND ((AND (LISTP CHOSEN-ITEM)
		      ( (LENGTH CHOSEN-ITEM) 3)
		      (EQ (SECOND CHOSEN-ITEM) ':BUTTONS))
		 (SETQ CHOSEN-ITEM (NTH (1- (HAULONG BD)) (THIRD CHOSEN-ITEM))))))
	((AND ( X (SHEET-INSIDE-LEFT)) (< X (SHEET-INSIDE-RIGHT))
	      ( Y (SHEET-INSIDE-TOP)) (< Y (SHEET-INSIDE-BOTTOM))))
	(T
	 ;; Here, clicked on the window, but outside of the window proper.
	 ;; Send a :MOUSE-CLICK message so things like margin regions can work.
	 (FUNCALL-SELF ':MOUSE-CLICK BD X Y))))

(DEFMETHOD (BASIC-MENU :MOUSE-CLICK) (BD X Y)
  ;; If we get to here, punt: default action is to do nothing
  BD X Y
  T)

(DEFMETHOD (BASIC-MENU :CHOOSE) ()
  (SETQ CHOSEN-ITEM NIL)
  (OR EXPOSED-P (FUNCALL-SELF ':EXPOSE))
  (PROCESS-WAIT "Menu choose" #'(LAMBDA (ITEM-LOC STATUS-LOC)
				  (OR (CAR ITEM-LOC) (NULL (CAR STATUS-LOC))))
		(LOCATE-IN-INSTANCE SELF 'CHOSEN-ITEM)
		(LOCF (SHEET-EXPOSED-P SELF)))
  (PROG1 (FUNCALL-SELF ':EXECUTE CHOSEN-ITEM)
	 (SETQ CHOSEN-ITEM NIL)))

;;; These understand the mapping between an item and its printed representation
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MENU)
(DEFUN MENU-ITEM-STRING (ITEM &AUX STRING FONT)
  (DECLARE (RETURN-LIST STRING FONT))
  (IF (ATOM ITEM)
      (SETQ STRING ITEM)
      (SETQ STRING (CAR ITEM))
      (AND (LISTP (CDR ITEM))
	   (SETQ FONT (GET (CDDR ITEM) ':FONT))))
  (COND ((NULL FONT) (SETQ FONT CURRENT-FONT))
	((SYMBOLP FONT)
	 (SETQ FONT (FUNCALL (SHEET-GET-SCREEN SELF) ':PARSE-FONT-DESCRIPTOR FONT)))
	((NUMBERP FONT) (SETQ FONT (AREF FONT-MAP FONT))))
  (VALUES (STRING STRING) FONT)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MENU)
(DEFUN MENU-ITEM-STRING-WIDTH (ITEM &OPTIONAL STOP-X)
  (MULTIPLE-VALUE-BIND (STRING FONT)
      (MENU-ITEM-STRING ITEM)
    (SHEET-STRING-LENGTH SELF STRING 0 NIL STOP-X FONT))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MENU)
(DEFUN MENU-COMPUTE-FONT-MAP (ITEMS &OPTIONAL (DEFAULT CURRENT-FONT)
			            &AUX (MAP (NCONS DEFAULT)) FONT)
  (DOLIST (ITEM ITEMS)
    (SETQ FONT (AND (LISTP ITEM)
		    (LISTP (CDR ITEM))
		    (GET (CDDR ITEM) ':FONT)))
    (AND FONT (NOT (MEMQ FONT MAP))
	 (PUSH FONT MAP)))
  (NREVERSE MAP)))

;;; This is called from the scheduler
(DEFMETHOD (BASIC-MENU :WHO-LINE-DOCUMENTATION-STRING) ()
  (AND (BOUNDP 'CURRENT-ITEM) (MENU-ITEM-WHO-LINE-DOCUMENTATION CURRENT-ITEM)))

(DEFUN MENU-ITEM-WHO-LINE-DOCUMENTATION (ITEM)
  (AND (LISTP ITEM) (LISTP (CDR ITEM))
       (GET (CDDR ITEM) ':DOCUMENTATION)))

;;; This is the guts.  Given a menu and a set of coordinates, it finds
;;; the corresponding item, if any, sets CURRENT-ITEM to it, and sets up
;;; the blinker to mark that item.  If no item, the blinker is shut off.
;;;*** This tvobish code should be rewritten ***
(DEFMETHOD (BASIC-MENU :MOUSE-MOVES) (X Y
				      &AUX ITEM ITEMS ROW XREL BLINKER BLX (BLWIDTH 0)
				           COLN STOP-ITEM
					   (FILL-P (GEOMETRY-FILL-P GEOMETRY)))
  (MOUSE-SET-BLINKER-CURSORPOS)
  (SETQ ROW (// (- Y (SHEET-INSIDE-TOP)) ROW-HEIGHT)
	XREL (- X (SHEET-INSIDE-LEFT))
	BLINKER (CAR BLINKER-LIST))
  (COND ((AND ( XREL 0)	;If inside the menu
	      (< X (SHEET-INSIDE-RIGHT))
	      ( Y (SHEET-INSIDE-TOP))
	      (< Y (SHEET-INSIDE-BOTTOM)))
	 ;;If mouse is past the last displayed row, blink item on that row.
	 (AND (OR (>= (+ TOP-ROW ROW) TOTAL-ROWS) (>= ROW SCREEN-ROWS))
	      (SETQ ROW (1- (MIN SCREEN-ROWS (- TOTAL-ROWS TOP-ROW)))))
	 (IF (MINUSP ROW) (SETQ ITEMS NIL STOP-ITEM NIL)	;No items visible
	     (SETQ ITEMS (AREF ROW-MAP (+ TOP-ROW ROW))
		   STOP-ITEM (AREF ROW-MAP (+ TOP-ROW ROW 1))))
	 (COND (FILL-P				;Fill mode, cogitate
		(SETQ BLX 0)
		(DO ((L ITEMS (CDR L))
		     (ITM) (OITM NIL ITM)
		     (X 0 (+ X
			     (SETQ BLWIDTH (MENU-ITEM-STRING-WIDTH ITM))
			     MENU-INTERWORD-SPACING)))
		    ((OR (NULL L)
			 (> X XREL))	    ;If this string crosses the mouse, it's the one
		     (SETQ ITEM OITM
			   BLX (1- BLX)
			   BLWIDTH (+ BLWIDTH 1)))
		  (AND (EQ L STOP-ITEM)
		       ;; The next item on next line -- punt
		       (RETURN NIL))
		  (SETQ ITM (CAR L)
			BLX X)))
	       (T				;Columnated, find which column
		(SETQ COLN (// XREL COLUMN-WIDTH))	;Column selected
		(SETQ ITEM (CAR (NTHCDR COLN ITEMS)))	;This may be NIL
		(SETQ BLWIDTH (1+ (MENU-ITEM-STRING-WIDTH ITEM COLUMN-WIDTH)))
		(SETQ BLX (+ (* COLN COLUMN-WIDTH)	;Start of column
			     -1
			     (MAX 0 (// (- COLUMN-WIDTH	;Centering
					   MENU-INTERCOLUMN-SPACING
					   BLWIDTH)
					2))))))))
  ;; If this item is non-selectable, don't select it.
  (AND (NOT (ATOM ITEM)) (NOT (ATOM (CDR ITEM))) (NOT (ATOM (CDDR ITEM)))
       (EQ (CADR ITEM) ':NO-SELECT)
       (SETQ ITEM NIL))
  ;; Now make the blinker be where and what we have just found it should be.
  (BLINKER-SET-VISIBILITY BLINKER (NOT (NULL ITEM)))
  (SETQ CURRENT-ITEM ITEM)
  (COND (ITEM
	 (FUNCALL BLINKER ':SET-SIZE-AND-CURSORPOS 
		  BLWIDTH (+ (FONT-CHAR-HEIGHT (AREF FONT-MAP 0)) 2)
		  BLX (1- (* ROW ROW-HEIGHT))))))

(DEFMETHOD (BASIC-MENU :SCROLL-POSITION) ()
  (VALUES TOP-ROW TOTAL-ROWS ROW-HEIGHT))

(DEFMETHOD (BASIC-MENU :SCROLL-TO) (LINE MODE)
  (SELECTQ MODE
    (:ABSOLUTE)
    (:RELATIVE (SETQ LINE (+ TOP-ROW LINE)))
    (OTHERWISE (FERROR NIL "Illegal scroll mode ~A" MODE)))
  (COND (( (SETQ LINE (MAX 0 (MIN LINE (1- TOTAL-ROWS)))) TOP-ROW)
	 ;; Actually changing something, update
	 (SETQ TOP-ROW LINE)
	 (FUNCALL-SELF ':MENU-DRAW)
	 (FUNCALL-SELF ':NEW-SCROLL-POSITION TOP-ROW))))

;;; Put a menu near another window.  This will normally try to put it just below
;;; it and give it the same width.
(DEFMETHOD (BASIC-MENU :MOVE-NEAR-WINDOW) (W)
  (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
      (FUNCALL W ':EDGES)
    (MULTIPLE-VALUE-BIND (IGNORE IGNORE IGNORE NEW-HEIGHT)
	(MENU-DEDUCE-PARAMETERS NIL NIL (- RIGHT LEFT) NIL NIL NIL)
      (SETQ NEW-HEIGHT (+ NEW-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
      ;If it won't fit below try putting it above
      (AND (> (+ BOTTOM NEW-HEIGHT)
	      (SHEET-INSIDE-BOTTOM SUPERIOR))
	   (SETQ BOTTOM (MAX (- TOP NEW-HEIGHT) 0)))
      ;Put it there
      (LET-GLOBALLY ((SET-EDGES-MODE ':MOVE-NEAR))
	(FUNCALL-SELF ':SET-EDGES LEFT BOTTOM RIGHT (+ BOTTOM NEW-HEIGHT)))
      (FUNCALL-SELF ':EXPOSE))))

;;; This is used by othogonal things like hysteretic window
(DEFMETHOD (BASIC-MENU :SCROLL-BAR-P) () (< SCREEN-ROWS TOTAL-ROWS))

;;; MENU-EXECUTE-MIXIN flavor processes a menu-like item

(DEFFLAVOR MENU-EXECUTE-MIXIN () ()
  (:DOCUMENTATION :MIXIN "Processes a menu-like item
This is a part of every menu, it is a separate flavor so that it can be included in other
things which want to act like menus with regard to the format of an item passed to a
:execute message.  This message is what handles most of the interpretation of the
item-list instance variable."))

;;; Decide what to return based on the item selected.  Also have side-effects
;;; such as calling a function if the item says to.
(DEFMETHOD (MENU-EXECUTE-MIXIN :EXECUTE) (ITEM &AUX OP ARG)
  (COND ((ATOM ITEM) ITEM)
	((ATOM (CDR ITEM)) (CDR ITEM))
	((ATOM (CDDR ITEM)) (CADR ITEM))
	((EQ (SETQ ARG (CADDR ITEM)
		   OP (CADR ITEM))
	     ':VALUE)
	 ARG)
	((EQ OP ':EVAL) (EVAL ARG))
	((EQ OP ':FUNCALL) (FUNCALL ARG))
	((EQ OP ':WINDOW-OP) (FUNCALL-SELF ':EXECUTE-WINDOW-OP ARG))
	((EQ OP ':KBD) (AND SELECTED-WINDOW (FUNCALL SELECTED-WINDOW ':FORCE-KBD-INPUT ARG)))
	((EQ OP ':MENU) (FUNCALL (IF (SYMBOLP ARG) (SYMEVAL ARG) ARG) ':CHOOSE))
	(T (FERROR NIL "~S is unknown operation for :EXECUTE" OP))))

;Same as above but returns NIL if getting the value would require side-effects.
;This is used by MENU-HIGHLIGHTING-MIXIN
(DEFMETHOD (MENU-EXECUTE-MIXIN :EXECUTE-NO-SIDE-EFFECTS) (ITEM)
  (MENU-EXECUTE-NO-SIDE-EFFECTS ITEM))

(DEFUN MENU-EXECUTE-NO-SIDE-EFFECTS (ITEM &AUX OP ARG)
  (COND ((ATOM ITEM) ITEM)
	((ATOM (CDR ITEM)) (CDR ITEM))
	((ATOM (CDDR ITEM)) (CADR ITEM))
	((EQ (SETQ ARG (CADDR ITEM)
		   OP (CADR ITEM))
	     ':VALUE)
	 ARG)
	(T NIL)))

(DEFMETHOD (MENU-EXECUTE-MIXIN :EXECUTE-WINDOW-OP) (FUNCTION) (FUNCALL FUNCTION))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MENU)
(DEFUN MENU-COMPUTE-GEOMETRY (DRAW-P &OPTIONAL INSIDE-WIDTH INSIDE-HEIGHT)
  "This function is called whenever something related to the geometry changes.  The menu
is redrawn if DRAW-P is T."
  (COND ((BOUNDP 'ITEM-LIST)  ;Do nothing if item-list not specified yet
	 ;; Get the new N-ROWS and so forth.
	 (MULTIPLE-VALUE (COLUMNS SCREEN-ROWS INSIDE-WIDTH INSIDE-HEIGHT)
	   (MENU-DEDUCE-PARAMETERS NIL NIL INSIDE-WIDTH INSIDE-HEIGHT NIL NIL))
	 ;; Recompute the row map
	 (MULTIPLE-VALUE (ROW-MAP TOTAL-ROWS)
	   (MENU-COMPUTE-ROW-MAP INSIDE-WIDTH))
	 (SETQ TOP-ROW 0
	       ROW-HEIGHT LINE-HEIGHT)
	 (FUNCALL-SELF ':NEW-SCROLL-POSITION TOP-ROW)
	 (SETQ COLUMN-WIDTH
	       (AND (NOT (GEOMETRY-FILL-P GEOMETRY))
		    (// (+ INSIDE-WIDTH MENU-INTERCOLUMN-SPACING) COLUMNS)))
	 (COND ((AND (= INSIDE-HEIGHT (SHEET-INSIDE-HEIGHT))
		     (= INSIDE-WIDTH (SHEET-INSIDE-WIDTH)))
		(AND DRAW-P
		     (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
		       (FUNCALL-SELF ':MENU-DRAW))))
	       ((FUNCALL-SELF ':SET-INSIDE-SIZE INSIDE-WIDTH INSIDE-HEIGHT ':VERIFY)
		;; Room to do this in current place.
		(LET-GLOBALLY ((SET-EDGES-MODE T))
		  (FUNCALL-SELF ':SET-INSIDE-SIZE INSIDE-WIDTH INSIDE-HEIGHT)))
	       (T
		;; Else try to be approximately in the same place
		(LET ((CX (+ X-OFFSET (// WIDTH 2)))
		      (CY (+ Y-OFFSET (// HEIGHT 2))))
		  (WITH-SHEET-DEEXPOSED (SELF)
		    (LET-GLOBALLY ((SET-EDGES-MODE T))
		      (FUNCALL-SELF ':SET-INSIDE-SIZE INSIDE-WIDTH INSIDE-HEIGHT))
		    (CENTER-WINDOW-AROUND SELF CX CY)))))))
  NIL))

;;; This function, given a bunch of parameters some of which are NIL meaning
;;; unspecified, deduces the rest of the parameters from constraints.
;;; For parameters passed in as NIL, the corresponding element of GEOMETRY
;;; is used.

;;; First, compute the geometry
;;;  (1) The user has supplied the width and the number of columns or fill-p, nothing special.
;;;  (2) The user has supplied the width, we compute the number of columns
;;;             by finding the widest string in the item-list.
;;;  (3) The user has not supplied the width, but has supplied n-columns, we compute width
;;;             again by finding the widest string in the item-list.
;;;  (4) The user has supplied neither width nor n-columns.
;;;    (4a) The user has, however, supplied height or n-rows, so we pick a suitable width
;;;         to make the entire menu come out to n-rows, depending on fill mode.  Then if
;;;         it doesn't fit, this width will be wider than the screen, and will be limited.
;;;    (4b) The user has supplied no geometry, it's up to us.
;;;         Compute the total width depending on fill-mode, then pick n-rows and
;;;         n-columns to make this a square array.  Then limit each to the available
;;;         area of the screen, in case the menu is too big to fit.
;;;	    Not actually square but the prettiest looking shape.

;;; Once the horizontal business has been straightened out, if we don't have the
;;; height already, we pick a height to make it all fit on the screen, and limit that
;;; if it is too big.  Note that fill-mode has a line-breakage problem, which will
;;; need to be solved here (may change shape "slightly" from square.)

;;; Arguments:
;;; SELF, ITEM-LIST and GEOMETRY are used freely.
;;; SELF should have the right font, screen, vsp but not
;;;	  yet the right dimensions and location.
;;; NEW-LEFT, etc. are the boundaries of the area actually available for use.
;;;  Any margins have already been excluded.

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MENU)
(DEFUN MENU-DEDUCE-PARAMETERS (N-COLUMNS N-ROWS INSIDE-WIDTH INSIDE-HEIGHT
			       MAX-WIDTH MAX-HEIGHT
			       &AUX TEM COLUMN-WIDTH ;NIL if N-COLUMNS not chosen in here
				    (N-ITEMS (LENGTH ITEM-LIST))
				    FILL-P)
  ;; Pick up default constraints from GEOMETRY
  (SETQ N-COLUMNS (OR N-COLUMNS (GEOMETRY-N-COLUMNS GEOMETRY))
	N-ROWS (OR N-ROWS (GEOMETRY-N-ROWS GEOMETRY))
	INSIDE-WIDTH (OR INSIDE-WIDTH (GEOMETRY-INSIDE-WIDTH GEOMETRY))
	INSIDE-HEIGHT (OR INSIDE-HEIGHT (GEOMETRY-INSIDE-HEIGHT GEOMETRY))
	MAX-WIDTH (OR MAX-WIDTH (GEOMETRY-MAX-WIDTH GEOMETRY))
	MAX-HEIGHT (OR MAX-HEIGHT (GEOMETRY-MAX-HEIGHT GEOMETRY)))
  ;; If any of the arguments was :UNCONSTRAINED, that means use NIL
  ;; even if the geometry is non-NIL, whereas if an argument was NIL
  ;; that means use any constraint that is in the geometry.
  (AND (EQ N-COLUMNS ':UNCONSTRAINED) (SETQ N-COLUMNS NIL))
  (AND (EQ N-ROWS ':UNCONSTRAINED) (SETQ N-ROWS NIL))
  (AND (EQ INSIDE-WIDTH ':UNCONSTRAINED) (SETQ INSIDE-WIDTH NIL))
  (AND (EQ INSIDE-HEIGHT ':UNCONSTRAINED) (SETQ INSIDE-HEIGHT NIL))
  (AND (EQ MAX-WIDTH ':UNCONSTRAINED) (SETQ MAX-WIDTH NIL))
  (AND (EQ MAX-HEIGHT ':UNCONSTRAINED) (SETQ MAX-HEIGHT NIL))
  ;; Decide whether it is fill mode or array mode
  (AND (SETQ FILL-P (AND N-COLUMNS (ZEROP N-COLUMNS)))
       (SETQ N-COLUMNS NIL))

  ;; Realize any immediately clear implications
  (AND N-ROWS (NULL INSIDE-HEIGHT) (SETQ INSIDE-HEIGHT (* N-ROWS LINE-HEIGHT)))
  (AND INSIDE-HEIGHT (NULL N-ROWS) (SETQ N-ROWS (// INSIDE-HEIGHT LINE-HEIGHT)))
  (SETQ MAX-HEIGHT (MIN (OR INSIDE-HEIGHT MAX-HEIGHT 10000)
			(- (SHEET-INSIDE-HEIGHT SUPERIOR) TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
	MAX-WIDTH (MIN (OR INSIDE-WIDTH MAX-WIDTH 10000)
		       (- (SHEET-INSIDE-WIDTH SUPERIOR) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))

  ;; Compute the horizontal parameters.
  (COND ((AND INSIDE-WIDTH (OR N-COLUMNS FILL-P)) )		;It's fully-determined
	(INSIDE-WIDTH		;We have the width, and it's not in fill mode, compute
	 (SETQ N-COLUMNS	; N-COLUMNS based on widest item, but always fill the space
	       (MAX (MIN (// (+ INSIDE-WIDTH MENU-INTERCOLUMN-SPACING)
			     (+ (MENU-MAX-WIDTH ITEM-LIST) MENU-INTERCOLUMN-SPACING))
			 (IF N-ROWS (// (+ N-ITEMS (1- N-ROWS)) N-ROWS) N-ITEMS))
		    1)))
	(N-COLUMNS  ;We don't have the width, but do know how many columns, compute width
	 (SETQ INSIDE-WIDTH (MIN (- (* (+ (MENU-MAX-WIDTH ITEM-LIST)
					  MENU-INTERCOLUMN-SPACING)
				       N-COLUMNS)
				    MENU-INTERCOLUMN-SPACING)
				 MAX-WIDTH)))
	(N-ROWS  ;We know how high, make it wide enough to come out this high
	 (IF FILL-P
	     (SETQ INSIDE-WIDTH (MIN (// (+ (MENU-FILL-WIDTH ITEM-LIST)
					    (1- N-ROWS))
					 N-ROWS)
				     MAX-WIDTH))
	     (SETQ N-COLUMNS (MAX (// (+ N-ITEMS (1- N-ROWS)) N-ROWS) 1)
		   INSIDE-WIDTH (- (* (SETQ COLUMN-WIDTH (+ (MENU-MAX-WIDTH ITEM-LIST)
							    MENU-INTERCOLUMN-SPACING))
				      N-COLUMNS)
				   MENU-INTERCOLUMN-SPACING))))
	((NOT FILL-P) ;No geometry supplied, pick N-ROWS and N-COLUMNS to make it look nice
		      ;Use the largest number of columns which does not make the ratio
		      ;of height to width less than the Golden ratio
	 (SETQ TEM (* (SETQ COLUMN-WIDTH (MENU-MAX-WIDTH ITEM-LIST))
                      N-ITEMS
                      LINE-HEIGHT)
	       COLUMN-WIDTH (+ COLUMN-WIDTH MENU-INTERCOLUMN-SPACING)
	       N-COLUMNS (MAX (// (ISQRT (FIX (// TEM MENU-GOLDEN-RATIO))) COLUMN-WIDTH) 1)
	       INSIDE-WIDTH (- (* COLUMN-WIDTH N-COLUMNS) MENU-INTERCOLUMN-SPACING)))
	(T	;No geometry supplied, and in fill mode, make it like above
	 (SETQ INSIDE-WIDTH (MAX (ISQRT (FIX (// (* (MENU-FILL-WIDTH ITEM-LIST)
						    LINE-HEIGHT)
						 MENU-GOLDEN-RATIO)))
				 40))))  ;Don't get zero, and don't get absurdly small

  ;; Now figure out the vertical characteristics
  (OR N-ROWS
      (SETQ N-ROWS (IF FILL-P 
		       (// (+ (MENU-FILL-WIDTH ITEM-LIST) INSIDE-WIDTH -1) INSIDE-WIDTH)
		       (// (+ N-ITEMS N-COLUMNS -1) N-COLUMNS))))
  (OR INSIDE-HEIGHT (SETQ INSIDE-HEIGHT (* N-ROWS LINE-HEIGHT)))

  ;; If there is a label, the menu must be at least wide enough to accomodate it
  (LET ((L (GET-HANDLER-FOR SELF ':LABEL-SIZE)))
    (AND L (SETQ L (FUNCALL L ':LABEL-SIZE))
	 (SETQ INSIDE-WIDTH (MAX INSIDE-WIDTH L))))

  ;; If this came out too high or too wide, retrench
  (AND (> INSIDE-HEIGHT MAX-HEIGHT)
       (SETQ N-ROWS (// MAX-HEIGHT LINE-HEIGHT)
	     INSIDE-HEIGHT (* N-ROWS LINE-HEIGHT)))
  (COND ((> INSIDE-WIDTH MAX-WIDTH)
	 (SETQ INSIDE-WIDTH MAX-WIDTH)
	 (AND COLUMN-WIDTH  ;If N-COLUMNS was not user-supplied, recompute it
	      (SETQ N-COLUMNS (MAX (// (+ INSIDE-WIDTH MENU-INTERCOLUMN-SPACING)
				       COLUMN-WIDTH)
				   1)))))

  ;; At this point, INSIDE-WIDTH, INSIDE-HEIGHT, N-COLUMNS (if not FILL-P), and N-ROWS
  ;; are all valid and consistent, and not bigger than the available area,
  ;; provided that the user's original parameters were not illegally huge.

  ;; Return all the dependent parameters as multiple values
  (VALUES (IF FILL-P 0 N-COLUMNS) N-ROWS INSIDE-WIDTH INSIDE-HEIGHT))
)

;;; This function computes the ROW-MAP, which determines how many strings per line, & c.
;;; The first value is the row-map and the second is the n-total-rows
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MENU)
(DEFUN MENU-COMPUTE-ROW-MAP (&OPTIONAL (INSIDE-WIDTH (SHEET-INSIDE-WIDTH))
			     &AUX (MAP (MAKE-ARRAY NIL 'ART-Q
						   (1+ (LENGTH ITEM-LIST))))
				  WID
				  (FILL-P (GEOMETRY-FILL-P GEOMETRY)))
  (DO ((ITEMS ITEM-LIST) (ROW 0 (1+ ROW)))
      ((NULL ITEMS)
       (VALUES (ADJUST-ARRAY-SIZE MAP (1+ ROW))  ;Last element always contains NIL
	       ROW))
    (ASET ITEMS MAP ROW)	;This is where this row starts
    (IF FILL-P		;Fill mode, we have some hairy calculation to do
	(DO ((SPACE INSIDE-WIDTH))
	    ((NULL ITEMS))
	  (SETQ WID (MENU-ITEM-STRING-WIDTH (CAR ITEMS)))
	  (COND ((> WID SPACE)	;This one won't fit, break the line
		 (AND (> WID INSIDE-WIDTH)
		      (FERROR NIL "The item /"~A/" is too wide for this fill-mode menu"
			      (CAR ITEMS)))
		 (RETURN NIL)))
	  (SETQ SPACE (- SPACE (+ WID MENU-INTERWORD-SPACING))
		ITEMS (CDR ITEMS)))
	(SETQ ITEMS (NTHCDR COLUMNS ITEMS)))))
)

(DEFMETHOD (BASIC-MENU :MENU-DRAW) (&AUX (FILL-P (GEOMETRY-FILL-P GEOMETRY)))
  ;; Make sure the mouse knows we're changing
  (AND EXPOSED-P (MOUSE-WAKEUP))
  (PREPARE-SHEET (SELF)
    (SHEET-CLEAR SELF)
    (DO ((ROW TOP-ROW (1+ ROW))
	 (Y-POS 0 (+ Y-POS ROW-HEIGHT))
	 (LIM (MIN TOTAL-ROWS (+ TOP-ROW SCREEN-ROWS))))
	(( ROW LIM))
      (DO ((ITEMS (AREF ROW-MAP ROW) (CDR ITEMS))
	   (END-ITEM-LIST (AREF ROW-MAP (1+ ROW)))
	   (STR) (FONT) (FLAG)
	   (X-POS 0))
	  ((EQ ITEMS END-ITEM-LIST))
	 (MULTIPLE-VALUE (STR FONT)
	   (MENU-ITEM-STRING (CAR ITEMS)))
	 (UNWIND-PROTECT
	   (PROGN
	     (AND (SETQ FLAG (AND (NEQ FONT CURRENT-FONT) CURRENT-FONT))
		  (SHEET-SET-FONT SELF FONT))
	     (COND (FILL-P			;Filled, put string followed by spacing
		    (SHEET-SET-CURSORPOS SELF X-POS Y-POS)
		    (SHEET-STRING-OUT SELF STR)
		    (SETQ X-POS (+ (SHEET-READ-CURSORPOS SELF) MENU-INTERWORD-SPACING)))
		   (T				;Columnated, center text within column
		    (SHEET-DISPLAY-CENTERED-STRING SELF STR
						   X-POS
						   (- (SETQ X-POS (+ X-POS COLUMN-WIDTH))
						      MENU-INTERCOLUMN-SPACING)
						   Y-POS))))
	   (AND FLAG (SHEET-SET-FONT SELF FLAG)))))))

;;; This function, given a menu item-list, returns the maximum width
;;; of any string in it.  Normally you want to add an allowance for interword spacing.
(DEFUN MENU-MAX-WIDTH (ITEM-LIST)
  (DO ((L ITEM-LIST (CDR L))
       (MXW 1 (MAX MXW (MENU-ITEM-STRING-WIDTH (CAR L)))))
      ((NULL L) MXW)))

;;; This function, given a menu item-list, returns the estimated total width
;;; (product of WIDTH and N-ROWS, not counting borders) when the menu items
;;; are put in "fill mode" rather than in columns.  It is only an estimate
;;; because at this point we can't be sure about word breakage.
(DEFUN MENU-FILL-WIDTH (ITEM-LIST)
  (DO ((L ITEM-LIST (CDR L))
       (WID 0))
      ((NULL L) WID)
    (SETQ WID (+ WID (MENU-ITEM-STRING-WIDTH (CAR L)) MENU-FILL-BREAKAGE))))

;;; Here is how we make a menu appear with the last item chosen under the mouse.

;;; Return the x and y co-ordinates (inside the margins)
;;; of the center of the specified item, NIL if scrolled off display
(DEFMETHOD (BASIC-MENU :ITEM-CURSORPOS) (ITEM &AUX (ALEN (ARRAY-LENGTH ROW-MAP)))
  (DO ((ROW (1- (MIN (+ TOP-ROW SCREEN-ROWS)	;last row on screen
		     ALEN))			;last row that exists
	    (1- ROW)))
      ((< ROW TOP-ROW) NIL)
    (AND (MEMQ ITEM (AREF ROW-MAP ROW))
	 (OR (= ROW (1- ALEN)) (NOT (MEMQ ITEM (AREF ROW-MAP (1+ ROW)))))
	 (RETURN (IF (NOT (GEOMETRY-FILL-P GEOMETRY))
		     (+ (* (FIND-POSITION-IN-LIST ITEM (AREF ROW-MAP ROW)) COLUMN-WIDTH)
			(// COLUMN-WIDTH 2))
		     (DO ((L (AREF ROW-MAP ROW) (CDR L))
			  (XSTART 0 (+ XSTART SWIDTH MENU-INTERWORD-SPACING))
			  (SWIDTH))
			 (NIL)
		       (SETQ SWIDTH (MENU-ITEM-STRING-WIDTH (CAR L)))
		       (AND (EQ (CAR L) ITEM)
			    (RETURN (+ XSTART (// SWIDTH 2))))))
		 (+ (* (- ROW TOP-ROW) ROW-HEIGHT) (// ROW-HEIGHT 2))))))

;;; Return the left, top, right, bottom coordinates (inside the margins)
;;; of the rectangle enclosing the specified item, including one bit of
;;; margin all around, or NIL if scrolled off the display.
;;; Note that because of the one bit of margin, returned values can be outside
;;; the window.
(DEFMETHOD (BASIC-MENU :ITEM-RECTANGLE) (ITEM &AUX (X 0) SWIDTH (ALEN (ARRAY-LENGTH ROW-MAP)))
  (DO ((ROW (1- (MIN (+ TOP-ROW SCREEN-ROWS)	;last row on screen
		     ALEN))			;last row that exists
	    (1- ROW)))
      ((< ROW TOP-ROW) NIL)
    (COND ((AND (MEMQ ITEM (AREF ROW-MAP ROW))
		(OR (= ROW (1- ALEN)) (NOT (MEMQ ITEM (AREF ROW-MAP (1+ ROW))))))
	   (IF (NOT (GEOMETRY-FILL-P GEOMETRY))
	       (SETQ SWIDTH (MENU-ITEM-STRING-WIDTH ITEM COLUMN-WIDTH)
		     X (+ (* (FIND-POSITION-IN-LIST ITEM (AREF ROW-MAP ROW)) COLUMN-WIDTH)
			  (// (- COLUMN-WIDTH MENU-INTERCOLUMN-SPACING SWIDTH) 2)))
	       (DOLIST (IT (AREF ROW-MAP ROW))
		 (SETQ SWIDTH (MENU-ITEM-STRING-WIDTH IT))
		 (AND (EQ IT ITEM) (RETURN))
		 (SETQ X (+ X SWIDTH MENU-INTERWORD-SPACING))))
	   (RETURN (1- X) (1- (* (- ROW TOP-ROW) ROW-HEIGHT))
		   (+ X SWIDTH 1) (1- (* (1+ (- ROW TOP-ROW)) ROW-HEIGHT)))))))

;; When we move a menu to a spot, make it go so that the last item chosen
;; appears at that spot.
(DEFMETHOD (BASIC-MENU :CENTER-AROUND) (X Y &AUX (XI 0) (YI 0))
  (AND (BOUNDP 'LAST-ITEM)
       (MEMQ LAST-ITEM ITEM-LIST)
       ;; If we remember a previous choice,
       ;; let XI and YI get the offsets from that item to the center.
       (MULTIPLE-VALUE-BIND (X1 Y1)
	   (FUNCALL-SELF ':ITEM-CURSORPOS LAST-ITEM)
	 (AND X1 Y1
	      (SETQ XI (- (// WIDTH 2) X1 (SHEET-INSIDE-LEFT))
		    YI (- (// HEIGHT 2) Y1 (SHEET-INSIDE-TOP))))))
  (MULTIPLE-VALUE-BIND (X1 Y1)
      (CENTER-WINDOW-AROUND SELF (+ X XI) (+ Y YI))
    (VALUES (- X1 XI) (- Y1 YI))))

(DEFMETHOD (BASIC-MENU :COLUMN-ROW-SIZE) ()
  (VALUES COLUMN-WIDTH ROW-HEIGHT))

;; Permanent menus for giving "keyboard" commands from a menu alist
(DEFFLAVOR COMMAND-MENU-MIXIN (IO-BUFFER) ()
  (:INCLUDED-FLAVORS BASIC-MENU)
  (:SETTABLE-INSTANCE-VARIABLES IO-BUFFER))

(DEFMETHOD (COMMAND-MENU-MIXIN :AFTER :MOUSE-BUTTONS) (BD IGNORE IGNORE)
  (COND (CHOSEN-ITEM
	 (IO-BUFFER-PUT IO-BUFFER `(:MENU ,CHOSEN-ITEM ,BD ,SELF))
	 (SETQ CHOSEN-ITEM NIL))))

(DEFFLAVOR COMMAND-MENU () (COMMAND-MENU-MIXIN MENU))

(DEFFLAVOR COMMAND-MENU-ABORT-ON-DEEXPOSE-MIXIN () ()
  (:INCLUDED-FLAVORS COMMAND-MENU)
  (:DOCUMENTATION :MIXIN "Automatically clicks on the ABORT item if the menu is deexposed"))

(DEFMETHOD (COMMAND-MENU-ABORT-ON-DEEXPOSE-MIXIN :BEFORE :DEEXPOSE) (&REST IGNORE)
  (IF EXPOSED-P
      (DOLIST (ITEM ITEM-LIST)
	(IF (STRING-EQUAL (MENU-ITEM-STRING ITEM) "ABORT")
	    (RETURN (IO-BUFFER-PUT IO-BUFFER `(:MENU ,ITEM 1 ,SELF)))))))

(DEFFLAVOR MENU-HIGHLIGHTING-MIXIN ((HIGHLIGHTED-ITEMS NIL)) ()
  (:INCLUDED-FLAVORS TV:BASIC-MENU)
  (:GETTABLE-INSTANCE-VARIABLES HIGHLIGHTED-ITEMS)
  (:INITABLE-INSTANCE-VARIABLES HIGHLIGHTED-ITEMS)
  (:DOCUMENTATION :MIXIN "Provides for highlighting of items with inverse video"))

; This does not remember it on the list, you probably don't want to use it yourself
(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :HIGHLIGHT-ITEM) (ITEM)
  (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM) (FUNCALL-SELF ':ITEM-RECTANGLE ITEM)
    (AND (NOT (NULL LEFT))
	 (PREPARE-SHEET (SELF)			;Clip but allow extension into margins
	   (SETQ LEFT (MAX (+ LEFT (SHEET-INSIDE-LEFT)) 0)
		 RIGHT (MIN (+ RIGHT (SHEET-INSIDE-LEFT)) WIDTH)
		 TOP (MAX (+ TOP (SHEET-INSIDE-TOP)) 0)
		 BOTTOM (MIN (+ BOTTOM (SHEET-INSIDE-TOP)) HEIGHT))
	   (%DRAW-RECTANGLE (- RIGHT LEFT) (- BOTTOM TOP) LEFT TOP ALU-XOR SELF)))))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :ADD-HIGHLIGHTED-ITEM) (ITEM)
  (COND ((NOT (MEMQ ITEM HIGHLIGHTED-ITEMS))
	 (PUSH ITEM HIGHLIGHTED-ITEMS)
	 (SHEET-FORCE-ACCESS (SELF T) (FUNCALL-SELF ':HIGHLIGHT-ITEM ITEM)))))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :REMOVE-HIGHLIGHTED-ITEM) (ITEM)
  (COND ((MEMQ ITEM HIGHLIGHTED-ITEMS)
	 (SETQ HIGHLIGHTED-ITEMS (DELQ ITEM HIGHLIGHTED-ITEMS))
	 (SHEET-FORCE-ACCESS (SELF T) (FUNCALL-SELF ':HIGHLIGHT-ITEM ITEM)))))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :SET-HIGHLIGHTED-ITEMS) (NEW-HIGHLIGHTED-ITEMS &AUX OLD)
  (SETQ OLD HIGHLIGHTED-ITEMS
	HIGHLIGHTED-ITEMS NEW-HIGHLIGHTED-ITEMS)
  (SHEET-FORCE-ACCESS (SELF T)
    (DOLIST (X OLD)
      (OR (MEMQ X NEW-HIGHLIGHTED-ITEMS) (FUNCALL-SELF ':HIGHLIGHT-ITEM X)))
    (DOLIST (X NEW-HIGHLIGHTED-ITEMS)
      (OR (MEMQ X OLD) (FUNCALL-SELF ':HIGHLIGHT-ITEM X)))))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :AFTER :MENU-DRAW) ()
  (DOLIST (X HIGHLIGHTED-ITEMS)
    (FUNCALL-SELF ':HIGHLIGHT-ITEM X)))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :HIGHLIGHTED-VALUES) ()
  (MAPCAR #'(LAMBDA (X) (FUNCALL-SELF ':EXECUTE-NO-SIDE-EFFECTS X)) HIGHLIGHTED-ITEMS))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :SET-HIGHLIGHTED-VALUES) (VALUES &AUX ITEMS)
  (DOLIST (ITEM ITEM-LIST)
    (AND (MEMBER (FUNCALL-SELF ':EXECUTE-NO-SIDE-EFFECTS ITEM) VALUES)
	 (PUSH ITEM ITEMS)))
  (OR (= (LENGTH ITEMS) (LENGTH VALUES))
      (FERROR NIL "Missing or duplicate value"))
  (FUNCALL-SELF ':SET-HIGHLIGHTED-ITEMS ITEMS))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :ADD-HIGHLIGHTED-VALUE) (VALUE)
  (DO ((L ITEM-LIST (CDR L)))
      ((NULL L) (FERROR NIL "Value not found"))
    (AND (EQUAL (FUNCALL-SELF ':EXECUTE-NO-SIDE-EFFECTS (CAR L)) VALUE)
	 (RETURN (FUNCALL-SELF ':ADD-HIGHLIGHTED-ITEM (CAR L))))))

(DEFMETHOD (MENU-HIGHLIGHTING-MIXIN :REMOVE-HIGHLIGHTED-VALUE) (VALUE)
  (DO ((L ITEM-LIST (CDR L)))
      ((NULL L) (FERROR NIL "Value not found"))
    (AND (EQUAL (FUNCALL-SELF ':EXECUTE-NO-SIDE-EFFECTS (CAR L)) VALUE)
	 (RETURN (FUNCALL-SELF ':REMOVE-HIGHLIGHTED-ITEM (CAR L))))))


;******** This doesn't work because it has to tell the geometry guy to leave enough
;******** width for the margin choices to fit in.  As it stands it actually manages
;******** to draw outside of its assigned area of the screen.
(DEFFLAVOR MENU-MARGIN-CHOICE-MIXIN () (MARGIN-CHOICE-MIXIN)
  (:INCLUDED-FLAVORS BASIC-MENU)
  (:DOCUMENTATION :MIXIN "Puts choice boxes in the bottom margin of a menu.
Clicking on a choice box simulates clicking on a menu item")
  (:INIT-KEYWORDS :MENU-MARGIN-CHOICES))

;An element of :MENU-MARGIN-CHOICES is just like an element of :ITEM-LIST

(DEFMETHOD (MENU-MARGIN-CHOICE-MIXIN :BEFORE :INIT) (INIT-PLIST)
  (LET ((CURRENT-FONT NIL))	;MENU-ITEM-STRING looks at this
    (SETQ MARGIN-CHOICES
	  (MAPCAR #'MENU-MARGIN-CHOICE-FROM-ITEM (GET INIT-PLIST ':MENU-MARGIN-CHOICES)))))

(DEFMETHOD (MENU-MARGIN-CHOICE-MIXIN :SET-MENU-MARGIN-CHOICES) (LIST)
  (FUNCALL-SELF ':SET-MARGIN-CHOICES (MAPCAR #'MENU-MARGIN-CHOICE-FROM-ITEM LIST)))

(DEFUN MENU-MARGIN-CHOICE-FROM-ITEM (X)
  (LIST (MENU-ITEM-STRING X) NIL 'MENU-MARGIN-CHOICE-FUNCTION NIL NIL X))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (MENU-MARGIN-CHOICE-MIXIN)
(DEFUN MENU-MARGIN-CHOICE-FUNCTION (CHOICE-BOX REGION Y-POS)
  REGION Y-POS ;ignored
  (SETQ CHOSEN-ITEM (SIXTH CHOICE-BOX))))

(DEFFLAVOR MULTIPLE-MENU-MIXIN (SPECIAL-CHOICE-ITEMS) (MENU-HIGHLIGHTING-MIXIN)
  (:INIT-KEYWORDS :SPECIAL-CHOICES)
  (:DEFAULT-INIT-PLIST :FONT-MAP '(FONTS:MEDFNT FONTS:HL12I)
		       :SPECIAL-CHOICES '(("Do It"
					   :EVAL (FUNCALL-SELF ':HIGHLIGHTED-VALUES))))
  (:DOCUMENTATION :MIXIN "A menu in which you can select more than one choice.
 HIGHLIGHTED-ITEMS is a list of those items in the ITEM-LIST that are currently
 selected.  SPECIAL-CHOICES are those items that don't highlight when
 you click on them, but instead are executed in the usual way.  The default
 special choice is just Done, which returns a list of the values of the highlighted
 items.  SPECIAL-CHOICES are displayed in italics at the top of the menu."))

(DEFMETHOD (MULTIPLE-MENU-MIXIN :BEFORE :INIT) (INIT-PLIST)
  (SETQ SPECIAL-CHOICE-ITEMS
	(MAPCAR #'(LAMBDA (X)
		    (APPEND (COND ((ATOM X) (LIST X ':VALUE X))
				  ((ATOM (CDR X)) (LIST (CAR X) ':VALUE (CDR X)))
				  ((NULL (CDDR X)) (LIST (CAR X) ':VALUE (CADR X)))
				  (T X))
			    '(:FONT FONTS:HL12I :SPECIAL-CHOICE T)))
		(GET INIT-PLIST ':SPECIAL-CHOICES)))
  (AND (BOUNDP 'ITEM-LIST)			;Only if items specified in init-plist
       (SETQ ITEM-LIST (MULTIPLE-MENU-HACK-ITEM-LIST ITEM-LIST (GET INIT-PLIST ':COLUMNS)))))

(DEFMETHOD (MULTIPLE-MENU-MIXIN :SET-ITEM-LIST) (NEW-ITEM-LIST)
  (SETQ ITEM-LIST (MULTIPLE-MENU-HACK-ITEM-LIST NEW-ITEM-LIST)
	LAST-ITEM NIL
	CURRENT-ITEM NIL)
  (MENU-COMPUTE-GEOMETRY T)		;Recompute parameters, and redraw menu
  ITEM-LIST)

;Insert the special-choices into the item-list
;Buglet - if n-columns is not specified explicitly, and turns out to be more than 1,
;there will not be automatic blank space inserted to keep the special-choices on
;a separate row.  There is probably nothing wrong with this.
(DECLARE-FLAVOR-INSTANCE-VARIABLES (MULTIPLE-MENU-MIXIN)
(DEFUN MULTIPLE-MENU-HACK-ITEM-LIST (ITM-LST &OPTIONAL N-COLUMNS)
  (SETQ N-COLUMNS (OR N-COLUMNS (CAR GEOMETRY) 1))
  (APPEND SPECIAL-CHOICE-ITEMS
	  (AND N-COLUMNS (> N-COLUMNS 1)
	       (DO ((N (\ (LENGTH SPECIAL-CHOICE-ITEMS) N-COLUMNS) (1+ N))
		    (L NIL (CONS '("" :NO-SELECT NIL) L)))
		   ((OR (ZEROP N) (= N N-COLUMNS)) L)))
	  ITM-LST)))

;Modified mouse-button handler.  Does normal thing for special-choices, otherwise
;just complements highlight state.
(DEFWRAPPER (MULTIPLE-MENU-MIXIN :MOUSE-BUTTONS) (IGNORE . BODY)
  `(LET ((ITEM CURRENT-ITEM))
     (COND ((NULL ITEM))
	   ((AND (NOT (ATOM ITEM))	;Special-choice selected?
		 (NOT (ATOM (CDR ITEM)))
		 (GET (CDDR ITEM) ':SPECIAL-CHOICE))
	    . ,BODY)			;Yes, do normal action
	(T				;Ordinary item, highlight or un-highlight it
	 (FUNCALL-SELF (IF (MEMQ ITEM HIGHLIGHTED-ITEMS) ':REMOVE-HIGHLIGHTED-ITEM
			   ':ADD-HIGHLIGHTED-ITEM)
		       ITEM)))))

(DEFFLAVOR MULTIPLE-MENU () (MULTIPLE-MENU-MIXIN MENU))

(DEFFLAVOR MOMENTARY-MULTIPLE-MENU () (MULTIPLE-MENU-MIXIN MOMENTARY-MENU))

(DEFFLAVOR BASIC-MOMENTARY-MENU () (HYSTERETIC-WINDOW-MIXIN BASIC-MENU)
  (:DOCUMENTATION :MIXIN "A menu that holds control of the mouse.
Menus of this type handle the mouse for a small area outside of their
actual edges.  They also are automatically deactivated whenever an item
is chosen or the mouse moves even further, out of its control."))

(DEFWRAPPER (BASIC-MOMENTARY-MENU :CHOOSE) (IGNORE . BODY)
  `(*CATCH 'ABORT (PROGN . ,BODY)))

(DEFMETHOD (BASIC-MOMENTARY-MENU :BEFORE :CHOOSE) ()
  (COND ((NOT EXPOSED-P)
	 (MULTIPLE-VALUE-BIND (X-OFF Y-OFF)
	     (SHEET-CALCULATE-OFFSETS SUPERIOR MOUSE-SHEET)
	   (MULTIPLE-VALUE-BIND (X Y)
	       (FUNCALL-SELF ':CENTER-AROUND (- MOUSE-X X-OFF) (- MOUSE-Y Y-OFF))
	     (MOUSE-WARP (+ X X-OFF) (+ Y Y-OFF))))
	 ;; Expose self, and seize the mouse.
	 (WITH-MOUSE-GRABBED
	   (FUNCALL-SELF ':EXPOSE)
	   (COND ((NEQ SELF (LOWEST-SHEET-UNDER-POINT MOUSE-SHEET MOUSE-X MOUSE-Y
						      NIL ':EXPOSED))
		  (FUNCALL-SELF ':DEACTIVATE)
		  (*THROW 'ABORT NIL)))))))

;;; When no selection, but mouse moved out of range, deexpose menu
(DEFMETHOD (BASIC-MOMENTARY-MENU :AFTER :HANDLE-MOUSE) ()
  (OR CHOSEN-ITEM
      ;; Don't flush if mouse being usurped
      WINDOW-OWNING-MOUSE
      ;; Only flush us if either not explicitly flushing or we don't own mouse
      (AND MOUSE-RECONSIDER (EQ SELF (WINDOW-OWNING-MOUSE)))
      ;; This is called in the mouse process.  We don't want to take the chance that
      ;; we might go blocked, so run in another process.
      (PROCESS-RUN-FUNCTION "Menu Deactivate" SELF ':DEACTIVATE)))

;;; Make MOUSE-DEFAULT-HANDLER return so menu gets deactivated.
(DEFMETHOD (BASIC-MOMENTARY-MENU :AFTER :MOUSE-BUTTONS) (IGNORE IGNORE IGNORE)
  (AND CHOSEN-ITEM (SETQ MOUSE-RECONSIDER T)))

(DEFMETHOD (BASIC-MOMENTARY-MENU :BEFORE :EXECUTE) (&REST IGNORE)
  (FUNCALL-SELF ':DEACTIVATE))

(DEFFLAVOR WINDOW-HACKING-MENU-MIXIN (WINDOW-UNDER-MENU OLD-X OLD-Y) ()
  (:DOCUMENTATION :MIXIN "Menu which handles :WINDOW-OP when called over another window
The window that the menu is exposed over is remembered when the :choose message is sent,
and then used if a :window-op type item is selected."))

(DEFMETHOD (WINDOW-HACKING-MENU-MIXIN :BEFORE :CHOOSE) ()
  (SETQ WINDOW-UNDER-MENU (LOWEST-SHEET-UNDER-POINT MOUSE-SHEET MOUSE-X MOUSE-Y)
	OLD-X MOUSE-X
	OLD-Y MOUSE-Y))

(DEFMETHOD (WINDOW-HACKING-MENU-MIXIN :EXECUTE-WINDOW-OP) (FUNCTION)
  (FUNCALL FUNCTION WINDOW-UNDER-MENU OLD-X OLD-Y))

(DEFFLAVOR ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN () ()
  (:REQUIRED-FLAVORS BASIC-MENU)
  (:REQUIRED-METHODS :UPDATE-ITEM-LIST)
  (:DEFAULT-INIT-PLIST :ITEM-LIST NIL)
  (:DOCUMENTATION :MIXIN "Allows the menu to have an item list that's being dynamically
modified.  Causes the menu's item list to be updated at appropriate times.
The actual item list is computed via the :UPDATE-ITEM-LIST message."))

(DEFMETHOD (ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN :BEFORE :CHOOSE) (&REST IGNORE)
  (FUNCALL-SELF ':UPDATE-ITEM-LIST))

(DEFMETHOD (ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN :BEFORE :MOVE-NEAR-WINDOW) (&REST IGNORE)
  (FUNCALL-SELF ':UPDATE-ITEM-LIST))

(DEFMETHOD (ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN :BEFORE :CENTER-AROUND) (&REST IGNORE)
  (FUNCALL-SELF ':UPDATE-ITEM-LIST))

(DEFMETHOD (ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN :BEFORE :SIZE) (&REST IGNORE)
  (FUNCALL-SELF ':UPDATE-ITEM-LIST))

(DEFMETHOD (ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN :BEFORE :PANE-SIZE) (&REST IGNORE)
  (FUNCALL-SELF ':UPDATE-ITEM-LIST))


(DEFFLAVOR DYNAMIC-ITEM-LIST-MIXIN ((ITEM-LIST-POINTER NIL))
	   (ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN)
  :INITABLE-INSTANCE-VARIABLES
  :SETTABLE-INSTANCE-VARIABLES
  :GETTABLE-INSTANCE-VARIABLES
  (:DOCUMENTATION :MIXIN "Allows the menu to have an item list that's being dynamically
modified.  Causes the menu's item list to be updated at appropriate times.
The ITEM-LIST-POINTER instance variable is a form to be evaluated to get the item list."))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (DYNAMIC-ITEM-LIST-MIXIN)
(DEFUN DYNAMIC-ITEM-LIST ()
  (IF (SYMBOLP ITEM-LIST-POINTER)
      (SYMEVAL ITEM-LIST-POINTER)
      (EVAL ITEM-LIST-POINTER))))

(DEFMETHOD (DYNAMIC-ITEM-LIST-MIXIN :BEFORE :INIT) (IGNORE)
  (AND ITEM-LIST-POINTER
       (SETQ ITEM-LIST (DYNAMIC-ITEM-LIST))))

(DEFMETHOD (DYNAMIC-ITEM-LIST-MIXIN :UPDATE-ITEM-LIST) (&AUX NEW-ITEM-LIST)
  (AND ITEM-LIST-POINTER
       (OR (EQUAL ITEM-LIST (SETQ NEW-ITEM-LIST (DYNAMIC-ITEM-LIST)))
	   (FUNCALL-SELF ':SET-ITEM-LIST NEW-ITEM-LIST))))


(DEFFLAVOR DYNAMIC-MULTICOLUMN-MIXIN (COLUMN-SPEC-LIST PREVIOUS-STATE)
	   (ABSTRACT-DYNAMIC-ITEM-LIST-MIXIN)
  (:INITABLE-INSTANCE-VARIABLES COLUMN-SPEC-LIST)
  (:DOCUMENTATION :MIXIN "Makes a menu have multiple 'dynamic' columns.
Each column comes from a separate item-list which is recomputed at appropriate times.
The instance variable COLUMN-SPEC-LIST is a list of columns, each column consists
of (heading item-list-form . options).  Heading is a string to go at the top of the
column, and options are menu-item options for it (typically font).  item-list-form is
a form to be evaluated (without side-effects) to get the item list for that column."))

(DEFMETHOD (DYNAMIC-MULTICOLUMN-MIXIN :BEFORE :INIT) (IGNORE)
  (SETQ PREVIOUS-STATE (MAKE-LIST (LENGTH COLUMN-SPEC-LIST))))

(DEFMETHOD (DYNAMIC-MULTICOLUMN-MIXIN :UPDATE-ITEM-LIST) (&OPTIONAL FORCE)
  (IF (OR FORCE
	  (LOOP FOR (HEADING FORM) IN COLUMN-SPEC-LIST
		AND OLD-ITEM-LIST IN PREVIOUS-STATE
		THEREIS (NEQ (IF (SYMBOLP FORM) (SYMEVAL FORM) (EVAL FORM)) OLD-ITEM-LIST)))
      ;; Something has changed, set up new item list.
      ;; Start by extracting the column lists and setting up the headings.
      (LOOP FOR (HEADING FORM . OPTIONS) IN COLUMN-SPEC-LIST 
	    AND STATEL ON PREVIOUS-STATE
	    COLLECT `(,HEADING :NO-SELECT T . ,OPTIONS) INTO NEW-ITEM-LIST
	    COLLECT (IF (SYMBOLP FORM) (SYMEVAL FORM) (EVAL FORM)) INTO COLUMNS
	    FINALLY
	;; Now interleave the columns, and save the old state.
	(SETQ NEW-ITEM-LIST (NREVERSE NEW-ITEM-LIST))
	(LOOP FOR C IN COLUMNS AND L ON PREVIOUS-STATE DO (RPLACA L C))
	(LOOP REPEAT (LOOP FOR C IN COLUMNS MAXIMIZE (LENGTH C))
	      DO (LOOP FOR L ON COLUMNS
		       DO (PUSH (OR (CAAR L) `("" :NO-SELECT T)) NEW-ITEM-LIST)
			  (RPLACA L (CDAR L))))
	(OR (EQ (CAR GEOMETRY) (LENGTH COLUMN-SPEC-LIST))
	    (FUNCALL-SELF ':SET-GEOMETRY (LENGTH COLUMN-SPEC-LIST)))
	(FUNCALL-SELF ':SET-ITEM-LIST (NREVERSE NEW-ITEM-LIST)))))

(DEFMETHOD (DYNAMIC-MULTICOLUMN-MIXIN :SET-COLUMN-SPEC-LIST) (NEW-COLUMN-SPEC-LIST)
  (SETQ PREVIOUS-STATE (MAKE-LIST (LENGTH NEW-COLUMN-SPEC-LIST)))
  (SETQ COLUMN-SPEC-LIST NEW-COLUMN-SPEC-LIST)
  (FUNCALL-SELF ':UPDATE-ITEM-LIST T))

;;; This is a bit of a kludge.  It is necessary because this method is not
;;; loaded before the COMPILE-FLAVOR-METHODS is done, and therefore the
;;; flavor system assumes that the method has been deleted and recompiles
;;; the combined method.  So we tell it that there is going to be a method,
;;; but the actual code for the method is in FRAME.
(SI:FLAVOR-NOTICE-METHOD '(:METHOD BASIC-MENU :PANE-SIZE))


;;; Menus to be used for a momentary choice.
;;; Send a menu of this type a :CHOOSE message to use the menu.
;;; When the user selects an item, or moves the mouse off the menu,
;;; the menu will disappear, and whatever was underneath it will reappear.
;;; It will return the chosen item, or NIL.  If the item is not atomic
;;; and its cadr is non-NIL, the cadr will be called with no arguments.
;;; In this case, if the caddr of the item is also non-nil,
;;; no windows will be re-exposed before the cadr is called.
(DEFFLAVOR MOMENTARY-MENU ((LABEL NIL)) (BASIC-MOMENTARY-MENU TEMPORARY-WINDOW-MIXIN
					 BORDERS-MIXIN TOP-BOX-LABEL-MIXIN
					 BASIC-SCROLL-BAR MINIMUM-WINDOW)
  (:DOCUMENTATION :COMBINATION "Temporary menu that goes away after item is chosen"))


(DEFFLAVOR MOMENTARY-WINDOW-HACKING-MENU () (WINDOW-HACKING-MENU-MIXIN MOMENTARY-MENU)
  (:DOCUMENTATION :COMBINATION))

(DEFFLAVOR DYNAMIC-MOMENTARY-MENU () (DYNAMIC-ITEM-LIST-MIXIN MOMENTARY-MENU))
(DEFFLAVOR DYNAMIC-MOMENTARY-WINDOW-HACKING-MENU
	()
	(DYNAMIC-ITEM-LIST-MIXIN MOMENTARY-WINDOW-HACKING-MENU))
(DEFFLAVOR DYNAMIC-POP-UP-MENU () (DYNAMIC-ITEM-LIST-MIXIN POP-UP-MENU))
(DEFFLAVOR DYNAMIC-POP-UP-COMMAND-MENU ()
	   (DYNAMIC-ITEM-LIST-MIXIN TEMPORARY-WINDOW-MIXIN COMMAND-MENU))
(DEFFLAVOR DYNAMIC-POP-UP-ABORT-ON-DEEXPOSE-COMMAND-MENU ()
	   (COMMAND-MENU-ABORT-ON-DEEXPOSE-MIXIN DYNAMIC-POP-UP-COMMAND-MENU))
(DEFFLAVOR DYNAMIC-MULTICOLUMN-MOMENTARY-MENU ()
	   (DYNAMIC-MULTICOLUMN-MIXIN MOMENTARY-MENU))
(DEFFLAVOR DYNAMIC-MULTICOLUMN-MOMENTARY-WINDOW-HACKING-MENU ()
	   (WINDOW-HACKING-MENU-MIXIN DYNAMIC-MULTICOLUMN-MOMENTARY-MENU))

(DEFUN MENU-CHOOSE (ALIST &OPTIONAL (LABEL NIL) (NEAR-MODE '(:MOUSE)) DEFAULT-ITEM
		    (SUPERIOR MOUSE-SHEET) &AUX V1 V2)
  (AND (EQ (CAR NEAR-MODE) ':WINDOW) (SETQ SUPERIOR (SHEET-SUPERIOR (CADR NEAR-MODE))))
  (USING-RESOURCE (MENU MOMENTARY-MENU SUPERIOR)
    (FUNCALL MENU ':SET-LABEL LABEL)
    (FUNCALL MENU ':SET-ITEM-LIST ALIST)
    (FUNCALL MENU ':SET-LAST-ITEM DEFAULT-ITEM)
    (EXPOSE-WINDOW-NEAR MENU NEAR-MODE)
    (AND DEFAULT-ITEM (NOT (MEMQ (CAR NEAR-MODE) '(:MOUSE :POINT)))
	 (MULTIPLE-VALUE-BIND (X Y)
	     (FUNCALL MENU ':ITEM-CURSORPOS DEFAULT-ITEM)
	   (AND X Y
		(FUNCALL MENU ':SET-MOUSE-POSITION (+ X (SHEET-INSIDE-LEFT MENU))
			 			   (+ Y (SHEET-INSIDE-TOP MENU))))))
    (SETQ V1 (FUNCALL MENU ':CHOOSE) V2 (FUNCALL MENU ':LAST-ITEM)))
  (VALUES V1 V2))	;No multiple values through unwind-protect!

;All types of menus, since they probably all get used
(COMPILE-FLAVOR-METHODS MENU POP-UP-MENU COMMAND-MENU MOMENTARY-MENU
			MOMENTARY-WINDOW-HACKING-MENU
			MULTIPLE-MENU MOMENTARY-MULTIPLE-MENU
			DYNAMIC-MOMENTARY-MENU DYNAMIC-MOMENTARY-WINDOW-HACKING-MENU
			DYNAMIC-POP-UP-MENU DYNAMIC-POP-UP-COMMAND-MENU
			DYNAMIC-POP-UP-ABORT-ON-DEEXPOSE-COMMAND-MENU
			DYNAMIC-MULTICOLUMN-MOMENTARY-MENU
			DYNAMIC-MULTICOLUMN-MOMENTARY-WINDOW-HACKING-MENU)