(FILECREATED "24-Feb-84 15:01:32" {PHYLUM}<LISPCORE>SOURCES>MENU.;63 56457
changes to: (FNS DEFAULTWHENSELECTEDFN)
previous date: "17-Jan-84 11:36:27" {PHYLUM}<LISPCORE>SOURCES>MENU.;61)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT MENUCOMS)
(RPAQQ MENUCOMS ((* window functions)
(FNS MAXMENUITEMHEIGHT MAXMENUITEMWIDTH MENU MENUTITLEFONT ADDMENU DELETEMENU MENUREGION
BLTMENUIMAGE ERASEMENUIMAGE DEFAULTMENUHELDFN DEFAULTWHENSELECTEDFN
BACKGROUNDWHENSELECTEDFN GETMENUITEM MENUBUTTONFN MENU.HANDLER DOSELECTEDITEM
\FDECODE/BUTTON MENUITEMREGION \MENUITEMLABEL \MENUSUBITEMS CHECK/MENU/IMAGE PPROMPT2
UPDATE/MENU/IMAGE \SHOWMENULABEL \SMASHMENUIMAGEONRESET CLOSE.PROCESS.MENU
DEFAULTSUBITEMFN GETMENUPROP PUTMENUPROP WAKE.MY.PROCESS \INVERTITEM \BOXITEM
NESTED.SUBMENU NESTED.SUBMENU.POS WFROMMENU)
(BITMAPS MENUSUBITEMMARK)
(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
(MAXMENUITEMHEIGHT
[LAMBDA (MENU) (* rrb "22-NOV-83 13:59")
(* returns the height of the largest menu item label in
the menu MENU.)
(IMAX (for I in (fetch (MENU ITEMS) of MENU) 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 (fetch (MENU MENUFONT) of MENU)
(QUOTE HEIGHT])
(MAXMENUITEMWIDTH
[LAMBDA (MENU) (* rrb "29-Dec-83 10:03")
(* returns the width of the largest menu item label in
the menu MENU.)
(DECLARE (GLOBALVARS MENUSUBITEMMARK))
(bind LABEL SUBITEMS (M ← 0)
(FONT ←(fetch (MENU MENUFONT) of MENU)) for I in (fetch (MENU ITEMS) of MENU)
do (SETQ LABEL (\MENUITEMLABEL I))
(SETQ SUBITEMS (\MENUSUBITEMS MENU I))
[SETQ M (IMAX M (IPLUS (COND
((BITMAPP LABEL)
(fetch (BITMAP BITMAPWIDTH) of LABEL))
(T (STRINGWIDTH LABEL FONT NIL NIL)))
(COND
(SUBITEMS (BITMAPWIDTH MENUSUBITEMMARK))
(T 0]
finally (RETURN M])
(MENU
[LAMBDA (MENU POSITION RELEASECONTROLFLG NESTEDFLG) (* rrb "29-Dec-83 09:22")
(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 DSP) (* 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]
(SETQ DSP (WINDOWPROP IMAGE (QUOTE DSP)))
(MOVEW IMAGE (create POSITION
XCOORD ← MX
YCOORD ← MY))
[SETQ MX (RESETLST (RESETSAVE (OPENW IMAGE)
(LIST (QUOTE CLOSEW)
IMAGE))
(COND
(RELEASECONTROLFLG (PROG (MVAL)
(WINDOWPROP IMAGE (QUOTE MENUPROCESS)
(THIS.PROCESS))
(WINDOWPROP IMAGE (QUOTE CLOSEFN)
(QUOTE CLOSE.PROCESS.MENU))
(WINDOWPROP IMAGE (QUOTE BUTTONEVENTFN)
(QUOTE WAKE.MY.PROCESS))
LP (OR (NEQ T (SETQ MVAL (BLOCK T)))
(RETURN NIL))
(GETMOUSESTATE)
(* if mouse state is up, then someone came into the
window with the mouse down. Ignore it.)
(OR (MOUSESTATE (OR LEFT RIGHT MIDDLE))
(GO LP))
(* MVAL will be NIL only if the user clicked up outside
the window)
(OR (SETQ MVAL
(MENU.HANDLER MENU DSP T NIL NESTEDFLG))
(GO LP))
(RETURN MVAL)))
(T (MENU.HANDLER MENU DSP T T NESTEDFLG]
(* evaluate menu form after image has been taken down.)
(RETURN (COND
(NESTEDFLG MX)
(MX (DOSELECTEDITEM MENU (CAR MX)
(CDR MX])
(MENUTITLEFONT
[LAMBDA (MENU) (* rrb "30-Dec-83 14:08")
(* returns the title font for a menu.)
(DECLARE (GLOBALVARS WindowTitleDisplayStream))
(PROG (TITLEFONT)
(RETURN (COND
((NULL (SETQ TITLEFONT (fetch (MENU MENUTITLEFONT) of MENU)))
(* use the window title font)
(DSPFONT NIL WindowTitleDisplayStream))
((EQ TITLEFONT T) (* use the menu item font)
(fetch (MENU MENUFONT) of MENU))
((FONTP (\GETFONTDESC TITLEFONT (QUOTE DISPLAY)
T)))
(T (DSPFONT NIL WindowTitleDisplayStream])
(ADDMENU
[LAMBDA (ADDEDMENU W POSITION DONTOPENFLG) (* rrb "14-Dec-83 14:10")
(* 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
((WINDOWP 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))
DONTOPENFLG))
(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))
(OR DONTOPENFLG (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
((NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W)
(MENUREGION ADDEDMENU))) (* if the menu didn't fit, make it scrollable.)
(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 WIN DONTOPEN) (* rrb "30-NOV-83 18:12")
(* Displays a menu image at its position on DS.)
(PROG ([SRC (COND
((WINDOWP (fetch IMAGE of MENU))
(fetch (WINDOW SAVE) of (fetch (MENU IMAGE) of MENU)))
(T (fetch IMAGE of MENU]
(DSTWIN (\INSUREWINDOW WIN)))
(RETURN (COND
[(AND DONTOPEN (NOT (OPENWP DSTWIN))) (* leave the window closed)
(PROG ((BORDER (WINDOWPROP DSTWIN (QUOTE BORDER)))
(CR (DSPCLIPPINGREGION NIL DSTWIN)))
(RETURN (BITBLT SRC 0 0 (fetch (WINDOW SAVE) of DSTWIN)
(IPLUS BORDER (fetch (MENU MENUREGIONLEFT) of MENU))
(IPLUS BORDER (fetch (MENU MENUREGIONBOTTOM)
of MENU))
(IMIN (BITMAPWIDTH SRC)
(fetch (REGION WIDTH) of CR))
(IMIN (BITMAPHEIGHT SRC)
(fetch (REGION HEIGHT) of CR]
(T (BITBLT SRC NIL NIL DSTWIN (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 "24-Feb-84 15:01")
(* default Menu handler)
(COND
((AND (LISTP ITEM)
(LISTP (CDR ITEM)))
(STKEVAL (OR (STKPOS (QUOTE MENU))
(QUOTE MENUBUTTONFN))
(CADR ITEM)
T))
(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 NESTEDFLG)
(* rrb " 7-Jan-84 15:52")
(* handles details of watching mouse for menus.)
(RESETLST (RESETSAVE NIL (LIST (QUOTE \SMASHMENUIMAGEONRESET)
MENU))
(PROG (ITEM SUBITEMS SUBMENURESULT OLDBOXX OLDBOXY BOXX BOXY HELDSTATE MOUSEDOWN
(MOVEDLEFT "NESTED")
(LASTBUTTONSTATE LASTMOUSEBUTTONS)
(MGRIDSPEC (fetch (MENU MENUGRID) of MENU))
(HOLDTIMER (SETUPTIMER MENUHELDWAIT))
(HELDFN (fetch (MENU WHENHELDFN) of MENU)))
(RETURN (COND
([SETQ ITEM
(ERSETQ (until (COND
(MOUSEDOWN
(* if mouse has been down, process it)
(MOUSESTATE UP))
((MOUSESTATE (NOT UP))
(* mouse hasn't been down but just went down.)
[COND
((AND (NULL KEEPCONTROLIFOUTFLG)
(LASTMOUSESTATE RIGHT))
(DOWINDOWCOM (WHICHW LASTMOUSEX LASTMOUSEY)))
(T (SETQ MOUSEDOWN T)
(COND
(OLDBOXX
(* switch between boxing to flipping items.)
(\BOXITEM OLDBOXX OLDBOXY MENU
DSP)
(\INVERTITEM OLDBOXX OLDBOXY
MENU DSP]
NIL))
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 (COND
(MOUSEDOWN (\INVERTITEM OLDBOXX
OLDBOXY
MENU DSP)
)
(T (\BOXITEM OLDBOXX OLDBOXY
MENU DSP)))
(MENU.HELDSTATE.RESET OLDBOXX
OLDBOXY))
(T (SETQ HOLDTIMER (SETUPTIMER MENUHELDWAIT
HOLDTIMER]
(* invert new item)
(COND
(MOUSEDOWN (\INVERTITEM BOXX BOXY MENU DSP))
(T (\BOXITEM BOXX BOXY MENU DSP)))
(SETQ OLDBOXX BOXX)
(SETQ OLDBOXY BOXY))
((AND HELDFN (NULL HELDSTATE)
(TIMEREXPIRED? HOLDTIMER))
(* 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 (COND
((AND (IGREATERP BOXX 0)
(SETQ ITEM
(GETMENUITEM MENU OLDBOXX
OLDBOXY))
(SETQ SUBITEMS
(\MENUSUBITEMS MENU ITEM)))
(* There are subitems to be displayed)
(SETQ SUBMENURESULT
(MENU (NESTED.SUBMENU MENU
SUBITEMS)
(NESTED.SUBMENU.POS
MENU ITEM DSP)
NIL T))
(COND
((NEQ SUBMENURESULT MOVEDLEFT)
(* selected something from submenu)
(COND
(MOUSEDOWN (\INVERTITEM
OLDBOXX
OLDBOXY MENU
DSP))
(T (\BOXITEM OLDBOXX
OLDBOXY MENU
DSP)))
(MENU.HELDSTATE.RESET OLDBOXX
OLDBOXY)
(SETQ OLDBOXX)
(GO OUT)))
(SETQ SUBMENURESULT NIL)))
(COND
(MOUSEDOWN (\INVERTITEM OLDBOXX
OLDBOXY
MENU DSP))
(T (\BOXITEM OLDBOXX OLDBOXY MENU
DSP)))
(MENU.HELDSTATE.RESET OLDBOXX OLDBOXY)
(SETQ OLDBOXX)))
(* OLDBOXX denotes item inverted.)
(COND
((AND NESTEDFLG BOXX (IGREATERP 0 BOXX))
(* if this is a nested call and the user moved to the
left, return indication of this.)
(RETURN MOVEDLEFT))
((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.)
OUT
(COND
(OLDBOXX (COND
(MOUSEDOWN (\INVERTITEM OLDBOXX
OLDBOXY
MENU DSP))
(T (\BOXITEM OLDBOXX OLDBOXY MENU
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
(SUBMENURESULT)
(OLDBOXX (CONS (GETMENUITEM MENU
OLDBOXX
OLDBOXY)
(\FDECODE/BUTTON
LASTBUTTONSTATE]
(* no error)
(RETURN (CAR ITEM)))
(T (* user ↑E -
reset the menu selection.)
(* note -
this doesn't protect against ↑D. I would suggest that something be put on the reset list to clear the menu image
in the case of a ↑D.)
[COND
(OLDBOXX (COND
(MOUSEDOWN (\INVERTITEM OLDBOXX OLDBOXY MENU DSP))
(T (\BOXITEM OLDBOXX OLDBOXY MENU DSP]
(ERROR!])
(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])
(\MENUSUBITEMS
[LAMBDA (MENU ITEM) (* rrb "29-Dec-83 09:54")
(APPLY* (OR (fetch (MENU SUBITEMFN) of MENU)
(FUNCTION DEFAULTSUBITEMFN))
MENU 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 "30-Dec-83 13:46")
(DECLARE (GLOBALVARS WindowTitleDisplayStream)) (* recomputes the menu image from its labels.)
(PROG (NUMCOLS NUMROWS WIDTH HEIGHT (DSP (DSPCREATE))
BLK COLWIDTH ROWHEIGHT (MENUITEMS (fetch (MENU ITEMS) of MNU))
BORDER OUTLINE FONT TITLEFONT TITLEHEIGHT WINDOW TITLE (CENTER?
(fetch (MENU CENTERFLG) of MNU))) (* 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)))
(COND
[(SETQ TITLE (fetch (MENU TITLE) of MNU)) (* set the title font)
(SETQ TITLEFONT (MENUTITLEFONT MNU))
(SETQ TITLEHEIGHT (FONTPROP TITLEFONT (QUOTE HEIGHT]
(T (SETQ TITLEHEIGHT 0))) (* 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 (MAXMENUITEMWIDTH MNU CENTER?)
(ITIMES (ADD1 BORDER)
2))
(COND
(TITLE
(* make title be in the same font as the rest of the
titles in the system)
(IPLUS (STRINGWIDTH TITLE TITLEFONT)
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 (MAXMENUITEMHEIGHT MNU)
(ITIMES BORDER 2]
(ITIMES OUTLINE 2)
TITLEHEIGHT))
[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 TITLEHEIGHT (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) (* calculate the offset from the top of the item box to
the base line of the printed item.)
[COND
(TITLE (* if there is a title, display it)
(DSPFONT TITLEFONT DSP)
(\SHOWMENULABEL TITLE (create REGION
LEFT ←(IPLUS OUTLINE BORDER)
BOTTOM ←(IDIFFERENCE (IPLUS HEIGHT BORDER)
(IPLUS TITLEHEIGHT OUTLINE))
WIDTH ← WIDTH
HEIGHT ← TITLEHEIGHT)
MNU DSP CENTER?)
(SETQ HEIGHT (IDIFFERENCE HEIGHT TITLEHEIGHT]
[PROG ([ITEMREGION (create REGION
LEFT ←(IPLUS OUTLINE BORDER)
BOTTOM ←(IDIFFERENCE (IPLUS HEIGHT BORDER)
(IPLUS ROWHEIGHT OUTLINE))
WIDTH ←(IDIFFERENCE (fetch (REGION WIDTH)
of (fetch (MENU MENUGRID) of MNU))
(ITIMES BORDER 2))
HEIGHT ←(IDIFFERENCE ROWHEIGHT (ITIMES BORDER 2]
(COL# 1))
(DSPFONT FONT DSP)
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)
(replace (WINDOW WBORDER) of WINDOW with OUTLINE)
(ADVISEWDS WINDOW) (* snap circular link between the display stream created
for printing and its stream.)
(RETURN (fetch (WINDOW SAVE) of (fetch (MENU IMAGE) of MNU])
(\SHOWMENULABEL
[LAMBDA (ITEM ITEMREGION MENU DSP CENTER?) (* rrb "29-Dec-83 10:19")
(* displays the item label for ITEM in the region
ITEMREGION on the stream DSP according to the formatting
information from MENU.)
(DECLARE (GLOBALVARS MENUSUBITEMMARK))
(PROG ((LABEL (\MENUITEMLABEL ITEM)))
[COND
((\MENUSUBITEMS MENU ITEM) (* this item has subitems, put the mark in and change
the region that the item should print in.)
(BITBLT MENUSUBITEMMARK 0 0 DSP (IPLUS (fetch (REGION LEFT) of ITEMREGION)
(IDIFFERENCE (fetch (REGION WIDTH) of ITEMREGION)
(BITMAPWIDTH MENUSUBITEMMARK)))
(IPLUS (fetch (REGION BOTTOM) of ITEMREGION)
(FONTPROP (fetch (MENU MENUFONT) of MENU)
(QUOTE DESCENT)))
NIL NIL (QUOTE INPUT)
(QUOTE REPLACE)
NIL ITEMREGION)
(SETQ ITEMREGION (CREATEREGION (fetch (REGION LEFT) of ITEMREGION)
(fetch (REGION BOTTOM) of ITEMREGION)
(IDIFFERENCE (fetch (REGION WIDTH) of ITEMREGION)
(BITMAPWIDTH MENUSUBITEMMARK))
(fetch (REGION HEIGHT) of ITEMREGION]
(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])
(\SMASHMENUIMAGEONRESET
[LAMBDA (MENU) (* rrb " 9-Jan-84 19:23")
(* sets the menu image field to NIL if RESETSTATE
indicates that a ↑D was typed.)
(COND
((FMEMB RESETSTATE (QUOTE (RESET HARDRESET)))
(replace (MENU IMAGE) of MENU with NIL])
(CLOSE.PROCESS.MENU
[LAMBDA (WINDOW) (* dgb: "15-DEC-83 19:18")
(WAKE.PROCESS (WINDOWPROP WINDOW (QUOTE MENUPROCESS))
T])
(DEFAULTSUBITEMFN
[LAMBDA (MENU ITEM) (* rrb "28-Dec-83 19:15")
(* default subitemfn for menus.
Checks the fourth element of the
(item for an expression of the form
(SUBITEMS a b c)))
(AND (LISTP ITEM)
(EQ [CAR (SETQ ITEM (LISTP (CADDDR ITEM]
(QUOTE SUBITEMS))
(CDR ITEM])
(GETMENUPROP
[LAMBDA (MENU PROPERTY) (* dgb: "13-DEC-83 17:50")
(LISTGET (fetch (MENU MENUUSERDATA) of MENU)
PROPERTY])
(PUTMENUPROP
[LAMBDA (MENU PROPERTY VALUE) (* dgb: "13-DEC-83 17:52")
(PROG ((NOWDATA (fetch (MENU MENUUSERDATA) of MENU)))
[COND
(NOWDATA (LISTPUT NOWDATA PROPERTY VALUE))
(T (replace (MENU MENUUSERDATA) of MENU with (LIST PROPERTY VALUE]
(RETURN VALUE])
(WAKE.MY.PROCESS
[LAMBDA (WINDOW) (* dgb: "15-DEC-83 19:09")
(WAKE.PROCESS (WINDOWPROP WINDOW (QUOTE MENUPROCESS))
"ABC"])
(\INVERTITEM
[LAMBDA (COLUMN ROW MENU DSP) (* dgb: "13-DEC-83 18:06")
(* inverts an item in a menu displayed in DSP.)
(SHADEGRIDBOX COLUMN ROW BLACKSHADE (QUOTE INVERT)
(fetch (MENU MENUGRID) of MENU)
(fetch (MENU MENUBORDERSIZE) of MENU)
DSP])
(\BOXITEM
[LAMBDA (COLUMN ROW MENU DSP) (* rrb "28-Dec-83 17:34")
(* inverts an item in a menu displayed in DSP.)
(PROG ((BORDER (OR (FIXP (fetch (MENU MENUBORDERSIZE) of MENU))
0))
(GRID (fetch (MENU MENUGRID) of MENU))
LFT BTM WID HGHT)
(BITBLT NIL NIL NIL DSP (SETQ LFT (IPLUS (LEFTOFGRIDCOORD COLUMN GRID)
BORDER))
(SETQ BTM (IPLUS (BOTTOMOFGRIDCOORD ROW GRID)
BORDER))
(SETQ WID (IDIFFERENCE (fetch (REGION WIDTH) of GRID)
(ITIMES BORDER 2)))
(SETQ HGHT (IDIFFERENCE (fetch (REGION HEIGHT) of GRID)
(ITIMES BORDER 2)))
(QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE)
(BITBLT NIL NIL NIL DSP (ADD1 LFT)
(ADD1 BTM)
(IDIFFERENCE WID 2)
(IDIFFERENCE HGHT 2)
(QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE])
(NESTED.SUBMENU
[LAMBDA (MENU SUBITEMS) (* dgb: "15-DEC-83 08:24")
(* computes and returns the nested submenu for SUBITEMS.
It maintains a cache on the MENUUSERDATA)
(PROG [SUBMENU (SUBMENULST (GETMENUPROP MENU (QUOTE SUBMENUS]
[COND
([NULL (SETQ SUBMENU (CDR (FASSOC SUBITEMS SUBMENULST]
(* Cache submenu on user data)
(PUTMENUPROP MENU (QUOTE SUBMENUS)
(CONS [CONS SUBITEMS (SETQ SUBMENU
(create MENU
ITEMS ← SUBITEMS
MENUOFFSET ←(create POSITION
XCOORD ← 1
YCOORD ← 5)
CHANGEOFFSETFLG ←(QUOTE Y)
CENTERFLG ←(fetch (MENU CENTERFLG) of MENU)
MENUFONT ←(fetch (MENU MENUFONT) of MENU)
MENUBORDERSIZE ←(fetch (MENU MENUBORDERSIZE)
of MENU)
MENUOUTLINESIZE ←(fetch (MENU MENUOUTLINESIZE)
of MENU)
WHENHELDFN ←(fetch (MENU WHENHELDFN) of MENU)
WHENUNHELDFN ←(fetch (MENU WHENUNHELDFN)
of MENU)
SUBITEMFN ←(fetch (MENU SUBITEMFN) of MENU]
SUBMENULST]
(RETURN SUBMENU])
(NESTED.SUBMENU.POS
[LAMBDA (IMENU ITEM STREAM) (* rrb "28-Dec-83 19:24")
(* return the position of a nested submenu should have.)
(PROG (ITEMNUMBER (ITEMS (fetch (MENU ITEMS) of IMENU))
(GRIDSPEC (fetch (MENU MENUGRID) of IMENU))
(BORDER (fetch (MENU MENUBORDERSIZE) of IMENU))
(DD (\GETDISPLAYDATA STREAM)))
[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 POSITION
XCOORD ←(\DSPTRANSFORMX (IPLUS (fetch (REGION LEFT) of GRIDSPEC)
(ITIMES (IREMAINDER ITEMNUMBER
(fetch (MENU MENUCOLUMNS)
of IMENU))
(fetch (REGION WIDTH) of GRIDSPEC))
(IDIFFERENCE (fetch (REGION WIDTH)
of GRIDSPEC)
(ITIMES 2 BORDER)))
DD)
YCOORD ←(\DSPTRANSFORMY
(IPLUS (ITIMES -2 BORDER)
(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)))
DD])
(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])
)
(RPAQ MENUSUBITEMMARK (READBITMAP))
(6 9
"H@@@"
"D@@@"
"J@@@"
"E@@@"
"JH@@"
"E@@@"
"J@@@"
"D@@@"
"H@@@")
(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 HOLDTIMER (SETUPTIMER MENUHELDWAIT HOLDTIMER))))
)
)
(* 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 STREAM) (* rmk: "26-AUG-83 15:04")
(* prints an expression in the middle of a region)
(OR (type? REGION REGION)
(SETQ REGION (DSPCLIPPINGREGION NIL STREAM)))
(CENTERPRINTINAREA EXP (fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
(fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
STREAM])
(CENTERPRINTINAREA
[LAMBDA (EXP X Y WIDTH HEIGHT STREAM) (* rmk: "29-AUG-83 18:49")
(* prints an expression in a box.)
(SETQ STREAM (\OUTSTREAMARG STREAM))
(PROG (XPOS (STRWIDTH (STRINGWIDTH EXP STREAM)))
(MOVETO (SETQ XPOS (IPLUS X (IQUOTIENT (ADD1 (IDIFFERENCE WIDTH STRWIDTH))
2)))
(IPLUS Y (IQUOTIENT (IPLUS (IDIFFERENCE HEIGHT (FONTPROP STREAM (QUOTE ASCENT)))
(FONTPROP STREAM (QUOTE DESCENT)))
2))
STREAM)
(COND
((IGREATERP (IPLUS XPOS STRWIDTH)
(DSPRIGHTMARGIN NIL STREAM))
(* 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)
STREAM)
STREAM))
(PRIN3 EXP STREAM)))
(T (PRIN3 EXP STREAM])
(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 "17-Jan-84 11:26")
(* shades a menu item with a background shade.
DS/W if provided 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]
((DISPLAYSTREAMP (\OUTSTREAMARG DS/W T]
(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 DSPRIGHTMARGIN)
(DSPRIGHTMARGIN 64000 DSP)
DSP))
(RESETSAVE NIL (LIST (QUOTE DSPFONT)
(DSPFONT (fetch (MENU MENUFONT) of MENU)
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 MENUTITLEFONT SUBITEMFN
MENUFEEDBACKFLG)
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 POINTER POINTER POINTER)))
(* END EXPORTED DEFINITIONS)
(PUTPROPS MENU COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1701 46248 (MAXMENUITEMHEIGHT 1711 . 2341) (MAXMENUITEMWIDTH 2343 . 3165) (MENU 3167 .
6519) (MENUTITLEFONT 6521 . 7309) (ADDMENU 7311 . 11455) (DELETEMENU 11457 . 12564) (MENUREGION 12566
. 13227) (BLTMENUIMAGE 13229 . 14422) (ERASEMENUIMAGE 14424 . 15203) (DEFAULTMENUHELDFN 15205 . 15478
) (DEFAULTWHENSELECTEDFN 15480 . 15850) (BACKGROUNDWHENSELECTEDFN 15852 . 16315) (GETMENUITEM 16317 .
16786) (MENUBUTTONFN 16788 . 17346) (MENU.HANDLER 17348 . 24970) (DOSELECTEDITEM 24972 . 25200) (
\FDECODE/BUTTON 25202 . 25538) (MENUITEMREGION 25540 . 27074) (\MENUITEMLABEL 27076 . 27349) (
\MENUSUBITEMS 27351 . 27573) (CHECK/MENU/IMAGE 27575 . 28739) (PPROMPT2 28741 . 29064) (
UPDATE/MENU/IMAGE 29066 . 37246) (\SHOWMENULABEL 37248 . 39886) (\SMASHMENUIMAGEONRESET 39888 . 40294)
(CLOSE.PROCESS.MENU 40296 . 40477) (DEFAULTSUBITEMFN 40479 . 40933) (GETMENUPROP 40935 . 41125) (
PUTMENUPROP 41127 . 41487) (WAKE.MY.PROCESS 41489 . 41671) (\INVERTITEM 41673 . 42061) (\BOXITEM 42063
. 43022) (NESTED.SUBMENU 43024 . 44367) (NESTED.SUBMENU.POS 44369 . 45860) (WFROMMENU 45862 . 46246))
(46912 47336 (MENUREPAINTFN 46922 . 47334)) (47367 49859 (MAXSTRINGWIDTH 47377 . 47616) (
CENTEREDPRIN1 47618 . 47961) (CENTERPRINTINREGION 47963 . 48517) (CENTERPRINTINAREA 48519 . 49546) (
STRICTLY/BETWEEN 49548 . 49857)) (49889 53685 (UNREADITEM 49899 . 50122) (TYPEINMENU 50124 . 50316) (
SHADEITEM 50318 . 51636) (MOST/VISIBLE/OPERATION 51638 . 51938) (#BITSON 51940 . 52526) (BUTTONPANEL
52528 . 53075) (BUTTONPANEL/SELECTION/FN 53077 . 53468) (GETSELECTEDITEMS 53470 . 53683)) (53993 54531
(MENUDESELECT 54003 . 54219) (MENUSELECT 54221 . 54529)))))
STOP