;;; -*- Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development. If
;;; you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; The menu choice facility for Spice Lisp.
;;; Written by Jim Muller.
;;;
(defvar *italic-font*)
(defun menu-choose-init ()
;; For now, don't do fancy things that eat physical memory.
(setq *italic-font* *current-font*)
(setq *default-menu-choose-in-window* *full-window*))
;;; User settable parameters to the choice functions.
(defvar *default-menu-choose-position-x* nil
"This is the default x place to put the upper left hand corner of a choice
menu. Nil indicates the current mouse pointer position.")
(defvar *default-menu-choose-position-y* nil
"This is the default y place to put the upper left hand corner of a choice
menu. Nil indicates the current mouse pointer position.")
;;; This actually gets initialized in menu-choose-init, so that the value
;;; of the port is correct for the current lisp.
(defvar *default-menu-choose-in-window* *full-window*
"This is the default window to use as origin when choosing x-y position of
menu.")
(defvar *default-menu-choose-ncolumns* 1
"This is the default shape for choice windows. It is either a number of
columns to use or :square.")
(defvar *default-menu-choose-items-justified* :center
"The default is for items to be centered in their columns. Left and right
justification are also possible with :left and :right.")
;;; Internal specials.
(defvar *menu-viewport* () "The menu viewport object.")
(defvar *menu-window* () "The menu window object. Used for deletion.")
(defvar *menu-cols* () "A list of the columns (vectors of item structures)
which represents the menu.")
(defvar *menu-inside-width*)
(defvar *menu-width*)
(defvar *menu-column-width*)
(defvar *menu-height*)
(defvar *menu-title-height*)
(defvar *menu-in-viewport*)
;;; These correspond to the obvious parameters to the choice functions.
(defvar *menu-items*)
(defvar *menu-position-x*)
(defvar *menu-position-y*)
(defvar *menu-in-window*)
(defvar *menu-stay-in-place*)
(defvar *menu-title*)
(defvar *menu-title-font*)
(defvar *menu-items-justified*)
(defvar *menu-default-item*)
(defvar *menu-ncolumns*)
(defvar *menu-spacing*)
(defvar *menu-font*)
(defvar *menu-label-font*)
(defvar *menu-abort-value*)
(proclaim '(special *user-font*))
(proclaim '(special *user-viewport*))
;;; Get the height of the font in pixels from accent.
(defmacro font-height (font)
`(multiple-value-bind (n ps r c w h) (font-size ,font)
(declare (ignore n ps r c w))
h))
;;; Until someone actually builds a table of the things or something.
(defun italic-font (font)
(declare (ignore font))
*italic-font*)
;;; Get the width of the string in pixels from accent. Leave 4 for inset space.
(defmacro font-string-width (string font)
`(let* ((string ,string))
(font-string-size ,font string 0 (length string))))
(defparameter *lisp-keytran-file* "lisp.keytran"
"The keytran file that Lisp (not Hemlock) uses.")
(defparameter *mouse-buttons* '(:left :middle :right)
"The mouse buttons available on the Perq.")
(defmacro mouse-button (cmd)
`(case ,cmd (83 :left) (82 :middle) (84 :right)))
(defparameter *mouse-button-press-cmds* '(83 82 84)
"Left, middle, and right mouse buttons on Perq under current keytran file.")
(defparameter *control-g-cmd* 77 "Control G in current keytran file.")
(defparameter border-width 5 "Width in pixels of a sapphire window border.")
(defconstant screen-black 0 "Passed as FUNCT to some accent functions.")
(defconstant screen-white 1 "Passed as FUNCT to some accent functions.")
(defconstant screen-inverse 2 "Passed as FUNCT to some accent functions.")
(defparameter screen-right 767 "Far right pixel on the Perq screen.")
(defparameter screen-bottom 1023 "Far bottom pixel on the Perq screen.")
(defun print-menu (x stream depth)
(declare (ignore depth))
(format stream "#<Menu ~S>" (menu-title x)))
(defstruct (menu (:print-function print-menu))
"This holds all the information for a menu-choose menu."
items
(position-x *default-menu-choose-position-x*)
(position-y *default-menu-choose-position-y*)
stay-in-place
title
(items-justified *default-menu-choose-items-justified*)
default-item
(ncolumns *default-menu-choose-ncolumns*)
spacing
abort-value
return-form)
(defvar *print-item* ()
"If this is true, print all the fields of a menu item, not just its name.")
(defun print-item (x stream depth)
(declare (ignore depth))
(if *print-item*
(format stream "#<Item ~S: ~S Top: ~S, Width: ~S, Height: ~S, ~
Font: ~S, Selectable by ~S, Returns: ~S>" (item-name x)
(item-help x) (item-top x) (item-width x) (item-height x)
(item-font x) (item-selectable x) (item-return x))
(format stream "#<Item ~S>" (item-name x))))
(defstruct (item (:print-function print-item))
"One word displayed in a menu, with all the auxiliary information. The
format for items (as the user specifies it) is either a string/symbol/char
which is displayed as the name, or a list whose car is a string/symbol/char
and whose cdr is a bunch of keyword arguments as follows:
@t(:help) string. The string @i(name): @i(help) is given as help in the lisp
window title line as long as the entry @i(name) with help @i(help) is being
moused.
@t(:value) value. The value is returned if the user clicks the mouse button on
the item.
@t(:values) ({value}*). The values are returned as multiple values if the user
clicks the mouse button on the item.
@t(:eval) form. The form is evaluated and returned when the user clicks the
mouse button on the item.
@t(:funcall) fn ({arg}*). The result of the obvious funcall is returned when
the user clicks the mouse button on the item.
@t(:no-select). The item may not be selected. Clicking the mouse here just
causes the lisp window to flash.
@t(:buttons) {button-specifier}*. This takes some button specifiers, each of
which is a list. The specifier's car specifies a particular button, such as
:left, :middle, or :right. The rest of the specifier list is a keyword arg of
the :values, :eval, :funcall, or :no-select form; if there is anything after
the first keyword arg it is ignored. Thus each specifier says what to return
if that button is pressed, or that that button is inactive while mousing this
item. If a button is left unspecified it causes nil to be returned. A button
may not be specified more than once.
@t(:font) font. This specifies the font in which the item name is to be
printed.
@t(:label). This is an abbreviation for :font label-font :no-select.
Example:
(Temperature :eval *room-temperature* :font *fahrenheit-font*
:help Current temperature @i(in the room))"
(name "" :type 'simple-string)
(help "" :type 'simple-string)
(top 0 :type 'fixnum)
(width 0 :type 'fixnum)
(height 0 :type 'fixnum)
(selectable *mouse-buttons*)
return
(font :font))
;;; Calls view-put-ch-array with some defaults set up.
(defun write-at (string font x y viewport &optional (height (font-height font)))
(view-put-ch-array 6 x (+ y height) string 0
(1- (length string)) viewport font))
;;; Color the given block inverse.
(defun inverse-at (x y width height in-window)
(view-color-rect screen-inverse x y width height in-window))
;;; Read an item from the (tail of an) item keyword list l into slot.
(defmacro parse-1-item-arg (l slot)
`(progn
(setf ,slot (cadr ,l))
(setq ,l (cddr ,l))))
;;; Read until a keyword from the (tail of an) item keyword list l into slot.
(defmacro parse-*-item-args (list slot)
`(do* ((list (cdr ,list) (cdr list))
(i (car list) (car list)))
((or (and (symbolp i) (keywordp i)) (null list))
(setf ,slot (nreverse ,slot))
(setf ,list list))
(push i ,slot)))
;;; Take an item in the form specified in the documentation for the facility
;;; (with keywords) and turn it into an item structure. The keyword :new-column
;;; is passed on as is.
(defun construct-item (from-item)
(if (eq from-item :new-column)
:new-column
(let ((item (make-item)))
(cond ((listp from-item)
(setf (item-name item) (string (car from-item)))
(setf (item-return item) (list 'values (item-name item)))
(do* ((l (cdr from-item))
(i (car l) (car l)))
((null l))
(case i
(:help
(parse-1-item-arg l (item-help item))
(setf (item-help item) (string (item-help item))))
(:value
(parse-1-item-arg l (item-return item))
(setf (item-return item) (list 'values (item-return item))))
(:values
(parse-1-item-arg l (item-return item))
(push 'values (item-return item)))
(:eval (parse-1-item-arg l (item-return item)))
(:funcall
(let (fn)
(parse-1-item-arg l fn)
(setf (item-return item) (car l))
(setf l (cdr l))
(push fn (item-return item))
(push 'funcall (item-return item))))
(:no-select
(setf l (cdr l))
(setf (item-selectable item) ()))
(:buttons
(let ((buttons)
(case-forms '()))
(parse-*-item-args l buttons)
(do* ((b buttons (cdr b))
(button (caar b) (caar b))
(return-method (cadar b) (cadar b))
(arg1 (car (cddar b)) (car (cddar b)))
(arg2 (cadr (cddar b)) (cadr (cddar b))))
((null b))
(if (eq return-method :no-select)
(setf (item-selectable item)
(remove button (item-selectable item)))
(push (list button
(case return-method
(:eval arg1)
(:value `(values ,arg1))
(:values `(values ,@arg1))
(:funcall `(funcall ,arg1 ,@arg2))))
case-forms)))
(setf (item-return item) `(case button ,@case-forms))))
(:font (parse-1-item-arg l (item-font item)))
(:label
(setf l (cdr l))
(setf (item-font item) :label-font)
(setf (item-selectable item) ()))
(t (error "~S is the end of an invalid keyword list~
for menu choose item ~S" l (item-name item))
(return ())))))
(t (setf (item-name item) (string from-item))
(setf (item-return item) (list 'values (item-name item)))))
item)))
;;; Read through the items in the initial list from the caller, and figure out
;;; how they are supposed to be columnized, converting them into item
;;; structures along the way.
;;; Two cases:
;;; 1] If there are new column markers, columnize exactly as they order.
;;; 2] If they specify n columns, create that many.
(defun columnize (items)
(let* ((columns '()))
(cond ((member :new-column items)
(do ()
((null items))
;; Prune a column off a :new-columned list of items.
(do ((x items (cdr x))
(len 0 (1+ len)))
((or (null x) (eq (car x) :new-column))
(if (zerop len) (error "Zero length menu columns are illegal."))
;; Fill in the vector.
(do* ((col (make-array len))
(x items (cdr x))
(j 0 (1+ j)))
((= j len)
(setq items (cdr x))
(push col columns))
(setf (aref col j) (car x)))))))
((and (integerp *menu-ncolumns*) (plusp *menu-ncolumns*))
(let* ((length (length items))
(nrows (ceiling length *menu-ncolumns*))
(col (make-array nrows)))
(if (> *menu-ncolumns* length)
(error "Can't create ~S columns in menu with only ~S items."
*menu-ncolumns* length))
(do ((i 0 (1+ i))
(l items (cdr l)))
((null l))
(when (zerop (mod i nrows))
(setq col (make-array (min (- length i) nrows)))
(push col columns))
(setf (aref col (mod i nrows)) (car l)))))
(t (error "~S is a bad shape for a menu window." *menu-ncolumns*)))
(if (null columns) (error "No items provided for menu."))
(nreverse columns)))
;;; Find the max width of any item in any column.
(defun max-width (columns)
(let ((max 0))
(dolist (col columns max)
(do ((i 0 (1+ i)))
((= i (length (the vector col))))
(setq max (max max (item-width (aref col i))))))))
;;; Write the words into the window, marking their top fields in pixels from
;;; the top of the window. Inset everything two pixels from the left, one
;;; from the top (so things are more centered in the box)
(defun display-choose-window ()
(when *menu-title*
(inverse-at 0 0 *menu-width* *menu-title-height* *menu-viewport*)
(write-at *menu-title* *menu-title-font*
(+ 1 (floor (- *menu-width*
(* 2 border-width)
(font-string-width *menu-title* *menu-title-font*))
2))
(floor *menu-title-height* 4) *menu-viewport*))
(do* ((left 0 (+ left *menu-spacing* *menu-column-width*))
(cols *menu-cols* (cdr cols))
(col (car cols) (car cols)))
((null cols))
(do ((i 0 (1+ i))
(top *menu-title-height*
(+ top (item-height (aref col i)))))
((= i (length (the vector col))))
(setf (item-top (aref col i)) top)
(let ((item (aref col i)))
(write-at
(item-name item) (item-font item)
(case *menu-items-justified*
(:left (+ 2 left))
(:center (+ left
(floor (- *menu-column-width* (item-width item)) 2)))
(:right (+ left *menu-column-width* (- (item-width item)) -2))
(t (error "Bad argument ~S for :items-justified in item ~S"
*menu-items-justified* item)))
(+ 1 top) *menu-viewport* (item-height item))))))
;;; Return the initial cursor position (item, left, top, col, col & row num),
;;; or nil if we can't find it.
(defun default-item-info ()
(do* ((cols *menu-cols* (cdr cols))
(col (car cols) (car cols))
(j 0 (1+ j))
(left 0 (+ left *menu-spacing* *menu-column-width*)))
((null cols) ())
(let ((i (position *menu-default-item* col
:test #'string-equal :key #'item-name)))
(if i (let ((item (aref col i)))
(return (values item (+ left (floor (item-width item) 2))
(+ (floor (item-height item) 2) (item-top item))
col j i)))))))
;;; Unhighlight the old item (if it was highlighted).
;;; Update the help in the title line.
;;; Find the top, left, bottom, and right of the current item (where the mouse
;;; must be for it to be current, which includes all the way over to the next
;;; column) and highlight the item (only as far as the actual width of the
;;; column, only if it is selectable). Update the item variable.
(defmacro calculate-item-boundaries-and-highlight (unhighlight-old-item)
`(progn
,(if unhighlight-old-item
`(inverse-at left top *menu-column-width* (item-height item)
*menu-viewport*))
(setq item (aref col row-number))
(set-title (item-help item))
(setq top (item-top item))
(setq bottom (+ top (item-height item)))
(setq left (* col-number (+ *menu-column-width* *menu-spacing*)))
;; Actually the right is only column-width over, but we'll pretend
;; you are on an item if you are on its right margin. You can't be
;; in the right margin of the right column, thanks to stay-in-menu.
(setq right (+ left *menu-column-width* *menu-spacing*))
(inverse-at left top *menu-column-width* (- bottom top) *menu-viewport*)))
;;; Used when we change columns. Have to find the row again, since it may
;;; have changed either due to diagonal movement or the items being of
;;; different heights.
;;; Find the mouses position in the specified column (if it is not provided,
;;; don't change it). Start by looking at the item in the current row (or the
;;; last row if the column is short), and continue until you have reached the
;;; right cell or the bottom of the column. Update the boundaries on the cell
;;; and do any necessary highlighting switch.
(defmacro find-mouse-position-in-column (&optional c)
`(let* ((r row-number))
,(when c
`(progn
(setq col-number ,c)
(setq col (nth col-number *menu-cols*))
(setq row-number (min row-number (1- (length (the vector col)))))))
(do () (nil)
(cond ((> (item-top (aref col row-number)) y)
(setq row-number (1- row-number)))
((and (< (1+ row-number) (length (the vector col)))
(> y (item-top (aref col (1+ row-number)))))
(setq row-number (1+ row-number)))
(t (return nil))))
(if (or ,c (/= r row-number))
(calculate-item-boundaries-and-highlight t))))
;;; If the mouse cursor leaves the menu area, pretend to put it back. Returns
;;; where we are pretending it is, and whether it really is outside.
(defun stay-in-menu (x y)
(unless (and (<= 0 x *menu-inside-width*)
(<= *menu-title-height* y *menu-height*))
(let ((old-x x)
(old-y y))
(macrolet ((bigp (x) `(> ,x 2000)))
(if (or (bigp y) (< y *menu-title-height*)) (setq y *menu-title-height*))
(if (> y *menu-height*) (setq y *menu-height*))
(if (or (bigp x) (< x 0)) (setq x 0))
(if (> x *menu-inside-width*) (setq x *menu-inside-width*))
(if (or (/= old-x x) (/= old-y y))
(set-cursor-pos x y *menu-viewport*)))))
(values x y))
;;; The height in pixels of the column.
(defun column-height (col)
(let ((total 0))
(dotimes (i (length (the vector col)) total)
(setq total (+ total (item-height (aref col i)))))))
;;; This puts the mouse cursor at the right starting point and then monitors
;;; its activity, highlighting the appropriate item.
;;; X and y are the up to the minute x and y mouse pointer positions.
;;; Col was the vector for the current column.
;;; Col-number and row-number were the number of that column and of the row.
;;; Top, bottom, left, and right were the boundaries of the item.
;;;
;;; Returns as values the name chosen and the button chosen with.
(defun mouse-choose ()
(set-listener *menu-viewport*)
(multiple-value-bind (item x y col col-number row-number) (default-item-info)
(let (top bottom left right)
(set-cursor-pos x y)
(calculate-item-boundaries-and-highlight nil)
(do ()
(nil)
(multiple-value-bind (cmd char y x) (get-event 1 *menu-viewport*)
(declare (ignore char))
(multiple-value-setq (x y) (stay-in-menu x y))
(cond ((< x left) (find-mouse-position-in-column (1- col-number)))
((< right x) (find-mouse-position-in-column (1+ col-number)))
(t (find-mouse-position-in-column)))
(let ((button (mouse-button cmd)))
;; If a valid button is clicked, return, otherwise if an unselectable
;; button is clicked, flash.
(cond ((member button (item-selectable item))
(set-listener *user-viewport*)
(destroy-window *menu-window*)
(set-title
(concatenate 'string
(lisp-implementation-type) " "
(lisp-implementation-version)))
(return (values (item-name item) (mouse-button cmd))))
((eql cmd *control-g-cmd*)
(beep)
(set-listener *user-viewport*)
(destroy-window *menu-window*)
(set-title
(concatenate 'string
(lisp-implementation-type) " "
(lisp-implementation-version)))
(return (values nil nil)))
(button (beep)))))))))
(defmacro menu-width ()
`(+ (* 2 border-width)
(max (if *menu-title*
(+ 4 (font-string-width *menu-title* *menu-title-font*))
0)
*menu-inside-width*)))
;;; Put the items in columns and find their width. From this calculate the
;;; size of the menu. Set the default x-y coordinates if they weren't
;;; supplied (to be where the mouse is). Set the default item to be the
;;; middle item in the middle column, unless it is specified correctly
;;; by the functionCreate the window, enable input to it, write
;;; in it, and then track until the user returns.
(defun menu-choose-function
(*menu-items* *menu-stay-in-place* *menu-title* *menu-title-font*
*menu-position-x* *menu-position-y* *menu-in-window* *menu-default-item*
*menu-items-justified* *menu-font* *menu-label-font* *menu-ncolumns*
*menu-spacing* *menu-abort-value*)
(unless *menu-spacing*
(setq *menu-spacing* (font-string-width "xx" *menu-font*)))
;; Some more initialization we didn't do before because we didn't have fonts.
(dolist (item *menu-items*)
(unless (eq item :new-column)
(setf (item-height item) (font-height (item-font item)))
(setf (item-width item)
(font-string-width (item-name item) (item-font item)))))
(let* ((*menu-cols* (columnize *menu-items*))
;; 4 pixels extra so we can inset two from the left.
(*menu-column-width* (+ 4 (max-width *menu-cols*)))
(*menu-inside-width*
(+ (* *menu-column-width* (length *menu-cols*))
(* *menu-spacing* (1- (length *menu-cols*)))))
(*menu-width* (menu-width))
(*menu-in-viewport* (window-viewport *menu-in-window*))
(*menu-title-height*
(if *menu-title* (* 2 (font-height *menu-title-font*)) 0))
(*menu-height* (+ (* 2 border-width)
*menu-title-height*
(apply #'max (mapcar #'column-height *menu-cols*)))))
;; Find default position x and y.
(unless (and *menu-position-x* *menu-position-y*)
(set-listener *menu-in-viewport*)
(multiple-value-bind (cmd char y x) (get-event 1 *menu-in-viewport*)
(declare (ignore cmd char))
(if (not *menu-position-x*) (setq *menu-position-x* x))
(if (not *menu-position-y*) (setq *menu-position-y* y)))
(set-listener *user-viewport*))
(if (> *menu-width* screen-right)
(error "Menu is ~S pixels too wide." (- screen-right *menu-width*)))
(if (> *menu-height* screen-bottom)
(error "Menu is ~S pixels too high." (- screen-bottom *menu-height*)))
;; Make sure the window is on the screen.
(if (> (+ *menu-position-x* *menu-width*) screen-right)
(if *menu-stay-in-place*
(error "Menu window overhangs ~S pixels on the right of the screen"
(+ *menu-position-x* *menu-width* (- screen-right)))
(setq *menu-position-x* (- screen-right *menu-width*))))
(if (> (+ *menu-position-y* *menu-height*) screen-bottom)
(if *menu-stay-in-place*
(error "Menu window overhangs ~S pixels on the bottom of the screen"
(+ *menu-position-y* *menu-width* (- screen-bottom)))
(setq *menu-position-y* (- screen-bottom *menu-height*))))
;; The default default item is near the middle.
(if (or (not *menu-default-item*)
;; Default item is absent from all columns.
(dolist (col *menu-cols* t)
(if (position *menu-default-item* col
:test #'string-equal :key #'item-name)
(return nil))))
(setq *menu-default-item* (let ((c (nth (floor (length *menu-cols*) 2)
*menu-cols*)))
(item-name (aref c (floor (length c) 2))))))
(multiple-value-bind (*menu-window* *menu-viewport*)
(create-window
t *menu-position-x* *menu-position-y* t
*menu-width*
*menu-height*
nil t "" "" nil *menu-in-window*)
(enable-input (namestring (truename *lisp-keytran-file*)) *menu-viewport*)
(display-choose-window)
(mouse-choose))))
(defmacro menu-choose
(&key items
stay-in-place
title
(title-font '(italic-font *user-font*))
(position-x '*default-menu-choose-position-x*)
(position-y '*default-menu-choose-position-y*)
(in-window '*default-menu-choose-in-window*)
default-item
(items-justified '*default-menu-choose-items-justified*)
(font '*user-font*)
(label-font'(italic-font *user-font*))
(ncolumns '*default-menu-choose-ncolumns*)
spacing
abort-value)
"Menu-choose puts a menu up on the screen, and the user may then
mouse a desired item from the list, causing a value (specified with the
item in the function call) to be returned. Labels and column break
markers may be embedded in the list of items; the person calling the
function may specify display information, such as fonts, for each
individual item or for all items. The items list is not evaluated, but
the font information for each item is evaluated (in the call's lexical
environment, at call time) as are the return values (in the call's
lexical environment, at mouse click time). The help strings are not
evaluated. SEE THE DOCUMENTATION ON ITEM FOR A FULL EXPLANATION OF ITEM
SYNTAX.
The arguments to menu-choose operate as described below. Where variable
@i(x) is *ed, @i(x) defaults to the value of the global variable
*default-menu-choose-@i(x)*, which initially has the specified value.
@i(Position-x*) and @i(position-y*) default to the pixel x and y coordinates of
the mouse pointer, and @i(in-window*) defaults to the window which is the
whole screen. These three variables specify where the menu should pop up. If
@i(stay-in-place) is specified and non-nil the window will appear with its
upper left hand corner at exactly that position, or an error will be signalled.
Otherwise it may be moved in order to make it fit on the screen.
The @i(title) is a string to be displayed above the rest of the menu in
inverse video in @i(title-font). If no title is given, the inverse video
title bar does not even appear.
The @i(default-item) is the name of the item on which the mouse initially
appears. The default default item is the around the middle somewhere. If
a bogus default item is specified, it is ignored. If a menu structure is
created, the default item is the last one chosen from it.
@i(Ncolumns*) specifies how many columns will be used. Its value defaults
to one. See the section below on arrangement of items in the window.
@i(Spacing) specifies the number of pixels width between columns. This much
white space is inserted after all columns but the last. @i(Spacing) defaults
to twice the width of the letter x in @i(font). @i(Items-justified*) tells
whether to to center the items, or justify them to the left or right
(:center, :left, :right); this defaults to :center.
@i(Font) is the default font for items which are not labels to appear in,
and defaults to whatever the font normally defaults to. @i(Label-font) is
the default font for labels to appear in, and defaults to the italic font
corresponding to the default font.
@i(Abort-value) is a value which is returned if the user types control-g
while choosing from a menu; it defaults to nil."
;;; The parameter list repeated within view of the code:
;;; (&key items
;;; stay-in-place
;;; title
;;; (title-font '(italic-font *user-font*))
;;; (position-x '*default-menu-choose-position-x*)
;;; (position-y '*default-menu-choose-position-y*)
;;; (in-window '*default-menu-choose-in-window*)
;;; default-item
;;; (items-justified '*default-menu-choose-items-justified*)
;;; (font '*user-font*)
;;; (label-font'(italic-font *user-font*))
;;; (ncolumns '*default-menu-choose-ncolumns*)
;;; spacing
;;; abort-value)
(setq items (mapcar #'construct-item items))
(let* ((cond-forms '())
(font-setf-forms '()))
(do* ((i items (cdr i))
(item (car i) (car i)))
((null i))
(unless (eq item :new-column)
(push `((string-equal item ,(item-name item)) ,(item-return item))
cond-forms)
(let ((item-font (case (item-font item)
(:font font)
(:label-font label-font)
(t (item-font item)))))
(push `(setf (item-font (car temp)) ,item-font) font-setf-forms)))
(push `(setq temp (cdr temp)) font-setf-forms))
`(let ((temp ',items))
,@(nreverse font-setf-forms)
(multiple-value-bind (item button)
(menu-choose-function
',items ,stay-in-place ,title ,title-font ,position-x
,position-y ,in-window ,default-item ,items-justified
,font ,label-font ,ncolumns ,spacing ,abort-value)
;; Button is the button pressed, nil if we aborted.
(if button (cond ,@cond-forms) ,abort-value)))))
(defun menu-choose-from-structure (m)
"This takes a menu structure as returned by menu-prepare and displays it
on the screen in the same way menu-choose does."
(funcall (menu-return-form m) m))
;;; Prepare a menu. This is all done with make-menu, except that spacing
;;; has to be set after the font, so we do it after the make-menu call.
;;; Eval the fonts here only if supplied for the particular item, so not :font
;;; or :label-font. At choose-with-defaults time fill in :font and :label-font.
(defmacro menu-prepare (&rest args)
"This prepares a menu. Its args are taken in the same form as menu-choose,
but it returns a menu structure which menu-choose-from-structure can display."
(let* ((items (mapcar #'construct-item (cadr (member :items args))))
;; These are the defaults for things that are ports, and thus
;; have there names spliced into the form, rather than being evalled
;; and stored.
(title-font '(italic-font *user-font*))
(label-font '(italic-font *user-font*))
(normal-font '*user-font*)
(in-window '*default-menu-choose-in-window*)
(args (do* ((l args (cdr l))
(new-args '()))
((null l) (nreverse new-args))
(case (car l)
(:items
(push :items new-args)
(push `',items new-args)
(setf l (cdr l)))
(:title-font
(setq title-font (cadr l))
(setf l (cdr l)))
(:label-font
(setq label-font (cadr l))
(setf l (cdr l)))
(:font
(setq normal-font (cadr l))
(setf l (cdr l)))
(:in-window
(setq in-window (cadr l))
(setf l (cdr l)))
(t (push (car l) new-args)))))
(cond-forms '())
(font-setf-forms '()))
(do* ((i items (cdr i))
(item (car i) (car i)))
((null i))
(unless (eq item :new-column)
(push `((string-equal item ,(item-name item)) ,(item-return item))
cond-forms)
(let ((font (case (item-font item)
(:font normal-font)
(:label-font label-font)
(t (item-font item)))))
(push `(setf (item-font (car temp)) ,font) font-setf-forms)))
(push `(setq temp (cdr temp)) font-setf-forms))
`(let* ((m (make-menu ,@args))
(temp (menu-items m)))
,@(nreverse font-setf-forms)
(setf (menu-return-form m)
#'(lambda (m)
(multiple-value-bind (item button)
(menu-choose-function
(menu-items m) (menu-stay-in-place m) (menu-title m)
,title-font (menu-position-x m)
(menu-position-y m) ,in-window
(menu-default-item m) (menu-items-justified m)
,normal-font ,label-font (menu-ncolumns m)
(menu-spacing m) (menu-abort-value m))
;; Make the default item be the last one chosen, for the
;; next time this lambda is called.
(if item (setf (menu-default-item m) item))
;; Button is the button pressed, nil if we aborted.
(if button (cond ,@cond-forms) (menu-abort-value m)))))
(if (not (menu-spacing m))
(setf (menu-spacing m) (font-string-width "xx" ,normal-font)))
m)))