(FILECREATED "26-Apr-85 14:47:06" {FLOPPY}SUPERMENUS.;1 26890
changes to: (VARS SUPERMENUSCOMS))
(* Copyright (c) by NIL. All rights reserved.)
(PRETTYCOMPRINT SUPERMENUSCOMS)
(RPAQQ SUPERMENUSCOMS ((FNS ERASESMENUIMAGE HOWHIGH HOWWIDE INVERTITEMS BOXITEM ITEMSELECTED MKLST
SETUP SMENUPROP SMENUREPAINTFN SMENUTITLEFONT)
(FNS SMENU ADDSMENU DELETESMENU)
(FNS CHECK/SMENUBM CREATE-IMAGE TEXTMAP CHOOSEFONT)
(FNS GET-BOXREGION GET-FONT GET-REGION GET-ITEMS)
(FNS BACKGROUNDSMENUSELECTEDFN DEFAULTSMENUSELECTEDFN SMENUBUTTONFN
SMENU.HANDLER)
(VARS)
[P (SETQ SMENUHELDWAIT 1200)
(SETQ SMENUFONT (FONTCREATE (QUOTE HELVETICA)
10))
(SETQ SMENU-CHOOSEFONT-LIST (LIST (FONTCREATE (QUOTE TIMESROMAND)
72)
(FONTCREATE (QUOTE HELVETICA)
36)
(FONTCREATE (QUOTE HELVETICAD)
24)
(FONTCREATE (QUOTE HELVETICA)
18)
(FONTCREATE (QUOTE HELVETICA)
14)
(FONTCREATE (QUOTE HELVETICA)
12)
(FONTCREATE (QUOTE HELVETICA)
10)
(FONTCREATE (QUOTE HELVETICA)
7)
(FONTCREATE (QUOTE HELVETICA)
5]
(RECORDS SMENU)
(MACROS SMENU.HELDRESET)
(PROP INFO TOP-OF-LOOP)))
(DEFINEQ
(ERASESMENUIMAGE
[LAMBDA (SMENU W) (* edited: "12-Mar-85 20:57")
(BITBLT NIL NIL NIL (WINDOWPROP W (QUOTE DSP))
0 0 NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE])
(HOWHIGH
[LAMBDA (I) (* edited: " 1-Mar-85 16:04")
(LET ((R (GET-REGION I)))
[IPLUS (fetch (REGION BOTTOM) of R)
(replace (REGION HEIGHT) of R with (EVAL (fetch (REGION HEIGHT) of R])])
(HOWWIDE
[LAMBDA (I) (* JTS "16-Mar-85 18:49")
(* * Compute far RIGHT a region extends by adding its width to -
----- the xcoord of its left edge. Also updates the width field.)
(LET ((R (GET-REGION I)))
[IPLUS (fetch (REGION LEFT) of R)
(replace (REGION WIDTH) of R with (EVAL (fetch (REGION WIDTH) of R])])
(INVERTITEMS
[LAMBDA (ITEM SMENU W) (* JTS "21-Apr-85 17:20")
(* * Inverts a region in window, W, by BITBLTing the region into -
----- itself using the INVERT operation.)
(LET (LEF BOT WID HGT
(REGION (GET-REGION ITEM)))
(GET-REGIONVALS LEF BOT WID HGT REGION)
[COND
((OPENWP W)
(BITBLT W LEF BOT W LEF BOT WID HGT (QUOTE INVERT)
(QUOTE REPLACE])])
(BOXITEM
[LAMBDA (ITEM SMENU W) (* JTS "21-Apr-85 16:52")
(PROG ((REGION (GET-REGION ITEM)))
(PROG ((LEF (fetch (REGION LEFT) of REGION))
(BOT (fetch (REGION BOTTOM) of REGION))
(WID (fetch (REGION WIDTH) of REGION))
(HGT (fetch (REGION HEIGHT) of REGION)))
(PROG ((BPH (IPLUS BOT HGT))
(LPW (IPLUS LEF WID)))
(PROG ((BPHM2 (IDIFFERENCE BPH 2))
(LPWM2 (IDIFFERENCE LPW 2)))
(DRAWLINE LEF BOT LEF BPHM2 2 (QUOTE INVERT)
W)
(DRAWLINE LEF BPHM2 LPWM2 BPHM2 2 (QUOTE INVERT)
W)
(DRAWLINE LPWM2 BPHM2 LPWM2 (IPLUS BOT 2)
2
(QUOTE INVERT)
W)
(DRAWLINE LPWM2 BOT LEF BOT 2 (QUOTE INVERT)
W])
(ITEMSELECTED
[LAMBDA (SMENU ITEM BUTTON) (* edited: "25-Mar-85 12:19")
(APPLY* (OR (fetch (SMENU WHENSELECTEDFN) of SMENU)
(FUNCTION DEFAULTSMENUSELECTEDFN))
ITEM SMENU BUTTON])
(MKLST
[LAMBDA (SENTENCE) (* edited: "25-Feb-85 15:44")
(COND
[(STRINGP SENTENCE)
(PROG (TEMP BLIST)
(for X in (UNPACK SENTENCE) do (if (NEQ X (QUOTE % ))
then (SETQ TEMP (APPEND TEMP (LIST X)))
else (SETQ BLIST (CONS (PACK TEMP)
BLIST))
(SETQ TEMP NIL)))
(RETURN (REVERSE (CONS (PACK TEMP)
BLIST]
(T NIL])
(SETUP
[LAMBDA NIL (* JTS "21-Apr-85 19:55")
(create SMENU
TITLE ← "THIS IS A TEST SMENU"
SMENUOUTLINESIZE ← 5
SMENUBORDERSIZE ← 1
ITEMS ←(QUOTE ((BM5 (PROMPTPRINT "CONGRAGULATIONS, YOU JUST SELECTED SMILING SAM!")
"SAM SMILEY"
(227 37 60 40))
((QUOTE (HAVE A NICE DAY!))
NIL "NIL" (51 260 168 48)
FITFONT)
((QUOTE (IX XX))
NIL "MORE FONTFITTING" (29 15 73 105)
FITFONT)
((EXPANDBITMAP BM4 2 2)
(PRINTBELLS)
"LUCEY MAE"
(132 34 80 80))
((EXPANDBITMAP BM3 2 2)
NIL "DUMBO THE ELEPHANT" (31 153 80 80))
((QUOTE (LONG AND VERY THIN PIECE OF TEXT TO BE PUT SOME WHERE IN THE
MIDDLE OF THE SMENU))
NIL NIL (127 125 175 104)
FITFONT])
(SMENUPROP
[LAMBDA (SMENU PROPERTY VALUE) (* edited: " 1-Mar-85 12:10")
(COND
(VALUE (PROG ((DATA (fetch (SMENU USERDATA) of SMENU)))
[COND
(DATA (LISTPUT DATA PROPERTY VALUE))
(T (replace (SMENU USERDATA) of SMENU with (LIST PROPERTY VALUE]
(RETURN VALUE)))
(T (LISTGET (fetch (SMENU USERDATA) of SMENU)
PROPERTY])
(SMENUREPAINTFN
[LAMBDA (WINDOW REG) (* edited: "19-Apr-85 14:33")
(for SMENU in (REVERSE (WINDOWPROP WINDOW (QUOTE SMENU))) do (BITBLT (fetch (SMENU SMENUBM)
of SMENU)
0 0 WINDOW 0 0])
(SMENUTITLEFONT
[LAMBDA (SMENU)
(DECLARE (GLOBALVARS WindowTitleDisplayStream)) (* JTS "27-Mar-85 11:34")
(PROG (TITLEFONT)
(RETURN (COND
((NULL (SETQ TITLEFONT (fetch (SMENU TITLEFONT) of SMENU)))
(DSPFONT NIL WindowTitleDisplayStream))
((EQ TITLEFONT T)
(FETCH (SMENU SMENUFONT) OF SMENU))
((FONTP (\GETFONTDESC TITLEFONT (QUOTE DISPLAY)
T)))
(T (DSPFONT NIL WindowTitleDisplayStream])
)
(DEFINEQ
(SMENU
[LAMBDA (SMENU POSITION RELEASECONTROLFLG) (* JTS "22-Apr-85 13:01")
(* * Puts a pop-up smenu on the screen and waits for selection)
(OR (type? SMENU SMENU)
(\ILLEGAL.ARG SMENU))
(PROG ((SMENUBM (OR (fetch (SMENU SMENUBM) of SMENU)
(CHECK/SMENUBM SMENU T)))
(IMAGE (fetch (SMENU WINDOW) of SMENU))
MX MY DSP)
(COND
[(AND (OR POSITION (SETQ POSITION (fetch (SMENU SMENUPOSITION) of SMENU)))
(SETQ MX (FIXP (fetch (POSITION XCOORD) of POSITION)))
(SETQ MY (FIXP (fetch (POSITION YCOORD) of POSITION]
(T (GETMOUSESTATE)
(SETQ MX LASTMOUSEX)
(SETQ MY LASTMOUSEY)))
(PROGN (SETQ MX (IMAX (IMIN MX (IDIFFERENCE SCREENWIDTH (BITMAPWIDTH SMENUBM)))
0)))
[PROGN (SETQ MY (IMIN (IMAX MY 0)
(IDIFFERENCE SCREENHEIGHT (BITMAPHEIGHT SMENUBM]
(SETQ DSP (DSPCREATE SMENUBM))
(SHAPEW IMAGE (create REGION
LEFT ← MX
BOTTOM ← MY
WIDTH ←(BITMAPWIDTH SMENUBM)
HEIGHT ←(BITMAPHEIGHT SMENUBM)))
(BITBLT SMENUBM 0 0 IMAGE 0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE))
[SETQ MX (RESETLST (RESETSAVE (OPENW IMAGE)
(LIST (QUOTE CLOSEW)
IMAGE))
(COND
(RELEASECONTROLFLG (PROG (MVAL)
(WINDOWPROP IMAGE (QUOTE SMENUPROCESS)
(THIS.PROCESS))
(WINDOWPROP IMAGE (QUOTE CLOSEFN)
(QUOTE CLOSE.PROCESS.MENU))
(WINDOWPROP IMAGE (QUOTE BUTTONEVENTFN)
(QUOTE WAKE.MY.PROCESS)))
LOOP
(TOTOPW IMAGE)
(OR (NEQ T (SETQ MVAL (BLOCK 200)))
(RETURN NIL))
(GETMOUSESTATE)
(OR (MOUSESTATE (OR LEFT RIGHT MIDDLE))
(GO LOOP))
(OR (SETQ MVAL (SMENU.HANDLER SMENU IMAGE NIL))
(GO LOOP))
(RETURN MVAL))
(T (SMENU.HANDLER SMENU IMAGE T]
(* * returns a list of the results of the selected items)
(RETURN (COND
(MX (for I in (CAR MX) collect (ITEMSELECTED SMENU I (CDR MX])
(ADDSMENU
[LAMBDA (SMENU WINDOW POSITION NEWIMAGEFLG) (* edited: "24-Apr-85 13:52")
(* * ADDSMENU is used to display SMENUs which remain active in windows, (closely related to ADDMENU.))
(OR (type? SMENU SMENU)
(\ILLEGAL.ARG SMENU))
(PROG ((OUTLINE (fetch (SMENU SMENUOUTLINESIZE) of SMENU))
W H DEST (TITLE (fetch (SMENU TITLE) of SMENU))
TFONT TWIDTH THIGHT (BM (CHECK/SMENUBM SMENU NIL NEWIMAGEFLG)))
(SETQ W (BITMAPWIDTH BM))
(SETQ H (BITMAPHEIGHT BM))
[COND
((POSITIONP POSITION))
((SETQ POSITION (fetch (SMENU SMENUPOSITION) of SMENU)))
(WINDOW (SETQ POSITION (create POSITION
XCOORD ← 0
YCOORD ← 0)))
(T (SETQ POSITION (create POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY]
[COND
((WINDOWP WINDOW)
(SETQ DEST WINDOW)
(MOVEW DEST POSITION))
(T (SETQ DEST (CREATEW (CREATEREGION (fetch (POSITION XCOORD) of POSITION)
(fetch (POSITION YCOORD) of POSITION)
W H)
NIL 0]
(WINDOWPROP DEST (QUOTE CURSORINFN)
(FUNCTION SMENUBUTTONFN))
(WINDOWPROP DEST (QUOTE BUTTONEVENTFN)
(FUNCTION SMENUBUTTONFN))
(WINDOWPROP DEST (QUOTE CURSORMOVEDFN)
(FUNCTION SMENUBUTTONFN))
(WINDOWADDPROP DEST (QUOTE REPAINTFN)
(FUNCTION SMENUREPAINTFN))
(WINDOWADDPROP DEST (QUOTE SMENU)
SMENU)
(BITBLT BM 0 0 DEST 0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE))
(replace (SMENU WINDOW) of SMENU with DEST)
(RETURN DEST])
(DELETESMENU
[LAMBDA (SMENU CLOSEFLG FROMW) (* JTS "16-Mar-85 19:15")
(OR (type? SMENU SMENU)
(\ILLEGAL.ARG SMENU))
(PROG ([W (COND
((WINDOWP FROMW)
FROMW)
(T (fetch (SMENU WINDOW) of SMENU]
OTHERS)
(OR W (RETURN))
(ERASESMENUIMAGE SMENU W)
[COND
[[NULL (CDR (SETQ OTHERS (WINDOWPROP W (QUOTE SMENU]
(OR (EQ SMENU (CAR OTHERS))
(ERROR "SMENU not correctly in W"))
(WINDOWPROP W (QUOTE SMENU)
NIL)
(COND
(CLOSEFLG (CLOSEW W]
(T (WINDOWPROP W (QUOTE SMENU)
(DREMOVE SMENU OTHERS]
(COND
((EQ (fetch (SMENU WHENSELECTEDFN) of SMENU)
(FUNCTION BACKGROUNDSMENUSELECTEDFN))
(replace (SMENU WHENSELECTEDFN) of SMENU with NIL)))
(RETURN W])
)
(DEFINEQ
(CHECK/SMENUBM
[LAMBDA (SMN MKWFLG NEWIMAGEFLG) (* edited: "19-Apr-85 15:27")
(PROG (IMAGE)
(OR (type? SMENU SMN)
(\ILLEGAL.ARG SMN)) (* edited: "22-Feb-85 14:33")
[SETQ IMAGE (COND
(NEWIMAGEFLG (replace SMENUBM of SMN with (CREATE-IMAGE SMN)))
((fetch (SMENU SMENUBM) of SMN))
(T (replace SMENUBM of SMN with (CREATE-IMAGE SMN]
[COND
(MKWFLG (COND
((WINDOWP (fetch (SMENU WINDOW) of SMN))
NIL)
(T (replace WINDOW of SMN with (CREATEW [CREATEREGION
(SETQ LEFT 0)
(SETQ BOTTOM 0)
(SETQ WIDTH
(IMAX (fetch (SMENU SMENUWIDTH)
of SMN)
(BITMAPWIDTH IMAGE)))
(SETQ HEIGHT
(IMAX (fetch (SMENU SMENUHEIGHT)
of SMN)
(BITMAPHEIGHT IMAGE]
NIL 0 (QUOTE T]
(RETURN IMAGE])
(CREATE-IMAGE
[LAMBDA (S) (* edited: "21-May-85 12:43")
(* * This function is used to create the image for the SMENU. This includes all region images, the title, outline,
etc.)
(PROG (WIDTH HEIGHT (SMFONT (fetch (SMENU SMENUFONT) of S))
TITLE TITLEFONT TITLEHEIGHT TITLEWIDTH (ITEMLIST (fetch (SMENU ITEMS) of S))
BORDER SMENUBM BMASSOCLST OUTLIN)
(SETQ BORDER (OR (FIXP (fetch (SMENU SMENUBORDERSIZE) of S))
(replace SMENUBORDERSIZE of S with 0)))
[SETQ OUTLIN (OR (FIXP (fetch SMENUOUTLINESIZE of S))
(replace (SMENU SMENUOUTLINESIZE) of S with (IMAX BORDER 1]
(COND
((SETQ TITLE (fetch (SMENU TITLE) of S))
(SETQ TITLEFONT (SMENUTITLEFONT S))
(SETQ TITLEHEIGHT (FONTPROP TITLEFONT (QUOTE HEIGHT)))
(SETQ TITLEWIDTH (STRINGWIDTH TITLE TITLEFONT)))
(T (SETQ TITLEHEIGHT 0)
(SETQ TITLEWIDTH 0)))
(replace SMENUWIDTH of S with (SETQ WIDTH (IPLUS [IMAX (OR (fetch (SMENU SMENUWIDTH)
of S)
0)
(HOWWIDE (for I in ITEMLIST
largest (HOWWIDE I]
OUTLIN OUTLIN)))
[replace SMENUHEIGHT of S with (SETQ HEIGHT
(IPLUS OUTLIN OUTLIN TITLEHEIGHT
(IMAX (OR (fetch (SMENU SMENUHEIGHT) of S)
0)
(HOWHIGH (for I in ITEMLIST
largest (HOWHIGH I]
(COND
[(FONTP (SETQ SMFONT (AND SMFONT (\GETFONTDESC SMFONT (QUOTE DISPLAY)
T]
(T [SETQ SMFONT (COND
((FONTP SMENUFONT))
(T (SETQ SMENUFONT (FONTCREATE (QUOTE HELVETICA)
10]
(replace (SMENU SMENUFONT) of S with SMFONT)))
(SETQ BORDER (OR (FIXP (fetch (SMENU SMENUBORDERSIZE) of S))
(replace SMENUBORDERSIZE of S with 0)))
(SETQ SMENUBM (BITMAPCREATE WIDTH HEIGHT))
(* * Two BITBLTs are used to draw the outline)
(BITBLT NIL NIL NIL SMENUBM 0 0 WIDTH HEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE)
(BITBLT NIL NIL NIL SMENUBM OUTLIN OUTLIN (IDIFFERENCE WIDTH (IPLUS OUTLIN OUTLIN))
(IDIFFERENCE HEIGHT (IPLUS OUTLIN OUTLIN TITLEHEIGHT))
(QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
(* * Each item is drawn in its proper position)
(for I in ITEMLIST do [PROG (BM LEF BOT WID HGT (IREGION (GET-REGION I)))
(GET-REGIONVALS LEF BOT WID HGT IREGION)
(DRAW-BORDER SMENUBM IREGION BORDER)
(BITBLT [SETQ BM (COND
[(BITMAPP (EVAL (CAR I]
((STRINGP (CAR I))
[RPLACA I (CONS (QUOTE QUOTE)
(LIST (MKLST (CAR I]
(TEXTMAP I IREGION S))
((LISTP (CAR I))
(TEXTMAP I IREGION S]
0 0 SMENUBM LEF BOT WID HGT (QUOTE INPUT)
(QUOTE REPLACE))
(COND
[(NULL BMASSOCLST)
(SETQ BMASSOCLST (LIST (CONS I BM]
(T (PUTASSOC I BM BMASSOCLST]
finally (replace (SMENU BMASSOCLST) of S with BMASSOCLST))
(* * Here the title is drawn in the correct font.)
(BITBLT (TEXTMAP (LIST (QUOTE (MKLST TITLE))
NIL NIL NIL TITLEFONT)
(LIST 0 0 WIDTH TITLEHEIGHT))
0 0 SMENUBM 0 (IDIFFERENCE HEIGHT TITLEHEIGHT)
WIDTH TITLEHEIGHT (QUOTE INVERT))
(RETURN SMENUBM])
(TEXTMAP
[LAMBDA (I R) (* JTS "27-Mar-85 11:45")
(* * Create a bitmap, on which is formatted the text which is in the -
----- car of the item, RETURN this bitmap.)
(LET ((F-CHOICE (GET-FONT I))
(ITEMTEXT (EVAL (CAR I)))
(CHARS (LENGTH (EVAL (CAR I)))))
(PROG ([MAKE-FONT-LIST? (AND (ATOM F-CHOICE)
(EQ F-CHOICE (QUOTE FITFONT]
(H (fetch (REGION HEIGHT) of R))
(W (fetch (REGION WIDTH) of R))
TFONT FONT-LIST TOP-OF-LOOP EDGE TEXTBM)
(if MAKE-FONT-LIST?
then (SETQ FONT-LIST (CHOOSEFONT CHARS W H)))
(* * Given a list of font descriptors which should be appropriate -
----- to print the item text, try them out in descending order -
----- until the text fits, or there are no more fonts to try.)
TOP-OF-LOOP
[SETQ TFONT (COND
((pop FONT-LIST))
((NULL F-CHOICE)
SMENUFONT)
(T (FONTP (EVAL F-CHOICE]
(SETQ EDGE (STRINGWIDTH " " TFONT))
(SETQ TEXTBM (BITMAPCREATE W H))
(SETQ DSP (DSPCREATE TEXTBM))
(DSPFONT TFONT DSP)
(DSPRIGHTMARGIN (IDIFFERENCE (BITMAPWIDTH TEXTBM)
EDGE)
DSP)
(DSPLEFTMARGIN EDGE DSP)
(DSPXPOSITION EDGE DSP)
(DSPYPOSITION H DSP)
(TERPRI DSP)
(PRINTPARA 0 0 ITEMTEXT NIL NIL DSP)
(if (OR (NOT MAKE-FONT-LIST?)
(LESSP 0 (DSPYPOSITION NIL DSP))
(NULL FONT-LIST))
then (RETURN TEXTBM)
else (GO TOP-OF-LOOP))))])
(CHOOSEFONT
[LAMBDA (LENGTH W H) (* JTS " 8-Mar-85 14:17")
(* * Given the number of characters to print, and the width and -
----- height of the region to print them in, CHOOSEFONT eliminates -
----- fonts which are most likely too big to allow all of the text -
----- to fit in the region, and returns a list of the rest.)
(PROG [(CHAR-ROOM (IQUOTIENT (ITIMES W H)
LENGTH))
(FONT-LIST SMENU-CHOOSEFONT-LIST)
(SIZES (QUOTE (5772 988 594 247 160 126 108 50 35]
(RETURN (NTH FONT-LIST (IPLUS 1 (for TRY in SIZES count (LESSP CHAR-ROOM TRY])
)
(DEFINEQ
(GET-BOXREGION
[LAMBDA (REG BORDER SUPERFLG) (* edited: "15-Mar-85 20:10")
(LET ((EXTRA (OR (AND SUPERFLG BORDER)
0)))
(CREATEREGION (IDIFFERENCE (fetch (REGION LEFT) of REG)
BORDER)
(IDIFFERENCE (fetch (REGION BOTTOM) of REG)
BORDER)
(IPLUS (fetch (REGION WIDTH) of REG)
BORDER EXTRA)
(IPLUS (fetch (REGION HEIGHT) of REG)
BORDER EXTRA)))])
(GET-FONT
[LAMBDA (L) (* edited: "23-Feb-85 18:14")
(CAR (NTH L 5])
(GET-REGION
[LAMBDA (L) (* JTS " 8-Mar-85 14:01")
(CAR (NTH L 4])
(GET-ITEMS
[LAMBDA (SMENU REGIONS) (* JTS "17-Mar-85 19:27")
(LET ((ITEMS (fetch (SMENU ITEMS) of SMENU)))
(for I in ITEMS collect I when (MEMBER (GET-REGION I)
REGIONS)))])
)
(DEFINEQ
(BACKGROUNDSMENUSELECTEDFN
[LAMBDA (ITEM FROMSMENU BUTTOM) (* edited: " 3-Mar-85 14:57")
(COND
((CADR ITEM)
(EVAL.AS.PROCESS (CADR ITEM)))
(T (CAR ITEM])
(DEFAULTSMENUSELECTEDFN
[LAMBDA (ITEM FROMSMENU BUTTON) (* edited: "25-Mar-85 17:29")
(COND
((LISTP (CADR ITEM))
(STKEVAL (OR (STKPOS (QUOTE SMENU))
(QUOTE SMENUBUTTONFN))
(CADR ITEM)
T))
(T (EVAL (CAR ITEM])
(SMENUBUTTONFN
[LAMBDA (W) (* edited: " 3-Mar-85 15:05")
(if (LASTMOUSESTATE (OR LEFT MIDDLE RIGHT))
then (TOTOPW W)
(bind SELECTION for SMENU in (WINDOWPROP W (QUOTE SMENU)) when (SETQ SELECTION
(SMENU.HANDLER SMENU W))
do (for I in (CAR SELECTION) do (ITEMSELECTED SMENU I (CDR SELECTION])
(SMENU.HANDLER
[LAMBDA (SMENU W CONTROLFLAG) (* JTS "21-Apr-85 16:49")
(PROG (R HELDSTATE INVERTOLD INVERTNEW (HOLDTIMER (SETUPTIMER SMENUHELDWAIT))
(ITEMLIST (fetch (SMENU ITEMS) of SMENU))
(LASTBUTTONSTATE LASTMOUSEBUTTONS)
(MOUSEDOWN (LASTMOUSESTATE (NOT UP)))
(HELDFN (fetch (SMENU WHENHELDFN) of SMENU)))
[if (AND MOUSEDOWN (EQ W (WHICHW)))
then (SETQ INVERTOLD (for R in ITEMLIST collect R when (AND (INSIDEP (GET-REGION R)
(LASTMOUSEX W)
(LASTMOUSEY W))
(INVERTITEMS R SMENU W]
(RETURN (COND
([SETQ ITEM
(ERSETQ (until (COND
(MOUSEDOWN (MOUSESTATE UP))
((MOUSESTATE (NOT UP))
[COND
((AND (NULL CONTROLFLAG)
(LASTMOUSESTATE RIGHT))
(DOWINDOWCOM (WHICHW LASTMOUSEX LASTMOUSEY)))
(T (SETQ MOUSEDOWN T)
(COND
(INVERTOLD (for R in INVERTOLD
do (INVERTITEMS R SMENU W]
NIL))
do [COND
[(EQ W (WHICHW))
[SETQ INVERTNEW (for R in ITEMLIST collect R
when (INSIDEP (GET-REGION R)
(LASTMOUSEX W)
(LASTMOUSEY W]
(COND
((NOT (EQUAL INVERTOLD INVERTNEW))
[COND
(INVERTOLD [COND
(MOUSEDOWN (for R in INVERTOLD
do (INVERTITEMS R SMENU W))
)
(T (for R in INVERTOLD
do (BOXITEM R SMENU W]
(SMENU.HELDRESET INVERTOLD))
(T (SETQ HOLDTIMER (SETUPTIMER SMENUHELDWAIT
HOLDTIMER]
[COND
(MOUSEDOWN (for R in INVERTNEW
do (INVERTITEMS R SMENU W)))
(T (for R in INVERTNEW do (BOXITEM R SMENU W]
(SETQ INVERTOLD INVERTNEW))
((AND HELDFN (NULL HELDSTATE)
(TIMEREXPIRED? HOLDTIMER))
(for R in INVERTOLD do (APPLY* HELDFN R SMENU
(\FDECODE/BUTTON
LASTBUTTONSTATE)))
(SETQ HELDSTATE T]
(T (COND
(INVERTOLD [COND
(MOUSEDOWN (for R in INVERTOLD
do (INVERTITEMS R SMENU W)))
(T (for R in INVERTOLD
do (BOXITEM R SMENU W]
(SMENU.HELDRESET INVERTOLD)
(SETQ INVERTOLD NIL)))
(COND
((NEQ LASTBUTTONSTATE (SETQ LASTBUTTONSTATE
LASTMOUSEBUTTONS))
(SMENU.HELDRESET INVERTOLD]
finally (COND
(INVERTOLD [COND
(MOUSEDOWN (for R in INVERTOLD
do (INVERTITEMS R SMENU W)))
(T (for R in INVERTOLD
do (BOXITEM R SMENU W]
(SMENU.HELDRESET INVERTOLD)))
(RETURN (COND
(INVERTOLD (CONS INVERTOLD (\FDECODE/BUTTON
LASTBUTTONSTATE]
(RETURN (CAR ITEM)))
(T [COND
(INVERTOLD (COND
(MOUSEDOWN (for R in INVERTOLD do (INVERTITEMS R SMENU W)))
(T (for R in INVERTOLD do (BOXITEM R SMENU W]
(ERROR!])
)
(SETQ SMENUHELDWAIT 1200)
(SETQ SMENUFONT (FONTCREATE (QUOTE HELVETICA)
10))
(SETQ SMENU-CHOOSEFONT-LIST (LIST (FONTCREATE (QUOTE TIMESROMAND)
72)
(FONTCREATE (QUOTE HELVETICA)
36)
(FONTCREATE (QUOTE HELVETICAD)
24)
(FONTCREATE (QUOTE HELVETICA)
18)
(FONTCREATE (QUOTE HELVETICA)
14)
(FONTCREATE (QUOTE HELVETICA)
12)
(FONTCREATE (QUOTE HELVETICA)
10)
(FONTCREATE (QUOTE HELVETICA)
7)
(FONTCREATE (QUOTE HELVETICA)
5)))
[DECLARE: EVAL@COMPILE
(DATATYPE SMENU (SMENUWIDTH SMENUHEIGHT ITEMS TITLE TITLEFONT SMENUBORDERSIZE SMENUOUTLINESIZE
SMENUFONT SMENUPOSITION WHENHELDFN WHENUNHELDFN WHENSELECTEDFN USERDATA
BMASSOCLST SMENUBM WINDOW)
WHENHELDFN ←(QUOTE DEFAULTMENUHELDFN)
WHENUNHELDFN ←(QUOTE CLRPROMPT)
[ACCESSFNS ((SMENUHEIGHT (FETCH (BITMAP BITMAPHEIGHT) OF (CHECK/SMENUBM DATUM)))
(SMENUWIDTH (FETCH (BITMAP BITMAPWIDTH) OF (CHECK/SMENUBM DATUM)))
(SMENUBM (CHECK/SMENUBM DATUM)
(REPLACE (SMENU SMENUBM) OF DATUM WITH (CHECK/SMENUBM DATUM])
]
(/DECLAREDATATYPE (QUOTE SMENU)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER)))
(DECLARE: EVAL@COMPILE
(PUTPROPS SMENU.HELDRESET MACRO ((INVERTS)
[COND
(HELDSTATE (COND
((SETQ HELDSTATE (fetch (SMENU WHENUNHELDFN)
of SMENU))
(APPLY* HELDSTATE (GET-ITEMS SMENU INVERTS)
SMENU
(\FDECODE/BUTTON LASTBUTTONSTATE))
(SETQ HELDSTATE NIL]
(SETQ HOLDTIMER (SETUPTIMER 1200 HOLDTIMER))))
)
(PUTPROPS TOP-OF-LOOP INFO LABEL)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1348 6742 (ERASESMENUIMAGE 1358 . 1603) (HOWHIGH 1605 . 1907) (HOWWIDE 1909 . 2358) (
INVERTITEMS 2360 . 2844) (BOXITEM 2846 . 3725) (ITEMSELECTED 3727 . 3985) (MKLST 3987 . 4518) (SETUP
4520 . 5400) (SMENUPROP 5402 . 5885) (SMENUREPAINTFN 5887 . 6187) (SMENUTITLEFONT 6189 . 6740)) (6743
12023 (SMENU 6753 . 9196) (ADDSMENU 9198 . 11052) (DELETESMENU 11054 . 12021)) (12024 19483 (
CHECK/SMENUBM 12034 . 13139) (CREATE-IMAGE 13141 . 17072) (TEXTMAP 17074 . 18780) (CHOOSEFONT 18782 .
19481)) (19484 20555 (GET-BOXREGION 19494 . 19995) (GET-FONT 19997 . 20133) (GET-REGION 20135 . 20269)
(GET-ITEMS 20271 . 20553)) (20556 25009 (BACKGROUNDSMENUSELECTEDFN 20566 . 20793) (
DEFAULTSMENUSELECTEDFN 20795 . 21114) (SMENUBUTTONFN 21116 . 21568) (SMENU.HANDLER 21570 . 25007)))))
STOP