(FILECREATED "19-Jan-85 18:19:17" {SDRVX1}INTERLISP$DISK:<INTERLISP.37120.STC>MULTIMENU.;8 36744
changes to: (FNS \MENURESHAPEFN)
previous date: "18-Dec-84 12:30:49" {SDRVX1}INTERLISP$DISK:<INTERLISP.37120.STC>MULTIMENU.;7)
(* Copyright (c) 1983, 1984, 1985 by Schlumberger Technology Corporation)
(PRETTYCOMPRINT MULTIMENUCOMS)
(RPAQQ MULTIMENUCOMS ((FNS ADDMULTIMENU CHANGEMULTIMENU DEFAULTACTIVEREGION DELETEALLMENUS
DELMULTIMENU GET-WINDOW-OF-MENU GRAYEDMENUSELECTEDFN GRAYMENU HELPTITLEFN
MAKEMENUS MAKETTYWINDOW MENUANDTITLEFN MENUEXISTS MULTIWINDOWREAD
SETUP-MENU-FOR-HELP TOTOPMENUS UNGRAYMENU WINDOWDOFUN \ADDMULTIMENU1
\FIND-MENUCOLUMN-HEIGHT \FIND-MENUHEIGHT \FIND-MENUWIDTH \FIND-WIDEST-MENU
\FIND-WIDEST-WINDOW \MAKEMENU \MAKEMENU1 \MAKEMENUID \MAKEMENUWINDOW
\MAKESCROLLINGMENUP \MENUCLOSEFN \MENUEXPANDFN \MENUMOVEFN \MENUOPENFN
\MENURESHAPEFN \MENUSHRINKFN \MENUTOTOPFN \TOTOPMENUS \UPDATEMINMENU)
(RECORDS MENULSTENTRY)
(VARS \TTYHEIGHT *HELPTITLEFLG*)))
(DEFINEQ
(ADDMULTIMENU
(LAMBDA (MAINW NEWMENULSTENTRY WHERE) (* ejs: "13-JUN-84 17:31")
(* * This function adds a new menu to the menucolumn on MAINW. MENULSTENTRY is in the usual format.
WHERE is a list of form (FIRST LAST BEFORE AFTER <A MENUID>); if not supplied, the new menu is added at the end
(bottom))
(PROG (NEW)
(COND
((NULL (WINDOWPROP MAINW (QUOTE ITEMMENU)))
(WINDOWPROP MAINW (QUOTE MINMENUHEIGHT)
(fetch (REGION HEIGHT) of (WINDOWPROP MAINW (QUOTE REGION))))
(SETQ NEW (\MAKEMENU MAINW NEWMENULSTENTRY (\FIND-MENUWIDTH NEWMENULSTENTRY)))
(WINDOWADDPROP MAINW (QUOTE MOVEFN)
(QUOTE \MENUMOVEFN))
(WINDOWADDPROP MAINW (QUOTE CLOSEFN)
(QUOTE \MENUCLOSEFN))
(WINDOWADDPROP MAINW (QUOTE RESHAPEFN)
(QUOTE \MENURESHAPEFN)))
(T (OR WHERE (SETQ WHERE (LIST (QUOTE LAST))))
(SELECTQ (COND
((LISTP WHERE)
(CAR WHERE))
(T WHERE))
(LAST (SETQ NEW (\MAKEMENU MAINW NEWMENULSTENTRY (\FIND-WIDEST-WINDOW MAINW)))
)
(FIRST (SETQ NEW (\ADDMULTIMENU1 MAINW NEWMENULSTENTRY
(LIST (QUOTE BEFORE)
(CAAR (WINDOWPROP MAINW (QUOTE
ITEMMENU)))))
))
((AFTER BEFORE)
(SETQ NEW (\ADDMULTIMENU1 MAINW NEWMENULSTENTRY WHERE)))
(ERROR
"Menu location relation must be one of FIRST, LAST, BEFORE, AFTER, or NIL"))
(\UPDATEMINMENU MAINW)))
(RETURN NEW))))
(CHANGEMULTIMENU
(LAMBDA (MAINW OLDMENUID NEWMENU) (* ejs: "13-JUN-84 17:28")
(* * Replaces OLDMENU with NEWMENU, suitably adjusting the menu column)
(PROG ((MLST (WINDOWPROP MAINW (QUOTE ITEMMENU)))
MLSTTAIL DELMENU RELPOS W NEW)
(COND
((NOT (SETQ DELMENU (SASSOC OLDMENUID MLST)))
(RETURN (\MAKEMENU MAINW NEWMENU (\FIND-WIDEST-WINDOW MAINW)))))
(SETQ MLSTTAIL (for M on MLST until (EQUAL (CAAR M)
OLDMENUID)
finally (RETURN (CDR M))))
(COND
((AND (NULL MLSTTAIL)
NEWMENU)
(DELMULTIMENU MAINW (CAAR (FLAST (WINDOWPROP MAINW (QUOTE ITEMMENU)))))
(RETURN (\MAKEMENU MAINW NEWMENU (\FIND-WIDEST-WINDOW MAINW)))))
(CLOSEW (CDR DELMENU))
(SETQ RELPOS (COND
(NEWMENU (create POSITION
XCOORD ← 0
YCOORD ←(IDIFFERENCE (fetch (REGION HEIGHT)
of (WINDOWPROP (CDR DELMENU)
(QUOTE REGION)))
(COND
((\MAKESCROLLINGMENUP NEWMENU)
(fetch (MENULSTENTRY MENUSCROLLFLG)
of NEWMENU))
(T (\FIND-MENUHEIGHT NEWMENU))))))
(T (create POSITION
XCOORD ← 0
YCOORD ←(fetch (REGION HEIGHT) of (WINDOWPROP (CDR DELMENU)
(QUOTE REGION)))))))
(for M in (COND
((ILESSP (fetch YCOORD of RELPOS)
0)
(REVERSE MLSTTAIL))
(T MLSTTAIL))
do (RELMOVEW (CDR M)
RELPOS))
(COND
(NEWMENU (WINDOWPROP MAINW (QUOTE ITEMMENU)
(SUBST (SETQ NEW
(CONS (\MAKEMENUID NEWMENU)
(\MAKEMENU1
MAINW NEWMENU
(create POSITION
XCOORD ←(IDIFFERENCE
(fetch (REGION LEFT)
of (WINDOWPROP MAINW (QUOTE REGION)))
(COND
((OR (LISTP NEWMENU)
(LISTP (EVAL NEWMENU)))
(IPLUS (\FIND-WIDEST-WINDOW MAINW)
2))
(T (\FIND-MENUWIDTH NEWMENU))))
YCOORD ←(IPLUS (fetch (REGION BOTTOM)
of (WINDOWPROP
(CDAR MLSTTAIL)
(QUOTE REGION)))
(fetch (REGION HEIGHT)
of (WINDOWPROP
(CDAR MLSTTAIL)
(QUOTE REGION))))))))
DELMENU MLST)))
(T (WINDOWPROP MAINW (QUOTE ITEMMENU)
(REMOVE DELMENU MLST))))
(\UPDATEMINMENU MAINW)
(RETURN NEW))))
(DEFAULTACTIVEREGION
(LAMBDA (WINDOW) (* Crystal: "13-Dec-84 16:17")
(* * DEFAULTACTIVEREGION sets up an active region for bringing multimenus to the top when the window to which they
are attached is buttoned.)
(WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN)
(FUNCTION ACTIVEREGIONS/BUTTONEVENTFN))
(WINDOWPROP WINDOW (QUOTE DEFAULTACTIVEREGION)
(create ACTIVEREGION
DOWNFN ←(FUNCTION TOTOPMENUS)))))
(DELETEALLMENUS
(LAMBDA (WINDOW) (* edited: "22-SEP-82 16:30")
(for M in (WINDOWPROP WINDOW (QUOTE ITEMMENU)
NIL)
do (CLOSEW (CDR M)))
(WINDOWPROP WINDOW (QUOTE MINMENUHEIGHT)
(fetch (REGION HEIGHT) of (WINDOWPROP WINDOW (QUOTE REGION))))))
(DELMULTIMENU
(LAMBDA (MAINW MENUID) (* ejs: "31-AUG-82 09:09")
(CHANGEMULTIMENU MAINW MENUID)))
(GET-WINDOW-OF-MENU
(LAMBDA (PARENTWINDOW MENUID) (* TONY: " 5-NOV-82 10:14")
(* PARENTWINDOW is the window to which the menu window is attached. MENUID is the TITLE string of
the menu window. GET-WINDOW-OF-MENU returns the pointer to the window corresponding to the menu.
*)
(CDR (SASSOC MENUID (WINDOWPROP PARENTWINDOW (QUOTE ITEMMENU))))))
(GRAYEDMENUSELECTEDFN
(LAMBDA (ITEM MENU MOUSE) (* ejs: "31-Jul-84 01:07")
(PROG ((GRAYEDITEMS (NLEFT (fetch (MENU ITEMS) of MENU)
(WINDOWPROP (fetch (MENU IMAGE) of MENU)
(QUOTE GRAYEDITEMS)))))
(COND
((NOT (FMEMB ITEM GRAYEDITEMS))
(APPLY (WINDOWPROP (fetch (MENU IMAGE) of MENU)
(QUOTE SELECTEDFN))
(LIST ITEM MENU MOUSE)))))))
(GRAYMENU
(LAMBDA (MAINW MENU #ITEMSTOGRAY NEWBUTTONFN) (* rgs: " 5-OCT-82 10:20")
(PROG (MI CPX CPY MNU (W (CDR (COND
((LISTP MAINW)
MAINW)
(T (SASSOC MENU (WINDOWPROP MAINW (QUOTE ITEMMENU)))))
)))
(COND
((NOT (WINDOWP W))
(RETURN)))
(COND
((EQ #ITEMSTOGRAY 0)
(UNGRAYMENU MAINW MENU)
(RETURN NIL)))
(SETQ CPX (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL (WINDOWPROP
W
(QUOTE DSP)))))
(SETQ CPY (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL (WINDOWPROP
W
(QUOTE DSP)))))
(COND
((EQUAL (fetch (MENU WHENSELECTEDFN) of (CAR (WINDOWPROP W (QUOTE MENU))))
(QUOTE GRAYEDMENUSELECTEDFN))
(UNGRAYMENU MAINW MENU)))
(COND
((NOT (WINDOWPROP W (QUOTE GRAYED)))
(COND
((NOT (WINDOWPROP W (QUOTE MENUIMAGE)))
(WINDOWPROP W (QUOTE MENUIMAGE)
(BITMAPCREATE (fetch (REGION WIDTH)
of (WINDOWPROP W (QUOTE REGION)))
(fetch (REGION HEIGHT)
of (WINDOWPROP W (QUOTE REGION)))))))
(BITBLT W CPX CPY (WINDOWPROP W (QUOTE MENUIMAGE))
0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE))
(COND
((AND (WINDOWPROP W (QUOTE MENU))
(NOT (WINDOWPROP W (QUOTE SCROLLFN))))
(BITBLT W NIL NIL W 2 2 (IPLUS (WINDOWPROP W (QUOTE WIDTH))
-4)
(COND
(#ITEMSTOGRAY (ITIMES #ITEMSTOGRAY
(fetch (MENU ITEMHEIGHT)
of (CAR (WINDOWPROP W (QUOTE MENU))))
))
(T (IPLUS (WINDOWPROP W (QUOTE HEIGHT))
(DSPLINEFEED NIL WindowTitleDisplayStream)
-4)))
(QUOTE TEXTURE)
(QUOTE REPLACE)
HIGHLIGHTSHADE)
(COND
(#ITEMSTOGRAY
(COND
((OR (MINUSP #ITEMSTOGRAY)
(IGREATERP #ITEMSTOGRAY
(LENGTH (fetch (MENU ITEMS)
of (CAR (WINDOWPROP W (QUOTE MENU))))))
)
(ERROR "GRAYMENU: #ITEMSTOGRAY argument is 0 or too big")))
(WINDOWPROP (fetch (MENU IMAGE)
of (SETQ MNU (CAR (WINDOWPROP W (QUOTE MENU)))))
(QUOTE GRAYEDITEMS)
#ITEMSTOGRAY)
(WINDOWPROP (fetch (MENU IMAGE) of MNU)
(QUOTE SELECTEDFN)
(fetch (MENU WHENSELECTEDFN) of MNU))
(replace (MENU WHENSELECTEDFN) of MNU with (QUOTE
GRAYEDMENUSELECTEDFN))
(WINDOWPROP W (QUOTE SAVEDBUTTONFN)
NIL))
(T (WINDOWPROP W (QUOTE SAVEDBUTTONFN)
(WINDOWPROP W (QUOTE BUTTONEVENTFN)
NEWBUTTONFN)))))
(T (BITBLT W NIL NIL W CPX CPY (IPLUS (fetch (REGION WIDTH)
of (WINDOWPROP W (QUOTE REGION)))
(IMINUS (WINDOWPROP W (QUOTE BORDER)
)))
(fetch (REGION HEIGHT) of (WINDOWPROP W (QUOTE REGION)))
(QUOTE TEXTURE)
(QUOTE REPLACE)
HIGHLIGHTSHADE)
(WINDOWPROP W (QUOTE SAVEDBUTTONFN)
(WINDOWPROP W (QUOTE BUTTONEVENTFN)
NEWBUTTONFN))))
(WINDOWPROP W (QUOTE GRAYED)
T)
(WINDOWPROP W (QUOTE SAVEDSCROLLFN)
(WINDOWPROP W (QUOTE SCROLLFN)
NIL)))))))
(HELPTITLEFN
(LAMBDA (WINDOW) (* TONY: " 9-NOV-82 08:39")
(COND
((NOT (BOUNDP (QUOTE *HELPTITLEFLG*)))
(SETQ *HELPTITLEFLG* T))
(T (SETQ *HELPTITLEFLG* (NOT *HELPTITLEFLG*))))
(AND *HELPTITLEFLG* (PROMPTPRINT (CAR (WINDOWPROP WINDOW (QUOTE MENUHELPSTRING)))))))
(MAKEMENUS
(LAMBDA (WINDOW MENULST WIDTH) (* Crystal: "24-APR-84 22:36")
(* * This function creates a set of menus placed along the left side of WINDOW, from top to bottom.
MENULST is a list of MENULSTENTRY's. WINDOW gets 2 new properties: MINMENUHEIGHT, used to determine the placement
of the next window relative to the others, and ITEMMENU, a list of (MENUTITLE . WINDOW-CONTAINING-THE-MENU). Menus
so created can be deactivated (and grayed-out) by called GRAYMENU with the proper entry from ITEMMENU;
UNGRAYMENU with the proper argument ungrays the menu and reactivates it)
(* * DRB: 1.NOV. added MAINWINDOW property to windows for MENULST)
(PROG ((MW (OR WIDTH (\FIND-WIDEST-MENU MENULST))))
(COND
((NULL (WINDOWPROP WINDOW (QUOTE ITEMMENU)))
(WINDOWPROP WINDOW (QUOTE MINMENUHEIGHT)
(fetch (REGION HEIGHT) of (WINDOWPROP WINDOW (QUOTE REGION))))))
(for MENU in MENULST do (\MAKEMENU WINDOW MENU MW))
(WINDOWADDPROP WINDOW (QUOTE CLOSEFN)
(FUNCTION \MENUCLOSEFN))
(WINDOWADDPROP WINDOW (QUOTE RESHAPEFN)
(FUNCTION \MENURESHAPEFN))
(WINDOWADDPROP WINDOW (QUOTE MOVEFN)
(FUNCTION \MENUMOVEFN))
(WINDOWADDPROP WINDOW (QUOTE EXPANDFN)
(FUNCTION \MENUEXPANDFN))
(WINDOWADDPROP WINDOW (QUOTE OPENFN)
(FUNCTION \MENUEXPANDFN))
(WINDOWADDPROP WINDOW (QUOTE SHRINKFN)
(FUNCTION \MENUSHRINKFN))
(WINDOWADDPROP WINDOW (QUOTE TOTOPFN)
(FUNCTION \TOTOPMENUS))
(RETURN (WINDOWPROP WINDOW (QUOTE ITEMMENU))))))
(MAKETTYWINDOW
(LAMBDA (MAINW TTYWIDTH TTYHEIGHT) (* rgs: "14-OCT-82 10:46")
(* * This function makes an ephemeral TTY window beneath the main window, the same width as the
main window and menu column combined, and TTY high (defaults to \TTYHEIGHT))
(PROG ((TTYW (WINDOWPROP MAINW (QUOTE TTYWINDOW)))
BOTTOM LEFT WIDTH (MAINWR (WINDOWPROP MAINW (QUOTE REGION))))
(COND
((AND TTYW (NOT TTYWIDTH))
(RETURN TTYW))
(T (SETQ BOTTOM (IMAX 0 (IPLUS (IDIFFERENCE
(IMIN (fetch (REGION BOTTOM) of MAINWR)
(IPLUS (fetch (REGION BOTTOM)
of MAINWR)
(COND
((WINDOWPROP MAINW
(QUOTE
MINMENUHEIGHT)))
(T 0))))
(OR TTYHEIGHT \TTYHEIGHT))
(LRSH (WINDOWPROP MAINW (QUOTE BORDER))
1))))
(SETQ LEFT (fetch (REGION LEFT) of MAINWR))
(SETQ WIDTH (OR TTYWIDTH (fetch (REGION WIDTH) of MAINWR)))
(SETQ TTYW
(CREATEW (create REGION
LEFT ← LEFT
BOTTOM ← BOTTOM
WIDTH ← WIDTH
HEIGHT ←(OR TTYHEIGHT \TTYHEIGHT))))
(DSPSCROLL (QUOTE ON)
TTYW)
(WINDOWPROP MAINW (QUOTE TTYWINDOW)
TTYW)
(RETURN TTYW))))))
(MENUANDTITLEFN
(LAMBDA (WINDOW) (* TONY: " 9-NOV-82 08:41")
(CLRPROMPT)
(COND
((WINDOWPROP WINDOW (QUOTE SCROLLFN))
(COND
((INSIDEP (DSPCLIPPINGREGION NIL WINDOW)
(LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW))
(SETQ *HELPTITLEFLG* NIL)
(MENUBUTTONFN WINDOW))
(T (HELPTITLEFN WINDOW))))
(T (COND
((GEQ (GRIDYCOORD (LASTMOUSEY WINDOW)
(fetch (MENU MENUGRID) of (CAR (WINDOWPROP WINDOW
(QUOTE MENU)))))
(LENGTH (fetch (MENU ITEMS) of (CAR (WINDOWPROP WINDOW (QUOTE MENU))))))
(HELPTITLEFN WINDOW))
(T (SETQ *HELPTITLEFLG* NIL)
(MENUBUTTONFN WINDOW)))))
WINDOW))
(MENUEXISTS
(LAMBDA (MAINW MENUID) (* ejs: "25-SEP-82 15:27")
(COND
((SASSOC MENUID (WINDOWPROP MAINW (QUOTE ITEMMENU)))
MENUID)
(T NIL))))
(MULTIWINDOWREAD
(LAMBDA (WINDOW PROMPT STAYOPENFLG) (* ejs: " 6-OCT-82 17:12")
(PROG (TMP (TTYW (MAKETTYWINDOW WINDOW)))
(COND
((THIS.PROCESS)
(PREEMPT.KEYBOARD (RESETLST (RESETSAVE (TTYDISPLAYSTREAM TTYW))
(SETQ TMP (TTYIN PROMPT NIL PROMPT)))))
(T (RESETLST (RESETSAVE (TTYDISPLAYSTREAM TTYW))
(SETQ TMP (TTYIN PROMPT NIL PROMPT)))))
(COND
((NOT STAYOPENFLG)
(CLEARW TTYW)
(CLOSEW TTYW)))
(RETURN TMP))))
(SETUP-MENU-FOR-HELP
(LAMBDA (PARENTWINDOW CURRENT-MENULSTENTRY HELP-STRING)
(* TONY: " 5-NOV-82 14:53")
(PROG ((DEFAULT-HELP-MESSAGE "No help message available...")
(MENUWINDOW (GET-WINDOW-OF-MENU PARENTWINDOW (fetch (MENULSTENTRY MENUTITLE)
of CURRENT-MENULSTENTRY))))
(WINDOWADDPROP MENUWINDOW (QUOTE MENUHELPSTRING)
(OR HELP-STRING DEFAULT-HELP-MESSAGE))
(WINDOWPROP MENUWINDOW (QUOTE BUTTONEVENTFN)
(QUOTE MENUANDTITLEFN))
(RETURN MENUWINDOW))))
(TOTOPMENUS
(LAMBDA (WINDOW) (* Crystal: "13-Dec-84 15:30")
(* * This is useful in an active region to bring multimenus to the top along with window to which they are
attached.)
(TOTOPW WINDOW)
(\TOTOPMENUS WINDOW)
(UNTILMOUSESTATE UP)))
(UNGRAYMENU
(LAMBDA (MAINW MENU) (* rgs: " 5-OCT-82 10:23")
(PROG (CPX CPY (W (CDR (COND
((LISTP MAINW)
MAINW)
(T (SASSOC MENU (WINDOWPROP MAINW (QUOTE ITEMMENU))))))))
(COND
((NOT (WINDOWP W))
(RETURN)))
(SETQ CPX (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL W)))
(SETQ CPY (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL W)))
(COND
((WINDOWPROP W (QUOTE GRAYED))
(BITBLT (WINDOWPROP W (QUOTE MENUIMAGE))
0 0 (WINDOWPROP W (QUOTE DSP))
CPX CPY NIL NIL (QUOTE INPUT)
(QUOTE REPLACE))
(WINDOWPROP W (QUOTE GRAYED)
NIL)
(COND
((WINDOWPROP (fetch (MENU IMAGE) of (CAR (WINDOWPROP W (QUOTE MENU))))
(QUOTE GRAYEDITEMS)
NIL)
(replace (MENU WHENSELECTEDFN) of (CAR (WINDOWPROP W (QUOTE MENU)))
with (WINDOWPROP (fetch (MENU IMAGE)
of (CAR (WINDOWPROP W (QUOTE MENU))))
(QUOTE SELECTEDFN))))
(T (COND
((WINDOWPROP W (QUOTE SAVEDBUTTONFN))
(WINDOWPROP W (QUOTE BUTTONEVENTFN)
(WINDOWPROP W (QUOTE SAVEDBUTTONFN)))))))
(WINDOWPROP W (QUOTE SCROLLFN)
(WINDOWPROP W (QUOTE SAVEDSCROLLFN)))
(INVERTW W)
(INVERTW W))))))
(WINDOWDOFUN
(LAMBDA (WINDOW FN STAYOPENFLG WIDTH) (* rgs: "14-OCT-82 10:49")
(* * Function to evaluate an arbitrary function with the TTYDISPLAYSTREAM reset to the TTYWINDOW.
If STAYOPENFLG is NIL the TTYWINDOW is closed after evaluating FN. If WIDTH is supplied, the
TTYWINDOW is made WIDTH pixels wide.)
(PROG (TMP (TTYW (MAKETTYWINDOW WINDOW WIDTH)))
(COND
((THIS.PROCESS)
(PREEMPT.KEYBOARD (RESETLST (RESETSAVE (TTYDISPLAYSTREAM TTYW))
(SETQ TMP (EVAL FN)))))
(T (RESETLST (RESETSAVE (TTYDISPLAYSTREAM TTYW))
(SETQ TMP (EVAL FN)))))
(COND
((NOT STAYOPENFLG)
(CLOSEW TTYW)
(WINDOWPROP WINDOW (QUOTE TTYWINDOW)
NIL)))
(RETURN TMP))))
(\ADDMULTIMENU1
(LAMBDA (MAINW NEWMENULSTENTRY WHERE) (* ejs: "13-JUN-84 17:27")
(* * This function does the real work of ADDMULTIMENU -- WHERE must be either a BEFORE or AFTER dotted pair here)
(PROG (RELPOS NEWPOS REG W OMENUS OMENUS1 (DY (COND
((\MAKESCROLLINGMENUP NEWMENULSTENTRY)
(fetch (MENULSTENTRY MENUSCROLLFLG)
of NEWMENULSTENTRY))
(T (\FIND-MENUHEIGHT NEWMENULSTENTRY))))
NEW)
(COND
((\MAKESCROLLINGMENUP NEWMENULSTENTRY)
(SETQ DY (fetch (MENULSTENTRY MENUSCROLLFLG) of NEWMENULSTENTRY))))
(SETQ OMENUS1 (for M on (WINDOWPROP MAINW (QUOTE ITEMMENU)) until (EQUAL (CADR WHERE)
(CAAR M))
collect (CAR M) finally (SELECTQ (CAR WHERE)
(BEFORE (SETQ OMENUS M))
(AFTER (SETQ OMENUS (CDR M))
(SETQ $$VAL
(APPEND $$VAL
(LIST (CAR M)))))
(ERROR "Relation must be BEFORE or AFTER")
)))
(COND
((NULL OMENUS)
(RETURN (\MAKEMENU MAINW NEWMENULSTENTRY (\FIND-WIDEST-WINDOW MAINW)))))
(SETQ RELPOS (create POSITION
XCOORD ← 0
YCOORD ←(IMINUS DY)))
(for M in (REVERSE OMENUS) do (RELMOVEW (CDR M)
RELPOS))
(SETQ REG (WINDOWPROP (CDAR OMENUS)
(QUOTE REGION)))
(SETQ NEWPOS (create POSITION
XCOORD ←(IDIFFERENCE (fetch (REGION LEFT) of (WINDOWPROP MAINW
(QUOTE REGION)
))
(COND
((OR (LISTP NEWMENULSTENTRY)
(LISTP (EVAL NEWMENULSTENTRY)))
(IPLUS (\FIND-WIDEST-WINDOW MAINW)
2))
(T (\FIND-MENUWIDTH NEWMENULSTENTRY))))
YCOORD ←(IPLUS (fetch (REGION BOTTOM) of REG)
(fetch (REGION HEIGHT) of REG))))
(SETQ W (\MAKEMENU1 MAINW NEWMENULSTENTRY NEWPOS))
(WINDOWPROP MAINW (QUOTE ITEMMENU)
(APPEND OMENUS1 (CONS (SETQ NEW (CONS (\MAKEMENUID NEWMENULSTENTRY)
W))
OMENUS)))
(RETURN NEW))))
(\FIND-MENUCOLUMN-HEIGHT
(LAMBDA (MENULST) (* ejs: "30-AUG-82 11:59")
(* * This function accepts a MENULST and returns what it thinks will be the height of the column of
menus created by MAKEMENUS)
(PROG NIL
(RETURN (for M in MENULST sum (\FIND-MENUHEIGHT M))))))
(\FIND-MENUHEIGHT
(LAMBDA (MENULSTENTRY) (* ejs: "29-Aug-84 21:05")
(* * This function accepts a single MENULSTENTRY and returns its height)
(PROG ((MT (COND
((TYPENAMEP (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY)
(QUOTE LITATOM))
(TYPENAME (replace (MENULSTENTRY MENUITEMS) of MENULSTENTRY
with (EVAL (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY)))))
(T (TYPENAME (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY))))))
(RETURN (SELECTQ MT
(LISTP (IPLUS (IMINUS (DSPLINEFEED NIL WindowTitleDisplayStream))
(ITIMES (LENGTH (fetch (MENULSTENTRY MENUITEMS)
of MENULSTENTRY))
(FONTPROP MENUFONT (QUOTE HEIGHT)))
4))
(WINDOW (fetch (REGION HEIGHT) of (WINDOWPROP MENULSTENTRY (QUOTE REGION)))
)
(MENU (fetch (MENU IMAGEHEIGHT) of MENULSTENTRY))
0)))))
(\FIND-MENUWIDTH
(LAMBDA (MENULSTENTRY) (* ejs: "31-MAY-83 10:46")
(* * This function returns the width of a single MENULSTENTRY)
(PROG ((MT (COND
((EQUAL (TYPENAME (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY))
(QUOTE LITATOM))
(TYPENAME (SETQ MENULSTENTRY (EVAL (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY)
))))
(T (TYPENAME (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY))))))
(RETURN (SELECTQ MT
(LISTP (IMAX (IPLUS (STRINGWIDTH (fetch (MENULSTENTRY MENUTITLE)
of MENULSTENTRY)
(DSPFONT NIL WindowTitleDisplayStream))
6)
(IPLUS (for W in (MAPCAR (fetch (MENULSTENTRY MENUITEMS)
of MENULSTENTRY)
(FUNCTION (LAMBDA (I)
(STRINGWIDTH (COND
((LISTP I)
(CAR I))
(T I))
MENUFONT))))
maximizing W)
4)))
(WINDOW (IDIFFERENCE (fetch (REGION WIDTH)
of (WINDOWPROP (fetch (MENULSTENTRY MENUITEMS)
of MENULSTENTRY)
(QUOTE REGION)))
4))
(MENU (fetch (MENU IMAGEWIDTH) of (fetch (MENULSTENTRY MENUITEMS)
of MENULSTENTRY)))
0)))))
(\FIND-WIDEST-MENU
(LAMBDA (MENULST) (* ejs: "30-AUG-82 11:54")
(* * This function accepts a list of MENULSTENTRY's, and returns the width of the widest menu in
the list, allowing a set of menus to be stacked on top of one another (in Y, not Z), each the same
width)
(PROG ((MAXW 0)
MT)
(RETURN (for M in MENULST do (SETQ MAXW (IMAX MAXW (\FIND-MENUWIDTH M)))
finally (RETURN MAXW))))))
(\FIND-WIDEST-WINDOW
(LAMBDA (MAINW) (* edited: "22-SEP-82 18:25")
(PROG ((MAXW 0))
(for W in (WINDOWPROP MAINW (QUOTE ITEMMENU))
do (SETQ MAXW (IMAX MAXW (fetch (REGION WIDTH) of (WINDOWPROP (CDR W)
(QUOTE REGION))
))))
(RETURN (IDIFFERENCE MAXW 4)))))
(\MAKEMENU
(LAMBDA (WINDOW MENULSTENTRY WIDTH) (* ejs: "13-JUN-84 17:26")
(* * This function puts up the correct menu based on the type of item selected)
(PROG (M W ENTRY NEW (WREGION (WINDOWPROP WINDOW (QUOTE REGION)))
(SCROLLP (\MAKESCROLLINGMENUP MENULSTENTRY WINDOW))
(MTYPE (SELECTQ (TYPENAME (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY))
(LISTP (QUOTE LISTP))
(MENU (QUOTE MENU))
(WINDOW (QUOTE WINDOW))
(LITATOM (TYPENAME (replace (MENULSTENTRY MENUITEMS) of MENULSTENTRY
with (EVAL (fetch (MENULSTENTRY MENUITEMS)
of MENULSTENTRY)))))
(ERROR "MENULSTENTRY must be MENULSTENTRY, WINDOW, or MENU"))))
(OR (fetch (MENULSTENTRY MENUID) of MENULSTENTRY)
(SELECTQ MTYPE
(MENU (replace (MENULSTENTRY MENUID) of MENULSTENTRY
with (fetch (MENU TITLE) of (fetch (MENULSTENTRY MENUITEMS)
of MENULSTENTRY))))
(WINDOW (replace (MENULSTENTRY MENUID) of MENULSTENTRY
with (WINDOWPROP (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY)
(QUOTE TITLE))))
NIL))
(SETQ ENTRY (SASSOC (fetch (MENULSTENTRY MENUID) of MENULSTENTRY)
(WINDOWPROP WINDOW (QUOTE ITEMMENU))))
(COND
((NOT ENTRY)
(SETQ M (SELECTQ MTYPE
(LISTP (create MENU
ITEMS ←(fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY)
CENTERFLG ← T
MENUOUTLINESIZE ← 2
TITLE ←(COND
((NOT SCROLLP)
(fetch (MENULSTENTRY MENUTITLE) of MENULSTENTRY))
(T NIL))
ITEMWIDTH ← WIDTH
WHENSELECTEDFN ←(fetch (MENULSTENTRY SELECTEDFN)
of MENULSTENTRY)))
((MENU WINDOW)
(fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY))
(ERROR "MENULSTENTRY must be MENULSTENTRY, WINDOW, or MENU")))
(SETQ W
(SELECTQ MTYPE
((LISTP MENU)
(let* ((TPOS (create POSITION
XCOORD ←(IPLUS (IDIFFERENCE (fetch (REGION LEFT)
of WREGION)
(fetch (MENU IMAGEWIDTH)
of M))
2)
YCOORD ←(IDIFFERENCE
(IPLUS (fetch (REGION BOTTOM) of WREGION)
(WINDOWPROP WINDOW (QUOTE MINMENUHEIGHT)))
(COND
((AND SCROLLP (NUMBERP (fetch (MENULSTENTRY
MENUSCROLLFLG)
of MENULSTENTRY))))
(T (fetch (MENU IMAGEHEIGHT) of M))))))
(TW (ADDMENU M (SETQ TW (\MAKEMENUWINDOW MENULSTENTRY TPOS
(fetch (MENU IMAGEWIDTH)
of M)))
(COND
(TW (create POSITION
XCOORD ← -4
YCOORD ← 0))
(T TPOS))
SCROLLP)))
(COND
(SCROLLP (SCROLLBYREPAINTFN TW .5 0.0)))
TW))
(WINDOW (MOVEW M (create POSITION
XCOORD ←(IPLUS (IDIFFERENCE
(fetch (REGION LEFT) of WREGION)
(fetch (REGION WIDTH)
of (WINDOWPROP M (QUOTE REGION))
))
(LRSH (WINDOWPROP M (QUOTE BORDER))
1))
YCOORD ←(IDIFFERENCE (IPLUS (fetch (REGION BOTTOM)
of WREGION)
(WINDOWPROP
WINDOW
(QUOTE MINMENUHEIGHT))
)
(fetch (REGION HEIGHT)
of (WINDOWPROP
M
(QUOTE REGION))))))
(TOTOPW M)
M)
(ERROR "MENULSTENTRY must be MENULSTENTRY, WINDOW, or MENU")))
(WINDOWPROP WINDOW (QUOTE MINMENUHEIGHT)
(IDIFFERENCE (WINDOWPROP WINDOW (QUOTE MINMENUHEIGHT))
(fetch (REGION HEIGHT) of (WINDOWPROP W (QUOTE REGION)))))
(WINDOWADDPROP WINDOW (QUOTE ITEMMENU)
(SETQ NEW (CONS (\MAKEMENUID MENULSTENTRY)
W)))
(* * DRB: MAINWINDOW provides pointer from menu's window to main window)
(WINDOWPROP W (QUOTE MAINWINDOW)
WINDOW)
(* * JSS: Save the MENULSTENTRY in case the menu is remade by \MENURESHAPEFN.)
(WINDOWPROP W (QUOTE MENULSTENTRY)
MENULSTENTRY)
(RETURN NEW))
(T (OPENW (CDR ENTRY))
(RETURN ENTRY))))))
(\MAKEMENU1
(LAMBDA (WINDOW MENULSTENTRY NEWPOS) (* ejs: "22-SEP-82 09:47")
(* * This function puts up the correct menu based on the type of item selected)
(PROG (M W W1 (MTYPE (SELECTQ (TYPENAME (fetch (MENULSTENTRY MENUITEMS) of
MENULSTENTRY))
(LISTP (QUOTE LISTP))
(MENU (QUOTE MENU))
(WINDOW (QUOTE WINDOW))
(LITATOM (TYPENAME (replace (MENULSTENTRY MENUITEMS)
of MENULSTENTRY
with (EVAL (fetch (MENULSTENTRY
MENUITEMS)
of MENULSTENTRY)))))
(ERROR
"MENULSTENTRY must be MENULSTENTRY, WINDOW, or MENU"))))
(RETURN
(SELECTQ
MTYPE
((LISTP MENU)
(PROG ((TW (ADDMENU (COND
((EQUAL MTYPE (QUOTE LISTP))
(PROG ((TMPMENU (create MENU
ITEMS ←(fetch
(MENULSTENTRY MENUITEMS)
of MENULSTENTRY)
CENTERFLG ← T
MENUOUTLINESIZE ← 2
TITLE ←(COND
((NOT (
\MAKESCROLLINGMENUP MENULSTENTRY))
(fetch (MENULSTENTRY
MENUTITLE)
of MENULSTENTRY))
(T NIL))
ITEMWIDTH ←(
\FIND-WIDEST-WINDOW
WINDOW)))
(SELFN (fetch (MENULSTENTRY SELECTEDFN)
of MENULSTENTRY)))
(COND
(SELFN (replace (MENU WHENSELECTEDFN)
of TMPMENU with SELFN)))
(RETURN TMPMENU)))
(T (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY))
)
(SETQ W1 (\MAKEMENUWINDOW MENULSTENTRY NEWPOS
(IPLUS (\FIND-WIDEST-WINDOW
WINDOW)
4)))
(COND
(W1 (create POSITION
XCOORD ← 0
YCOORD ← 0))
(T NEWPOS))
(\MAKESCROLLINGMENUP MENULSTENTRY))))
(COND
((\MAKESCROLLINGMENUP MENULSTENTRY)
(SCROLLBYREPAINTFN TW .5 0.0)))
(RETURN TW)))
(WINDOW (PROG ((W (fetch (MENULSTENTRY MENUITEMS) of MENULSTENTRY)))
(MOVEW W NEWPOS)
(TOTOPW W)
(RETURN W)))
(ERROR "MENULSTENTRY must be MENULSTENTRY, WINDOW, or MENU"))))))
(\MAKEMENUID
(LAMBDA (MENULSTENTRY) (* ejs: "30-AUG-82 11:48")
(OR (fetch (MENULSTENTRY MENUID) of MENULSTENTRY)
(replace (MENULSTENTRY MENUID) of MENULSTENTRY with (fetch (MENULSTENTRY
MENUTITLE)
of MENULSTENTRY)))))
(\MAKEMENUWINDOW
(LAMBDA (MENULSTENTRY POS WIDTH) (* ejs: "29-Aug-84 20:59")
(PROG ((SFLG (fetch (MENULSTENTRY MENUSCROLLFLG) of MENULSTENTRY)))
(RETURN (COND
((AND (NUMBERP SFLG)
(IGEQ SFLG (fetch (POSITION YCOORD) of (MINIMUMWINDOWSIZE)))
(\MAKESCROLLINGMENUP MENULSTENTRY))
(CREATEW (create REGION
LEFT ←(fetch XCOORD of POS)
BOTTOM ←(fetch YCOORD of POS)
WIDTH ← WIDTH
HEIGHT ← SFLG)
(fetch (MENULSTENTRY MENUTITLE) of MENULSTENTRY)
4 NIL))
(T NIL))))))
(\MAKESCROLLINGMENUP
(LAMBDA (MENULSTENTRY WINDOW) (* ejs: "29-Aug-84 21:07")
(* * This function returns T if the menu specified by MENULSTENTRY should scroll)
(let ((SFLG (fetch (MENULSTENTRY MENUSCROLLFLG) of MENULSTENTRY))
MINMENUHEIGHT MENUHEIGHT)
(COND
(SFLG (SETQ MENUHEIGHT (\FIND-MENUHEIGHT MENULSTENTRY))
(COND
((AND (EQ SFLG (QUOTE BOTTOMJUSTIFY))
(IGREATERP MENUHEIGHT (SETQ MINMENUHEIGHT (WINDOWPROP WINDOW (QUOTE
MINMENUHEIGHT))))
(IGREATERP MINMENUHEIGHT (fetch (POSITION YCOORD) of (MINIMUMWINDOWSIZE))))
(replace (MENULSTENTRY MENUSCROLLFLG) of MENULSTENTRY with MINMENUHEIGHT)
T)
((AND (NUMBERP SFLG)
(IGREATERP MENUHEIGHT SFLG))
T)))))))
(\MENUCLOSEFN
(LAMBDA (WINDOW) (* ejs: "28-AUG-82 13:13")
(for W in (WINDOWPROP WINDOW (QUOTE ITEMMENU)) do (CLOSEW (CDR W)))))
(\MENUEXPANDFN
(LAMBDA (WINDOW) (* Crystal: "19-APR-84 12:42")
(for W in (WINDOWPROP WINDOW (QUOTE ITEMMENU)) do (OPENW (CDR W)))))
(\MENUMOVEFN
(LAMBDA (WINDOW NEWPOS) (* ejs: "31-AUG-82 08:09")
(PROG ((RELPOS (create POSITION
XCOORD ←(IDIFFERENCE (fetch XCOORD of NEWPOS)
(fetch (REGION LEFT)
of (WINDOWPROP WINDOW (QUOTE REGION))))
YCOORD ←(IDIFFERENCE (fetch YCOORD of NEWPOS)
(fetch (REGION BOTTOM)
of (WINDOWPROP WINDOW (QUOTE REGION))))
)))
(for W in (COND
((ILESSP (fetch YCOORD of RELPOS)
0)
(REVERSE (WINDOWPROP WINDOW (QUOTE ITEMMENU))))
(T (WINDOWPROP WINDOW (QUOTE ITEMMENU))))
do (RELMOVEW (CDR W)
RELPOS)))))
(\MENUOPENFN
(LAMBDA (WINDOW) (* Peter: "10-FEB-83 09:13")
(for W in (WINDOWPROP WINDOW (QUOTE ITEMMENU)) do (OPENW (CDR W)))))
(\MENURESHAPEFN
(LAMBDA (WINDOW OLDBM OLDREGION) (* rgs: "19-Jan-85 17:06")
(* * After the window has been reshaped, delete all the old menus and recreate them)
(PROG (ITEMMENU MENULST PROPLST PROPVALS)
(SETQ ITEMMENU (WINDOWPROP WINDOW (QUOTE ITEMMENU)))
(* * Delete all the menus)
(DELETEALLMENUS WINDOW)
(WINDOWPROP WINDOW (QUOTE ITTEMMENU)
NIL)
(* * Get all the old MENULSTENTRYs)
(SETQ MENULST (for X in ITEMMENU collect (WINDOWPROP (CDR X)
(QUOTE MENULSTENTRY))))
(SETQ PROPLST (bind PROPS for X in ITEMMENU
collect (SETQ PROPS (CONS (QUOTE IMPORTANT-PROPERTIES)
(WINDOWPROP (CDR X)
(QUOTE IMPORTANT-PROPERTIES))))
(SETQ PROPVALS (NCONC1 PROPVALS (for PROP in PROPS
collect (WINDOWPROP
(CDR X)
PROP))))
PROPS))
(* * Now recreate them as if they never existed)
(for W in (MAKEMENUS WINDOW MENULST) as PROPS in PROPLST as VALS in PROPVALS
do (for PROP in PROPS as VAL in VALS do (WINDOWPROP (CDR W)
PROP VAL))))))
(\MENUSHRINKFN
(LAMBDA (WINDOW) (* Crystal: "19-APR-84 12:41")
(for W in (WINDOWPROP WINDOW (QUOTE ITEMMENU)) do (CLOSEW (CDR W)))))
(\MENUTOTOPFN
(LAMBDA (W) (* rgs: "25-OCT-83 13:18")
(* * Bring main window to top unless DON'TMENUTOTOP is set or called from scroll handler.)
(PROG (POS MW)
(SETQ POS (STKPOS (QUOTE SCROLL.HANDLER)))
(SETQ MW (WINDOWPROP W (QUOTE MAINWINDOW)))
(AND (OR (NULL POS)
(NEQ W (STKARG 1 POS)))
(OR (WINDOWPROP MW (QUOTE DON'TMENUTOTOP))
(TOTOPW MW))))))
(\TOTOPMENUS
(LAMBDA (WINDOW) (* scm: "18-Dec-84 12:30")
(* * Brings the menus associated with window WINDOW to the top. (Don't bother if we are called from the scroll
handler) Meant to be the TOTOPFN of WINDOW (This also cause responsiveness problems--rgs))
(PROG ((POS (STKPOS 'SCROLL.HANDLER)))
(COND
((OR (NULL POS)
(NEQ WINDOW (STKARG 1 POS)))
(for W in (WINDOWPROP WINDOW 'ITEMMENU) do (TOTOPW (CDR W)
T))))
(COND
(POS (RELSTK POS))))))
(\UPDATEMINMENU
(LAMBDA (MAINW) (* ejs: "31-AUG-82 09:13")
(WINDOWPROP MAINW (QUOTE MINMENUHEIGHT)
(IDIFFERENCE (fetch (REGION BOTTOM)
of (WINDOWPROP (CDAR (FLAST (WINDOWPROP MAINW
(QUOTE ITEMMENU)))
)
(QUOTE REGION)))
(fetch (REGION BOTTOM) of (WINDOWPROP MAINW (QUOTE REGION))))
)))
)
[DECLARE: EVAL@COMPILE
(RECORD MENULSTENTRY (MENUITEMS MENUTITLE SELECTEDFN MENUID MENUSCROLLFLG))
]
(RPAQQ \TTYHEIGHT 80)
(RPAQQ *HELPTITLEFLG* NIL)
(PUTPROPS MULTIMENU COPYRIGHT ("Schlumberger Technology Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1073 36459 (ADDMULTIMENU 1085 . 2618) (CHANGEMULTIMENU 2622 . 5143) (
DEFAULTACTIVEREGION 5147 . 5646) (DELETEALLMENUS 5650 . 5977) (DELMULTIMENU 5981 . 6124) (
GET-WINDOW-OF-MENU 6128 . 6538) (GRAYEDMENUSELECTEDFN 6542 . 7004) (GRAYMENU 7008 . 10204) (
HELPTITLEFN 10208 . 10535) (MAKEMENUS 10539 . 12217) (MAKETTYWINDOW 12221 . 13510) (MENUANDTITLEFN
13514 . 14230) (MENUEXISTS 14234 . 14429) (MULTIWINDOWREAD 14433 . 14951) (SETUP-MENU-FOR-HELP 14955
. 15541) (TOTOPMENUS 15545 . 15884) (UNGRAYMENU 15888 . 17216) (WINDOWDOFUN 17220 . 18002) (
\ADDMULTIMENU1 18006 . 20196) (\FIND-MENUCOLUMN-HEIGHT 20200 . 20561) (\FIND-MENUHEIGHT 20565 . 21560)
(\FIND-MENUWIDTH 21564 . 22900) (\FIND-WIDEST-MENU 22904 . 23412) (\FIND-WIDEST-WINDOW 23416 . 23787)
(\MAKEMENU 23791 . 28131) (\MAKEMENU1 28135 . 30341) (\MAKEMENUID 30345 . 30662) (\MAKEMENUWINDOW
30666 . 31329) (\MAKESCROLLINGMENUP 31333 . 32173) (\MENUCLOSEFN 32177 . 32365) (\MENUEXPANDFN 32369
. 32568) (\MENUMOVEFN 32572 . 33259) (\MENUOPENFN 33263 . 33451) (\MENURESHAPEFN 33455 . 34783) (
\MENUSHRINKFN 34787 . 34987) (\MENUTOTOPFN 34991 . 35466) (\TOTOPMENUS 35470 . 36054) (\UPDATEMINMENU
36058 . 36456)))))
STOP