(FILECREATED "18-APR-83 18:55:34" {PHYLUM}<LISPCORE>SOURCES>MENU.;37 42778
changes to: (FNS ADDMENU MENUBUTTONFN)
previous date: "24-MAR-83 16:37:39" {PHYLUM}<LISPCORE>SOURCES>MENU.;36)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT MENUCOMS)
(RPAQQ MENUCOMS ((* window functions)
(FNS MENU ADDMENU DELETEMENU MENUREGION BLTMENUIMAGE ERASEMENUIMAGE DEFAULTMENUHELDFN
DEFAULTWHENSELECTEDFN BACKGROUNDWHENSELECTEDFN GETMENUITEM MENUBUTTONFN MENU.HANDLER
DOSELECTEDITEM \FDECODE/BUTTON MENUITEMREGION \MENUITEMLABEL CHECK/MENU/IMAGE PPROMPT2
UPDATE/MENU/IMAGE \SHOWMENULABEL WFROMMENU)
(DECLARE: DONTCOPY (MACROS MENU.HELDSTATE.RESET))
(* scrolling menu functions and utilities)
(INITVARS (MENUFONT (FONTCREATE (QUOTE HELVETICA)
10)))
(FNS MENUREPAINTFN)
(* misc utility fns.)
(FNS MAXSTRINGWIDTH CENTEREDPRIN1 CENTERPRINTINREGION CENTERPRINTINAREA STRICTLY/BETWEEN)
(COMS (* examples of use.)
(FNS UNREADITEM TYPEINMENU SHADEITEM MOST/VISIBLE/OPERATION #BITSON BUTTONPANEL
BUTTONPANEL/SELECTION/FN GETSELECTEDITEMS)
(VARS EDITCMDS MENUHELDWAIT)
(CONSTANTS (BITSPERSHADE 16))
(GLOBALVARS MENUSELECTSHADE)
(VARS MENUSELECTSHADE)
(FNS MENUDESELECT MENUSELECT))
(DECLARE: DOCOPY DONTEVAL@LOAD (VARS (MENUFONT)))
(GLOBALVARS MENUFONT MENUHELDWAIT)
(EXPORT (RECORDS MENU))))
(* window functions)
(DEFINEQ
(MENU
[LAMBDA (MENU POSITION) (* rrb " 3-MAR-82 11:39")
(DECLARE (LOCALVARS . T)) (* puts a menu on the screen and waits for the user to
select one of the items)
(OR (TYPENAMEP MENU (QUOTE MENU))
(\ILLEGAL.ARG MENU))
(PROG (IMAGE MX MY) (* make sure the image is a window)
(CHECK/MENU/IMAGE MENU T)
(SETQ IMAGE (fetch (MENU IMAGE) of MENU))
(COND
((AND (OR POSITION (SETQ POSITION (fetch (MENU MENUPOSITION) of MENU)))
(FIXP (fetch XCOORD of POSITION))
(FIXP (fetch YCOORD of POSITION)))
(SETQ MX (fetch XCOORD of POSITION))
(SETQ MY (fetch YCOORD of POSITION)))
(T (GETMOUSESTATE)
(SETQ MX LASTMOUSEX)
(SETQ MY LASTMOUSEY)))
[SETQ MX (IDIFFERENCE MX (fetch XCOORD of (fetch MENUOFFSET of MENU]
[SETQ MY (IDIFFERENCE MY (fetch YCOORD of (fetch MENUOFFSET of MENU]
(* Adjust the position so that the menu will be entirely
on the screen.)
(PROGN (* do left margin first so that if the menu is wider
than the screen, the left most part of it will be shown)
(SETQ MX (IMAX (IMIN MX (IDIFFERENCE SCREENWIDTH (fetch (MENU IMAGEWIDTH)
of MENU)))
0)))
[PROGN (* do the bottom margin first so that the top of the
menu will show if the menu is higher than the a screen)
(SETQ MY (IMIN (IMAX MY 0)
(IDIFFERENCE SCREENHEIGHT (fetch (MENU IMAGEHEIGHT) of MENU]
(MOVEW IMAGE (create POSITION
XCOORD ← MX
YCOORD ← MY))
(SETQ MX (RESETLST (RESETSAVE (OPENW IMAGE)
(LIST (QUOTE CLOSEW)
IMAGE))
(until (MOUSESTATE (OR LEFT RIGHT MIDDLE)) do
(* Wait for a mouse button))
(MENU.HANDLER MENU (WINDOWPROP IMAGE (QUOTE DSP))
T T))) (* evaluate menu form after image has been taken down.)
(RETURN (COND
(MX (DOSELECTEDITEM MENU (CAR MX)
(CDR MX])
(ADDMENU
[LAMBDA (ADDEDMENU W POSITION SCROLLFLG) (* rrb "18-APR-83 17:19")
(* adds a menu to a window. If W is not given, it is
created; sized a necessary.)
(OR (TYPENAMEP ADDEDMENU (QUOTE MENU))
(\ILLEGAL.ARG ADDEDMENU))
(PROG ((IMAGEWIDTH (fetch (MENU IMAGEWIDTH) of ADDEDMENU))
(IMAGEHEIGHT (fetch (MENU IMAGEHEIGHT) of ADDEDMENU)))
(* put menu at POSITION if argument, otherwise its
stored position, otherwise at cursorposition)
[COND
((POSITIONP POSITION))
((SETQ POSITION (fetch (MENU MENUPOSITION) of ADDEDMENU)))
(W (* if a window is given, put it in the lower left
corner.)
(SETQ POSITION (create POSITION
XCOORD ← 0
YCOORD ← 0)))
(T (SETQ POSITION (create POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY]
(COND
[(ACTIVEWP W)
(* adding to an existing window. To avoid partial images when window is partly off the screen, this case could
close window then blt to save region then reopen window.)
(* locate menu grid in MENU.)
(replace (REGION LEFT) of (fetch (MENU MENUGRID) of ADDEDMENU)
with (IPLUS (fetch (POSITION XCOORD) of POSITION)
(fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)))
(replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of ADDEDMENU)
with (IPLUS (fetch (POSITION YCOORD) of POSITION)
(fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)))
(* Blt image into Window.)
(BLTMENUIMAGE ADDEDMENU (WINDOWPROP W (QUOTE DSP]
(T (* have to create new window.
Put position at Origin.)
[SETQ W (CREATEWFROMIMAGE (BITMAPCOPY (CHECK/MENU/IMAGE ADDEDMENU]
(MOVEW W POSITION)
(SETQ POSITION (create POSITION
XCOORD ← 0
YCOORD ← 0)) (* locate menu grid in MENU.)
(replace (REGION LEFT) of (fetch (MENU MENUGRID) of ADDEDMENU)
with (fetch (MENU MENUOUTLINESIZE) of ADDEDMENU))
(replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of ADDEDMENU)
with (fetch (MENU MENUOUTLINESIZE) of ADDEDMENU))
(OPENW W))) (* put MENUBUTTONFN in CURSORINFN so it will get called
if button is down and moves into W.)
(WINDOWPROP W (QUOTE CURSORINFN)
(FUNCTION MENUBUTTONFN)) (* Set ButtonEventFn to activate menu selection.)
(WINDOWPROP W (QUOTE BUTTONEVENTFN)
(FUNCTION MENUBUTTONFN))
(WINDOWPROP W (QUOTE CURSORMOVEDFN)
(FUNCTION MENUBUTTONFN)) (* put ADDEDMENU on USERDATA so MENUBUTTONFN can get at
it.)
(WINDOWADDPROP W (QUOTE MENU)
ADDEDMENU)
(WINDOWPROP W (QUOTE REPAINTFN)
(FUNCTION MENUREPAINTFN))
[COND
((NULL (fetch (MENU WHENSELECTEDFN) of ADDEDMENU))
(* make the default selection function call
EVAL.AS.PROCESS instead of EVAL so it won't tie up
background.)
(replace (MENU WHENSELECTEDFN) of ADDEDMENU with (FUNCTION BACKGROUNDWHENSELECTEDFN]
[COND
(SCROLLFLG (WINDOWPROP W (QUOTE SCROLLFN)
(FUNCTION SCROLLBYREPAINTFN))
(EXTENDEXTENT W (MENUREGION ADDEDMENU]
(RETURN W])
(DELETEMENU
[LAMBDA (MENU CLOSEFLG FROMWINDOW) (* rrb " 8-DEC-82 13:17")
(* deletes a menu from its window.
If it is the only menu in the window and CLOSEFLG is
non-NIL, it closes the window.)
(OR (TYPENAMEP MENU (QUOTE MENU))
(\ILLEGAL.ARG MENU))
(PROG ([W (COND
((type? WINDOW FROMWINDOW)
FROMWINDOW)
(T (WFROMMENU MENU]
OTHERMENUS) (* see if menu is in a window.)
(OR W (RETURN)) (* Blt image out of Window.)
(ERASEMENUIMAGE MENU W)
[COND
[[NULL (CDR (SETQ OTHERMENUS (WINDOWPROP W (QUOTE MENU]
(* last menu)
(OR (EQ MENU (CAR OTHERMENUS))
(ERROR "MENU not correctly in W"))
(WINDOWPROP W (QUOTE MENU)
NIL)
(COND
(CLOSEFLG (CLOSEW W]
(T (WINDOWPROP W (QUOTE MENU)
(DREMOVE MENU OTHERMENUS]
(RETURN W])
(MENUREGION
[LAMBDA (MENU) (* rrb " 9-FEB-82 09:37")
(* returns the region covered by the image of a MENU)
(* calls IMAGEWIDTH first so that it will calculate an
image if none exists yet.)
(create REGION
WIDTH ←(fetch (MENU IMAGEWIDTH) of MENU)
HEIGHT ←(fetch (MENU IMAGEHEIGHT) of MENU)
LEFT ←(fetch (MENU MENUREGIONLEFT) of MENU)
BOTTOM ←(fetch (MENU MENUREGIONBOTTOM) of MENU])
(BLTMENUIMAGE
[LAMBDA (MENU DS) (* rrb " 9-FEB-82 09:34")
(* Displays a menu image at its position on DS.)
(BITBLT (COND
((type? WINDOW (fetch IMAGE of MENU))
(fetch (WINDOW SAVE) of (fetch (MENU IMAGE) of MENU)))
(T (fetch IMAGE of MENU)))
NIL NIL DS (fetch (MENU MENUREGIONLEFT) of MENU)
(fetch (MENU MENUREGIONBOTTOM) of MENU])
(ERASEMENUIMAGE
[LAMBDA (MENU W) (* rrb "19-MAR-82 10:26")
(* removes the menu image from a window by clearing the place it used to occupy. Image may be different from
stored image because user may have shaded an item.)
(BITBLT NIL NIL NIL (WINDOWPROP W (QUOTE DSP))
(IDIFFERENCE (fetch (REGION LEFT) of (fetch (MENU MENUGRID) of MENU))
(fetch MENUOUTLINESIZE of MENU))
(IDIFFERENCE (fetch (REGION BOTTOM) of (fetch (MENU MENUGRID) of MENU))
(fetch MENUOUTLINESIZE of MENU))
(fetch (MENU IMAGEWIDTH) of MENU)
(fetch (MENU IMAGEHEIGHT) of MENU)
(QUOTE TEXTURE)
(QUOTE REPLACE])
(DEFAULTMENUHELDFN
[LAMBDA (ITEM) (* rrb "23-NOV-81 12:41")
(COND
((AND (LISTP ITEM)
(CADDR ITEM))
(PROMPTPRINT (CADDR ITEM)))
(T (PROMPTPRINT "Will select this item when you release the button."])
(DEFAULTWHENSELECTEDFN
[LAMBDA (ITEM FROMMENU BUTTON) (* rrb "16-MAR-82 15:35")
(* default Menu handler)
(COND
[(LISTP ITEM)
(COND
((CDR ITEM)
(STKEVAL (OR (STKPOS (QUOTE MENU))
(QUOTE MENUBUTTONFN))
(CADR ITEM)
T))
(T (CAR ITEM]
(T ITEM])
(BACKGROUNDWHENSELECTEDFN
[LAMBDA (ITEM FROMMENU BUTTON) (* rrb "27-AUG-82 10:17")
(* default Menu handler for fixed menus.
It differs from DEFAULTWHENSELECTEDFN by calling
EVAL.AS.PROCESS instead of EVAL.)
(COND
[(LISTP ITEM)
(COND
((CDR ITEM)
(EVAL.AS.PROCESS (CADR ITEM)))
(T (CAR ITEM]
(T ITEM])
(GETMENUITEM
[LAMBDA (MENU XGRID YGRID) (* rrb "31-JUL-81 07:31")
(* returns the menu item that is in grid location
{XGRID,YGRID}.)
(CAR (FNTH (fetch (MENU ITEMS) of MENU)
(IPLUS (ITIMES (SUB1 (IDIFFERENCE (fetch MENUROWS of MENU)
YGRID))
(fetch MENUCOLUMNS of MENU))
XGRID 1])
(MENUBUTTONFN
[LAMBDA (W) (* rrb "18-APR-83 17:19")
(COND
[(LASTMOUSESTATE (OR LEFT MIDDLE RIGHT))
(TOTOPW W)
(bind SELECTION for MENU in (WINDOWPROP W (QUOTE MENU)) when [SETQ SELECTION
(MENU.HANDLER
MENU
(WINDOWPROP W (QUOTE DSP]
do (DOSELECTEDITEM MENU (CAR SELECTION)
(CDR SELECTION]
(T (* must have been button up or a cursor move event.)
NIL])
(MENU.HANDLER
[LAMBDA (MENU DSP KEEPCONTROLIFOUTFLG CHANGEOFFSETFLG) (* rrb "19-MAR-82 10:57")
(* handles details of watching mouse for menus.)
(bind OLDBOXX OLDBOXY BOXX BOXY HELDSTATE LASTBUTTONSTATE←LASTMOUSEBUTTONS
(MGRIDSPEC ←(fetch (MENU MENUGRID) of MENU))
(HOLDBEGTIME ←(CLOCK 0))
(HELDFN ←(fetch (MENU WHENHELDFN) of MENU)) until (MOUSESTATE UP)
do (COND
[(AND (STRICTLY/BETWEEN (SETQ BOXY (GRIDYCOORD (LASTMOUSEY DSP)
MGRIDSPEC))
-1
(fetch (MENU MENUROWS) of MENU))
(STRICTLY/BETWEEN (SETQ BOXX (GRIDXCOORD (LASTMOUSEX DSP)
MGRIDSPEC))
-1
(fetch (MENU MENUCOLUMNS) of MENU)))
(* BOXX and BOXY hold the number of the box pointed at.)
(COND
((OR (NEQ BOXX OLDBOXX)
(NEQ BOXY OLDBOXY)) (* selected item has changed.)
(* uninvert old item if there was one.)
[COND
(OLDBOXX (SHADEGRIDBOX OLDBOXX OLDBOXY BLACKSHADE (QUOTE INVERT)
MGRIDSPEC
(fetch (MENU MENUBORDERSIZE) of MENU)
(COND
((EQ DSP T)
(SCREENBITMAP))
(T DSP)))
(MENU.HELDSTATE.RESET OLDBOXX OLDBOXY))
(T (SETQ HOLDBEGTIME (CLOCK0 HOLDBEGTIME]
(* invert new item)
(SHADEGRIDBOX BOXX BOXY BLACKSHADE (QUOTE INVERT)
MGRIDSPEC
(fetch (MENU MENUBORDERSIZE) of MENU)
(COND
((EQ DSP T)
(SCREENBITMAP))
(T DSP)))
(SETQ OLDBOXX BOXX)
(SETQ OLDBOXY BOXY))
((AND HELDFN (NULL HELDSTATE)
(IGREATERP (CLOCKDIFFERENCE HOLDBEGTIME)
MENUHELDWAIT)) (* same button in same region for MENUHELDWAIT
milliseconds.)
(APPLY* HELDFN (GETMENUITEM MENU OLDBOXX OLDBOXY)
MENU
(\FDECODE/BUTTON LASTBUTTONSTATE))
(SETQ HELDSTATE T]
(T (* cursor moved outside of the menu.)
(COND
(OLDBOXX (SHADEGRIDBOX OLDBOXX OLDBOXY BLACKSHADE (QUOTE INVERT)
MGRIDSPEC
(fetch (MENU MENUBORDERSIZE) of MENU)
(COND
((EQ DSP T)
(SCREENBITMAP))
(T DSP)))
(MENU.HELDSTATE.RESET OLDBOXX OLDBOXY)))
(* OLDBOXX denotes item inverted.)
(COND
((NOT KEEPCONTROLIFOUTFLG)
(RETURN)))
(SETQ OLDBOXX)))
(COND
((NEQ LASTBUTTONSTATE (SETQ LASTBUTTONSTATE LASTMOUSEBUTTONS))
(* reset held timer)
(MENU.HELDSTATE.RESET OLDBOXX OLDBOXX)))
finally (* turn off inverse image. and call whenunheldfn is
necessary.)
(COND
(OLDBOXX (SHADEGRIDBOX OLDBOXX OLDBOXY BLACKSHADE (QUOTE INVERT)
MGRIDSPEC
(fetch (MENU MENUBORDERSIZE) of MENU)
(COND
((EQ DSP T)
(SCREENBITMAP))
(T DSP)))
(MENU.HELDSTATE.RESET OLDBOXX OLDBOXY)))
(* if called for, change the menu offset so the menu
will come up in the same place relative to the cursor
next time.)
[COND
((AND CHANGEOFFSETFLG OLDBOXX)
[SELECTQ (fetch (MENU CHANGEOFFSETFLG) of MENU)
((Y NIL))
(replace (POSITION XCOORD) of (fetch (MENU MENUOFFSET) of MENU)
with (IDIFFERENCE (LASTMOUSEX DSP)
(fetch (REGION LEFT) of MGRIDSPEC]
(SELECTQ (fetch (MENU CHANGEOFFSETFLG) of MENU)
((X NIL))
(replace (POSITION YCOORD) of (fetch (MENU MENUOFFSET) of MENU)
with (IDIFFERENCE (LASTMOUSEY DSP)
(fetch (REGION BOTTOM) of MGRIDSPEC]
(RETURN (COND
(OLDBOXX (CONS (GETMENUITEM MENU OLDBOXX OLDBOXY)
(\FDECODE/BUTTON LASTBUTTONSTATE])
(DOSELECTEDITEM
[LAMBDA (MENU ITEM BUTTON) (* rrb "28-JAN-82 16:33")
(APPLY* (OR (fetch WHENSELECTEDFN of MENU)
(FUNCTION DEFAULTWHENSELECTEDFN))
ITEM MENU BUTTON])
(\FDECODE/BUTTON
[LAMBDA (BUTTONSTATE) (* rrb " 9-JAN-82 13:59")
(* return RED BLUE or YELLOW from a button state.)
(SELECTQ BUTTONSTATE
(4 (QUOTE LEFT))
(2 (QUOTE RIGHT))
(1 (QUOTE MIDDLE))
NIL])
(MENUITEMREGION
[LAMBDA (ITEM IMENU) (* rrb "27-AUG-82 12:01")
(* returns the region for ITEM in IMENU.
NIL if ITEM isn't in IMENU.)
(PROG (ITEMNUMBER (ITEMS (fetch (MENU ITEMS) of IMENU))
(GRIDSPEC (fetch (MENU MENUGRID) of IMENU))
(BORDER (fetch (MENU MENUBORDERSIZE) of IMENU)))
[SETQ ITEMNUMBER (IDIFFERENCE (LENGTH ITEMS)
(LENGTH (OR (FMEMB ITEM ITEMS)
(for ITEMTAIL on ITEMS
when (EQ (CAAR ITEMTAIL)
ITEM)
do (RETURN ITEMTAIL))
(RETURN]
(RETURN (create REGION
LEFT ←(IPLUS (fetch (REGION LEFT) of GRIDSPEC)
(ITIMES (IREMAINDER ITEMNUMBER (fetch (MENU MENUCOLUMNS)
of IMENU))
(fetch (REGION WIDTH) of GRIDSPEC))
BORDER)
BOTTOM ←(IPLUS (fetch (REGION BOTTOM) of GRIDSPEC)
(ITIMES [SUB1 (IDIFFERENCE (fetch (MENU MENUROWS)
of IMENU)
(IQUOTIENT ITEMNUMBER
(fetch (MENU
MENUCOLUMNS)
of IMENU]
(fetch (REGION HEIGHT) of GRIDSPEC))
BORDER)
WIDTH ←(IDIFFERENCE (fetch (REGION WIDTH) of GRIDSPEC)
(ITIMES 2 BORDER))
HEIGHT ←(IDIFFERENCE (fetch (REGION HEIGHT) of GRIDSPEC)
(ITIMES 2 BORDER])
(\MENUITEMLABEL
[LAMBDA (ITEM) (* rrb "21-AUG-81 08:13")
(* returns the item label of an item.)
(COND
((LISTP ITEM)
(CAR ITEM))
(T ITEM])
(CHECK/MENU/IMAGE
[LAMBDA (MENU MAKEWINDOWFLG) (* rrb " 4-MAR-82 17:20")
(* returns menus image, creating one if necessary.
The image field will be a WINDOW for popup menus.)
(PROG (IMAGE)
(SETQ IMAGE (OR (fetch (MENU IMAGE) of MENU)
(UPDATE/MENU/IMAGE MENU)))
[COND
(MAKEWINDOWFLG (PROG (DSP)
[COND
((type? WINDOW IMAGE)
(UPDATEWFROMIMAGE IMAGE)
(SETQ DSP (fetch (WINDOW DSP) of IMAGE))
(SETQ IMAGE (fetch (WINDOW SAVE) of IMAGE)))
(T (SETQ DSP (fetch (WINDOW DSP) of (replace (MENU IMAGE)
of MENU
with (CREATEWFROMIMAGE
IMAGE]
(* set the offset in the display stream to agree with
the region.)
(DSPXOFFSET 0 DSP)
(DSPYOFFSET 0 DSP]
(RETURN (COND
((type? BITMAP IMAGE)
IMAGE)
(T (fetch (WINDOW SAVE) of IMAGE])
(PPROMPT2
[LAMBDA (ITEM) (* rrb "17-NOV-81 14:09")
(* prints the second element of ITEM in the prompt
window.)
(COND
((AND (LISTP ITEM)
(CADR ITEM))
(PROMPTPRINT (CADR ITEM])
(UPDATE/MENU/IMAGE
[LAMBDA (MNU) (* rrb "24-MAR-83 16:34")
(DECLARE (GLOBALVARS WindowTitleDisplayStream)) (* recomputes the menu image from its labels.)
(PROG (NUMCOLS NUMROWS WIDTH HEIGHT (DSP (DSPCREATE))
BLK COLWIDTH ROWHEIGHT FASCENT HEIGHTOFFSET (MENUITEMS (fetch (MENU ITEMS)
of MNU))
BORDER OUTLINE FONT WINDOW TITLE CENTER?)
(* check the font.)
(COND
[(FONTP (SETQ FONT (AND (fetch (MENU MENUFONT) of MNU)
(\GETFONTDESC (fetch (MENU MENUFONT) of MNU)
(QUOTE DISPLAY)
T]
(T [SETQ FONT (COND
((FONTP MENUFONT))
(T (SETQ MENUFONT (FONTCREATE (QUOTE HELVETICA)
10] (* keep font in the menu)
(replace (MENU MENUFONT) of MNU with FONT)))
(* calculate the number of columns and rows)
[COND
[(NUMBERP (fetch (MENU MENUCOLUMNS) of MNU))
(SETQ NUMCOLS (fetch (MENU MENUCOLUMNS) of MNU))
(SETQ NUMROWS (COND
((NUMBERP (fetch (MENU MENUROWS) of MNU)))
(T (replace (MENU MENUROWS) of MNU with (ADD1 (IQUOTIENT (SUB1 (LENGTH MENUITEMS))
NUMCOLS]
[(NUMBERP (fetch (MENU MENUROWS) of MNU))
(SETQ NUMROWS (fetch (MENU MENUROWS) of MNU))
(replace (MENU MENUCOLUMNS) of MNU with (SETQ NUMCOLS
(ADD1 (IQUOTIENT (SUB1 (LENGTH MENUITEMS))
NUMROWS]
(T (SETQ NUMCOLS (replace (MENU MENUCOLUMNS) of MNU with 1))
(SETQ NUMROWS (replace (MENU MENUROWS) of MNU with (LENGTH MENUITEMS]
(* set BORDER to the size of the outline around each menu item and OUTLINE to the size of the outline around the
whole menu.)
(SETQ BORDER (OR (FIXP (fetch (MENU MENUBORDERSIZE) of MNU))
(replace (MENU MENUBORDERSIZE) of MNU with 0)))
[SETQ OUTLINE (OR (FIXP (fetch (MENU MENUOUTLINESIZE) of MNU))
(replace (MENU MENUOUTLINESIZE) of MNU with (IMAX BORDER 1]
(SETQ WIDTH
(IPLUS (ITIMES (COND
[(IGREATERP (SETQ COLWIDTH (fetch (MENU ITEMWIDTH) of MNU))
5000)
(* If ITEMWIDTH is greater than 5000, it was probably default clipping region. if no columnwidth is given {common
case}, calculate it from the items widths.)
(replace (MENU ITEMWIDTH) of MNU
with (SETQ COLWIDTH
(IMAX (IPLUS (for I in MENUITEMS bind LABEL
(M ← 0)
do (SETQ LABEL (\MENUITEMLABEL I))
[SETQ M
(IMAX M
(COND
((BITMAPP LABEL)
(fetch (BITMAP BITMAPWIDTH)
of LABEL))
(T (STRINGWIDTH LABEL FONT NIL
NIL]
finally (RETURN M))
(ITIMES (ADD1 BORDER)
2))
(COND
((fetch (MENU TITLE) of MNU)
(* make title be in the same font as the rest of the
titles in the system)
(IPLUS (STRINGWIDTH (fetch (MENU TITLE)
of MNU)
WindowTitleDisplayStream)
2))
(T 0]
(T COLWIDTH))
NUMCOLS)
(ITIMES OUTLINE 2)))
[SETQ HEIGHT
(IPLUS [ITIMES NUMROWS
(SETQ ROWHEIGHT
(COND
((ILESSP (SETQ HEIGHT (fetch (MENU ITEMHEIGHT) of MNU))
5000)
HEIGHT)
(T (replace (MENU ITEMHEIGHT) of MNU
with (IPLUS (IMAX (for I in MENUITEMS bind LABEL
(M ← 0)
do (SETQ LABEL (\MENUITEMLABEL I))
[SETQ M (IMAX M (COND
((BITMAPP LABEL)
(fetch (BITMAP
BITMAPHEIGHT)
of LABEL))
(T 0]
finally (RETURN M))
(FONTPROP FONT (QUOTE HEIGHT)))
(ITIMES BORDER 2]
(ITIMES OUTLINE 2)
(COND
((fetch (MENU TITLE) of MNU)
(FONTPROP (DSPFONT NIL WindowTitleDisplayStream)
(QUOTE HEIGHT)))
(T 0]
[SETQ BLK (COND
((AND [SETQ BLK (COND
((type? BITMAP (SETQ BLK (fetch (MENU IMAGE) of MNU)))
BLK)
((type? WINDOW BLK) (* if it is a window, make sure it is not active, then)
(CLOSEW BLK)
(fetch (WINDOW SAVE) of BLK]
(EQ (BITMAPWIDTH BLK)
WIDTH)
(EQ (fetch (BITMAP BITMAPHEIGHT) of BLK)
HEIGHT)) (* reuse current image bitmap)
BLK)
(T (* create a new one)
(BITMAPCREATE WIDTH HEIGHT]
(BITBLT NIL NIL NIL BLK 0 0 WIDTH HEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE) (* Draw box by nested BitBlts)
(* leave outline)
(BITBLT NIL NIL NIL BLK OUTLINE OUTLINE (IDIFFERENCE WIDTH (ITIMES OUTLINE 2))
(IDIFFERENCE HEIGHT (IPLUS (COND
((fetch (MENU TITLE) of MNU)
(FONTPROP (DSPFONT NIL WindowTitleDisplayStream)
(QUOTE HEIGHT)))
(T 0))
(ITIMES OUTLINE 2)))
(QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
(DSPDESTINATION BLK DSP)
(replace (REGION LEFT) of (fetch (MENU MENUGRID) of MNU) with OUTLINE)
(replace (REGION BOTTOM) of (fetch MENUGRID of MNU) with OUTLINE)
(GRID (fetch MENUGRID of MNU)
NUMCOLS NUMROWS BORDER DSP)
(DSPOPERATION (QUOTE INVERT)
DSP)
(DSPFONT FONT DSP)
(SETQ CENTER? (fetch (MENU CENTERFLG) of MNU))
[COND
((SETQ TITLE (fetch (MENU TITLE) of MNU)) (* if there is a title, put it in the same font as
window titles)
(SHOWWTITLE TITLE BLK BORDER CENTER?)
(SETQ HEIGHT (IDIFFERENCE HEIGHT (FONTPROP (DSPFONT NIL WindowTitleDisplayStream)
(QUOTE HEIGHT]
(* calculate the offset from the top of the item box to
the base line of the printed item.)
(SETQ HEIGHTOFFSET (IPLUS (SETQ FASCENT (FONTPROP FONT (QUOTE ASCENT)))
(IQUOTIENT (IDIFFERENCE ROWHEIGHT FASCENT)
2)))
[PROG ((ITEMREGION (create REGION
LEFT ←(IPLUS OUTLINE BORDER)
BOTTOM ←(IDIFFERENCE (IDIFFERENCE HEIGHT ROWHEIGHT)
OUTLINE)
WIDTH ←(IDIFFERENCE (fetch (REGION WIDTH)
of (fetch (MENU MENUGRID) of MNU))
(ITIMES BORDER 2))
HEIGHT ← ROWHEIGHT))
(COL# 1))
LP (COND
(MENUITEMS (\SHOWMENULABEL (CAR MENUITEMS)
ITEMREGION MNU DSP CENTER?)
(SETQ MENUITEMS (CDR MENUITEMS))
[COND
((EQ COL# NUMCOLS) (* advance to the next row)
(SETQ COL# 1)
(replace (REGION BOTTOM) of ITEMREGION
with (IDIFFERENCE (fetch (REGION BOTTOM) of ITEMREGION)
ROWHEIGHT))
(replace (REGION LEFT) of ITEMREGION with (IPLUS OUTLINE BORDER)))
(T (SETQ COL# (ADD1 COL#))
(replace (REGION LEFT) of ITEMREGION
with (IPLUS (fetch (REGION LEFT) of ITEMREGION)
COLWIDTH]
(GO LP]
[COND
((NULL (fetch (MENU MENUOFFSET) of MNU))
(* set offset so cursor will be be in middle of the menu on first display if it is to move with the cursor.
If it is fixed offset, initialize it to 0)
(replace (MENU MENUOFFSET) of MNU
with (COND
((fetch (MENU CHANGEOFFSETFLG) of MNU)
(create POSITION
XCOORD ←(IQUOTIENT WIDTH 2)
YCOORD ←(IQUOTIENT HEIGHT 2)))
(T (create POSITION
XCOORD ← 0
YCOORD ← 0]
[COND
((type? WINDOW (SETQ WINDOW (fetch (MENU IMAGE) of MNU)))
(* menu has a window, replace its save image.)
(replace (WINDOW SAVE) of WINDOW with BLK))
(T (replace (MENU IMAGE) of MNU with (SETQ WINDOW (CREATEWFROMIMAGE BLK]
(* tell the window about its border and title.)
(replace (WINDOW WTITLE) of WINDOW with (fetch (MENU TITLE) of MNU))
(replace (WINDOW WBORDER) of WINDOW with OUTLINE)
(ADVISEWDS WINDOW) (* snap circular link between the display stream created
for printing and its stream.)
(replace (DISPLAYSTREAM \SFOFD) of DSP with NIL)
(RETURN (fetch (WINDOW SAVE) of (fetch (MENU IMAGE) of MNU])
(\SHOWMENULABEL
[LAMBDA (ITEM ITEMREGION MENU DSP CENTER?) (* rrb "23-FEB-83 16:41")
(* displays the item label for ITEM in the region
ITEMREGION on the stream DSP according to the formatting
information from MENU.)
(PROG ((LABEL (\MENUITEMLABEL ITEM)))
(RETURN (COND
[(BITMAPP LABEL) (* bitblt the label using the default operation of the
displaystream.)
(COND
(CENTER? (BITBLT LABEL 0 0 DSP (IPLUS (fetch (REGION LEFT) of ITEMREGION)
(IQUOTIENT (IDIFFERENCE
(fetch (REGION WIDTH)
of ITEMREGION)
(BITMAPWIDTH LABEL))
2))
(IPLUS (fetch (REGION BOTTOM) of ITEMREGION)
(IQUOTIENT (IDIFFERENCE (fetch (REGION HEIGHT)
of ITEMREGION)
(fetch (BITMAP BITMAPHEIGHT)
of LABEL))
2))
NIL NIL (QUOTE INPUT)
NIL NIL ITEMREGION))
(T (BITBLT LABEL 0 0 DSP (fetch (REGION LEFT) of ITEMREGION)
(fetch (REGION BOTTOM) of ITEMREGION)
(fetch (REGION WIDTH) of ITEMREGION)
(fetch (REGION HEIGHT) of ITEMREGION)
(QUOTE INPUT)
NIL NIL]
(CENTER? (CENTERPRINTINREGION LABEL ITEMREGION DSP))
(T (DSPXPOSITION (ADD1 (fetch (REGION LEFT) of ITEMREGION))
DSP)
(DSPYPOSITION (IPLUS (fetch (REGION BOTTOM) of ITEMREGION)
(FONTDESCENT (DSPFONT NIL DSP)))
DSP)
(PRIN3 LABEL DSP])
(WFROMMENU
[LAMBDA (MENU) (* rrb "20-AUG-81 12:31")
(* finds the window that menu is in if any.)
(for WINDOW←TOPW by (fetch NEXTW of WINDOW) while WINDOW thereis (MEMB MENU (WINDOWPROP
WINDOW
(QUOTE MENU])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS MENU.HELDSTATE.RESET MACRO ((BX BY)
[COND
(HELDSTATE (COND
((SETQ HELDSTATE (fetch (MENU WHENUNHELDFN)
of MENU))
(APPLY* HELDSTATE (GETMENUITEM MENU BX BY)
MENU
(\FDECODE/BUTTON LASTBUTTONSTATE))
(SETQ HELDSTATE NIL]
(SETQ HOLDBEGTIME (CLOCK0 HOLDBEGTIME))))
)
)
(* scrolling menu functions and utilities)
(RPAQ? MENUFONT (FONTCREATE (QUOTE HELVETICA)
10))
(DEFINEQ
(MENUREPAINTFN
[LAMBDA (WINDOW REG) (* rrb " 5-JAN-82 16:41")
(* repaints the menus in a window.)
(PROG [(DSP (WINDOWPROP WINDOW (QUOTE DSP] (* stuff new images over old)
(for MENU in (REVERSE (WINDOWPROP WINDOW (QUOTE MENU))) do (BLTMENUIMAGE MENU DSP])
)
(* misc utility fns.)
(DEFINEQ
(MAXSTRINGWIDTH
[LAMBDA (L FONT PRIN2FLG RDTBL) (* rrb " 9-JAN-82 13:49")
(for I in L bind M←0 do (SETQ M (IMAX M (STRINGWIDTH I FONT PRIN2FLG RDTBL)))
finally (RETURN M])
(CENTEREDPRIN1
[LAMBDA (EXP DS LEFT WIDTH Y) (* rrb "17-DEC-82 15:53")
(* prints an expression in the middle of a width.)
(MOVETO (IPLUS LEFT (IQUOTIENT (IDIFFERENCE WIDTH (STRINGWIDTH EXP DS))
2))
Y DS)
(PRIN3 EXP DS])
(CENTERPRINTINREGION
[LAMBDA (EXP REGION DS) (* rrb "19-MAR-82 10:28")
(* prints an expression in the middle of a region)
(OR (type? REGION REGION)
(SETQ REGION (DSPCLIPPINGREGION NIL DS)))
(CENTERPRINTINAREA EXP (fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
(fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
DS])
(CENTERPRINTINAREA
[LAMBDA (EXP X Y WIDTH HEIGHT DS) (* rrb " 9-JAN-82 13:28")
(* prints an expression in a box.)
(SETQ DS (\SFInsureDisplayStream DS))
(PROG ((FONT (DSPFONT NIL DS))
XPOS STRWIDTH)
(MOVETO (SETQ XPOS (IPLUS X (IQUOTIENT [ADD1 (IDIFFERENCE WIDTH (SETQ STRWIDTH
(STRINGWIDTH EXP FONT]
2)))
(IPLUS Y (IQUOTIENT (IPLUS (IDIFFERENCE HEIGHT (FONTPROP FONT (QUOTE ASCENT)))
(FONTPROP FONT (QUOTE DESCENT)))
2))
DS)
(COND
((IGREATERP (IPLUS XPOS STRWIDTH)
(DSPRIGHTMARGIN NIL DS))
(* if string would cause a CR to be inserted, change the right margin to avoid it. When PRIN3 is fixed so that it
never inserts CR, this can be removed.)
(RESETLST (RESETSAVE NIL (LIST (QUOTE DSPRIGHTMARGIN)
(DSPRIGHTMARGIN (IPLUS XPOS STRWIDTH)
DS)
DS))
(PRIN3 EXP DS)))
(T (PRIN3 EXP DS])
(STRICTLY/BETWEEN
[LAMBDA (VAL LOWER HIGHER) (* rrb "30-JUL-81 14:53")
(* returns T if VAL is strictly between LOWER and
HIGHER)
(AND (IGREATERP VAL LOWER)
(IGREATERP HIGHER VAL])
)
(* examples of use.)
(DEFINEQ
(UNREADITEM
[LAMBDA (ITEM MENU BUTTON) (* rrb "31-JUL-81 17:37")
(BKSYSBUF (CONCAT (MKSTRING (COND
((LISTP ITEM)
(EVAL (CADR ITEM)))
(T ITEM)))
"
"])
(TYPEINMENU
[LAMBDA (LST) (* rrb "17-NOV-81 14:04")
(create MENU
ITEMS ← LST
WHENSELECTEDFN ← (FUNCTION UNREADITEM))])
(SHADEITEM
[LAMBDA (ITEM MENU SHADE DS/W) (* rrb "28-FEB-83 17:00")
(* shades a menu item with a background shade.
DS/W if provides is the displaystream to use.)
(PROG ((ITEMREGION (MENUITEMREGION ITEM MENU))
DSP) (* if the item isn't in MENU don't do anything.)
(OR ITEMREGION (RETURN)) (* if the menu is not in a window don't do anything.)
(OR (SETQ DSP (COND
[(NULL DS/W)
(COND
((SETQ DSP (WFROMMENU MENU))
(WINDOWPROP DSP (QUOTE DSP]
((type? WINDOW DS/W)
(WINDOWPROP DS/W (QUOTE DSP)))
((type? DISPLAYSTREAM DS/W)
DS/W)
(T NIL)))
(RETURN))
(DSPFILL ITEMREGION (OR SHADE WHITESHADE)
(QUOTE REPLACE)
DSP)
(RESETLST (RESETSAVE NIL (LIST (QUOTE DSPOPERATION)
(DSPOPERATION (MOST/VISIBLE/OPERATION (OR SHADE WHITESHADE))
DSP)
DSP))
(RESETSAVE NIL (LIST (QUOTE DSPFONT)
(DSPFONT (fetch (MENU MENUFONT) of MENU)
DSP)
DSP))
(RESETSAVE NIL (LIST (QUOTE DSPRIGHTMARGIN)
(DSPRIGHTMARGIN 3000 DSP)
DSP))
(\SHOWMENULABEL ITEM ITEMREGION MENU DSP (fetch (MENU CENTERFLG) of MENU])
(MOST/VISIBLE/OPERATION
[LAMBDA (SHADE) (* chooses the operation that is most visible way of
putting characters on a SHADE background.)
(COND
((IGREATERP (#BITSON SHADE)
8)
(QUOTE ERASE))
(T (QUOTE PAINT])
(#BITSON
[LAMBDA (N) (* rrb "16-AUG-81 18:35")
(* determines the number of bits that are on.)
(PROG ((MASK 1)
(I 1)
NBITS)
(COND
((NOT (ZEROP (LOGAND N 1)))
(SETQ NBITS 1))
(T (SETQ NBITS 0)))
LP (COND
((EQ I BITSPERSHADE)
(RETURN NBITS)))
(SETQ MASK (LLSH MASK 1))
(SETQ I (ADD1 I))
[COND
((NOT (ZEROP (LOGAND N MASK)))
(SETQ NBITS (ADD1 NBITS]
(GO LP])
(BUTTONPANEL
[LAMBDA (LABELLST) (* rrb "17-NOV-81 14:09")
(* make items which have second element that marks
whether or not they are selected.)
(create MENU
ITEMS ← (for LABEL in LABELLST collect (LIST LABEL "Release the button to select this item."
NIL))
CENTERFLG ← T
WHENSELECTEDFN ← (FUNCTION BUTTONPANEL/SELECTION/FN)
WHENHELDFN ← (FUNCTION PPROMPT2))])
(BUTTONPANEL/SELECTION/FN
[LAMBDA (ITEM MENU BUTTON WINDOW) (* rrb "10-NOV-81 09:25")
(* flips the selection and shades the background.)
(SHADEITEM ITEM MENU (COND
((CADDR ITEM)
WHITESHADE)
(T MENUSELECTSHADE))
WINDOW)
(RPLACA (CDDR ITEM)
(NOT (CADDR ITEM])
(GETSELECTEDITEMS
[LAMBDA (WMENU) (* rrb "10-NOV-81 09:26")
(for ITEM in (fetch ITEMS of WMENU) when (CADDR ITEM) collect (CAR ITEM])
)
(RPAQQ EDITCMDS ("P" "PP" ("LF" "%
")
0 1 -1 2 3 "BK" "EF" "EVAL"))
(RPAQQ MENUHELDWAIT 1200)
(DECLARE: EVAL@COMPILE
(RPAQQ BITSPERSHADE 16)
(CONSTANTS (BITSPERSHADE 16))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS MENUSELECTSHADE)
)
(RPAQQ MENUSELECTSHADE 32800)
(DEFINEQ
(MENUDESELECT
[LAMBDA (ITEM MENU) (* deselects a menu item)
(SHADEITEM ITEM MENU WHITESHADE)
(replace (MENU MENUUSERDATA) of MENU with NIL])
(MENUSELECT
[LAMBDA (ITEM MENU) (* rrb "23-SEP-81 15:26")
(* selects a menu item)
(SHADEITEM ITEM MENU MENUSELECTSHADE)
(replace (MENU MENUUSERDATA) of MENU with ITEM])
)
(DECLARE: DOCOPY DONTEVAL@LOAD
(RPAQQ MENUFONT NIL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS MENUFONT MENUHELDWAIT)
)
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE MENU (IMAGE SAVEIMAGE ITEMS MENUROWS MENUCOLUMNS MENUGRID CENTERFLG CHANGEOFFSETFLG
MENUFONT TITLE MENUOFFSET WHENSELECTEDFN MENUBORDERSIZE MENUOUTLINESIZE
WHENHELDFN MENUPOSITION WHENUNHELDFN MENUUSERDATA)
MENUGRID ←(create REGION
LEFT ← 0
BOTTOM ← 0)
WHENHELDFN ←(QUOTE DEFAULTMENUHELDFN)
WHENUNHELDFN ←(QUOTE CLRPROMPT)
[ACCESSFNS ((ITEMWIDTH (fetch (REGION WIDTH) of (fetch (MENU MENUGRID) of DATUM))
(replace (REGION WIDTH) of (fetch (MENU MENUGRID) of DATUM)
with NEWVALUE))
(ITEMHEIGHT (fetch (REGION HEIGHT) of (fetch (MENU MENUGRID) of DATUM))
(replace (REGION HEIGHT) of (fetch (MENU MENUGRID) of DATUM)
with NEWVALUE))
(IMAGEWIDTH (fetch (BITMAP BITMAPWIDTH) of (CHECK/MENU/IMAGE DATUM)))
(IMAGEHEIGHT (fetch (BITMAP BITMAPHEIGHT) of (CHECK/MENU/IMAGE DATUM)))
(MENUREGIONLEFT (IDIFFERENCE (fetch (REGION LEFT) of (fetch (MENU MENUGRID)
of DATUM))
(fetch MENUOUTLINESIZE of DATUM)))
(MENUREGIONBOTTOM (IDIFFERENCE (fetch (REGION BOTTOM)
of (fetch (MENU MENUGRID) of DATUM))
(fetch MENUOUTLINESIZE of DATUM])
]
(/DECLAREDATATYPE (QUOTE MENU)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER)))
(* END EXPORTED DEFINITIONS)
(PUTPROPS MENU COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1429 32674 (MENU 1439 . 3894) (ADDMENU 3896 . 7887) (DELETEMENU 7889 . 8996) (
MENUREGION 8998 . 9659) (BLTMENUIMAGE 9661 . 10205) (ERASEMENUIMAGE 10207 . 10986) (DEFAULTMENUHELDFN
10988 . 11261) (DEFAULTWHENSELECTEDFN 11263 . 11651) (BACKGROUNDWHENSELECTEDFN 11653 . 12116) (
GETMENUITEM 12118 . 12587) (MENUBUTTONFN 12589 . 13147) (MENU.HANDLER 13149 . 17425) (DOSELECTEDITEM
17427 . 17655) (\FDECODE/BUTTON 17657 . 17993) (MENUITEMREGION 17995 . 19529) (\MENUITEMLABEL 19531 .
19804) (CHECK/MENU/IMAGE 19806 . 20970) (PPROMPT2 20972 . 21295) (UPDATE/MENU/IMAGE 21297 . 30618) (
\SHOWMENULABEL 30620 . 32286) (WFROMMENU 32288 . 32672)) (33219 33643 (MENUREPAINTFN 33229 . 33641)) (
33674 36171 (MAXSTRINGWIDTH 33684 . 33923) (CENTEREDPRIN1 33925 . 34268) (CENTERPRINTINREGION 34270 .
34815) (CENTERPRINTINAREA 34817 . 35858) (STRICTLY/BETWEEN 35860 . 36169)) (36201 40080 (UNREADITEM
36211 . 36434) (TYPEINMENU 36436 . 36628) (SHADEITEM 36630 . 38031) (MOST/VISIBLE/OPERATION 38033 .
38333) (#BITSON 38335 . 38921) (BUTTONPANEL 38923 . 39470) (BUTTONPANEL/SELECTION/FN 39472 . 39863) (
GETSELECTEDITEMS 39865 . 40078)) (40388 40926 (MENUDESELECT 40398 . 40614) (MENUSELECT 40616 . 40924))
)))
STOP