(FILECREATED "20-Oct-86 10:58:58" {DSK}<LISPFILES>SOURCES>FREEMENU.;3 197532
changes to: (FNS FM.EDITITEM FM.SKIPNEXT \FM.WINDOWENTRYFN \FM.MENUHANDLER \FM.ENDEDIT
\FM.STARTEDIT \FM.DOSELECTION \FM.NUMBER-SELECTEDFN \FM.EDIT-ITEM
\FM.EDIT-PREPARETOEDIT)
previous date: " 2-Oct-86 15:35:18" {DSK}<LISPFILES>SOURCES>FREEMENU.;1)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT FREEMENUCOMS)
(RPAQQ FREEMENUCOMS
[(PROP FILETYPE FREEMENU)
(COMS (* USER INTERFACE FUNCTIONS)
(MACROS FM.GROUPPROP FM.MENUPROP FM.NWAYPROP)
(OPTIMIZERS FM.ITEMPROP)
(PROP ARGNAMES FM.ITEMPROP FM.GROUPPROP FM.MENUPROP FM.NWAYPROP)
(MACROS \FM.INSUREFM \FM.INSUREWINDOW)
(* RUN TIME TYPE CHECKERS)
(FNS FREEMENU (* ACCESSING FUNCTIONS)
FM.ITEMPROP FM.GETITEM FM.GETSTATE (* CHANGING FUNCTIONS)
FM.HIGHLIGHTITEM FM.CHANGELABEL FM.CHANGESTATE FM.RESETSTATE FM.RESETMENU
FM.RESETSHAPE FM.RESETGROUPS (* MISC FUNCTIONS)
FM.REDISPLAYITEM FM.REDISPLAYMENU FM.SHADE FM.EDITP FM.EDITITEM FM.ENDEDIT
FM.SKIPNEXT FM.WHICHITEM FM.TOPGROUPID))
(COMS (* CREATION OF FREEMENUS)
(DECLARE: DONTCOPY (MACROS \FM.ITEMPROP \FM.GROUPPROP \FM.NWAYPROP \FM.MAKEGROUP
\FM.TOPGROUPPROP \FM.DTOPGROUPID \FM.DGROUPPROP
\FM.DTOPGROUPPROP))
(FNS (* FORMATTING)
\FM.FORMAT \FM.FORMATBYROW \FM.FORMATBYCOLUMN \FM.FORMATBYGRID \FM.FORMATEXPLICIT
\FM.LAYOUTROW \FM.LAYOUTCOLUMN \FM.LAYOUTGRID \FM.JUSTIFYITEMS \FM.JUSTIFYGROUPS
\FM.PUSHGROUP (* ERROR CHECKING)
\FM.CHECKDESCRIPTION \FM.CHECKPROPS (* CREATING)
\FM.CREATEITEM \FM.GETREGIONS \FM.GETBITMAPS \FM.MAKEBITMAP \FM.READUSERDATA
\FM.MAKELINKS \FM.COLLECTNWAYS \FM.SETATTACHPOINT \FM.CREATEW \FM.STARTEDIT)
(DECLARE: DONTCOPY (MACROS \FM.SETUPPROPS \FM.SETFORMATPROPS \FM.CHECKFORBOX
\FM.UPDATEFORBOX \FM.UPDATEGRID \FM.ITEMWIDTH \FM.ITEMHEIGHT
\FM.ATTACHPOINT))
(DECLARE: DONTCOPY
(CONSTANTS (\FM.FORMAT-TYPES (QUOTE (ROW COLUMN TABLE EXPLICIT)))
(\FM.DEFAULTFORMAT (QUOTE ROW))
(* format keywords)
(\FM.GROUPSPEC (QUOTE GROUP))
(\FM.PROPSPEC (QUOTE PROPS))
(* key words in description)
(\FM.HJUSTIFY-SPECS (QUOTE (LEFT CENTER RIGHT)))
(\FM.VJUSTIFY-SPECS (QUOTE (TOP MIDDLE BOTTOM)))
(* item justification keywords)
(\FM.BOXSPACE 1)
(* default number of bits between label and box)
(\FM.ROWSPACE 2)
(\FM.COLUMNSPACE 10)
(* default number of bits between formatted rows and columns)
(\FM.ITEM-TYPES (QUOTE (MOMENTARY TOGGLE 3STATE NWAY STATE NUMBER EDIT
EDITSTART DISPLAY)))
(* known freemenu item types)
(\FM.DESCRIPTION-PROPS (QUOTE (TYPE LABEL LEFT BOTTOM ID GROUPID STATE
INITSTATE FONT BITMAP REGION
MAXREGION MESSAGE USERDATA LINKS
SYSDOWNFN SYSMOVEDFN SYSSELECTEDFN
DOWNFN HELDFN MOVEDFN SELECTEDFN)))
(* properties in item description that don't become USERDATA)))
(RECORDS FREEMENUITEM))
(COMS (* FREEMENU WINDOWS)
(DECLARE: DONTCOPY (MACROS \FM.TRANSPOSE))
(FNS \FM.REDISPLAYMENU \FM.RESHAPEFN \FM.UNSCROLLWINDOW \FM.RESETCLIPPINGREGION
\FM.FILLWINDOW \FM.INITCORNERSFN \FM.TRANSPOSEHORZ \FM.TRANSPOSEVERT
\FM.UPDATEGROUPEXTENT \FM.WINDOWEXTENT \FM.UPDATEWINDOWEXTENT))
(COMS (* MOUSE FUNCTIONS)
(DECLARE: DONTCOPY (MACROS \FM.ONITEM \FM.CHECKREGION))
(FNS \FM.WINDOWENTRYFN \FM.BUTTONEVENTFN \FM.RIGHTBUTTONFN \FM.DOSELECTION
\FM.MENUHANDLER))
(COMS (* ITEM SUPPORT FUNCTIONS)
(DECLARE: DONTCOPY (MACROS \FM.DISPLAYBITMAP \FM.COERCEITEMPTR))
(FNS \FM.GETITEMPROP \FM.PUTITEMPROP \FM.CGETITEMPROP \FM.CPUTITEMPROP \FM.DISPLAYITEM
\FM.HIGHLIGHTITEM \FM.CHANGELABEL \FM.CHANGESTATE \FM.ENDEDIT \FM.INSUREVISIBLE
\FM.CLEARITEM))
(COMS (* MOMENTARY ITEM FUNCTIONS)
(FNS \FM.MOMENTARY-SETUP \FM.MOMENTARY-SELECTEDFN))
(COMS (* TOGGLE ITEM FUNCTIONS)
(FNS \FM.TOGGLE-SETUP \FM.TOGGLE-DOWNFN \FM.TOGGLE-SELECTEDFN \FM.TOGGLE-CHANGESTATE))
(COMS (* 3STATE ITEM FUNCTIONS)
(FNS \FM.3STATE-SETUP \FM.3STATE-SETUPOFFBITMAP \FM.3STATE-DOWNFN \FM.3STATE-SELECTEDFN
\FM.3STATE-CHANGESTATE))
(COMS (* STATE ITEM FUNCTIONS)
(FNS \FM.STATE-SETUP \FM.STATE-SELECTEDFN \FM.STATE-CHANGESTATE))
(COMS (* NWAY ITEM FUNCTIONS)
(FNS \FM.NWAY-SETUP \FM.NWAY-MESSAGE \FM.NWAY-DOWNFN \FM.NWAY-MOVEDFN
\FM.NWAY-SELECTEDFN \FM.NWAY-CHANGESTATE))
(COMS (* NUMBER ITEM FUNCTIONS)
(FNS \FM.NUMBER-SETUP \FM.NUMBER-MESSAGE \FM.NUMBER-SELECTEDFN \FM.NUMBER-CHANGESTATE))
(COMS (* TITLE ITEM FUNCTIONS)
(FNS \FM.DISPLAY-SETUP))
(COMS (* EDITSTART ITEM FUNCTIONS)
(FNS \FM.EDITSTART-SETUP \FM.EDITSTART-MESSAGE \FM.EDITSTART-SELECTEDFN))
(COMS (* EDIT ITEMS)
(DECLARE: DONTCOPY
(CONSTANTS (\FM.EDIT-TIMEOUT 100000)
(\FM.EDIT-RIGHTENDSPACE 5)
(\FM.EDIT-BLOCKSIZE 50)
(\FM.EDIT-CONTROLCHARS (QUOTE (9 10 12 13)))
(\FM.EDIT-CONTROLCHARSECHO 255)
(\FM.EDIT-WORDDELIMCHARS (QUOTE (32 123 125 91 93 60 62 47 92 46 44 59 42
40 41 45)))
(* space { } %[ %] < > / \ %. , ; * %( %) -)))
(VARS (\FM.EDIT-TTBL))
(GLOBALVARS \FM.EDIT-TTBL)
(MACROS \FM.EDIT-MAXWIDTH \FM.EDIT-SCROLLAMOUNT)
(FNS \FM.EDIT-SETUP \FM.EDIT-MESSAGE \FM.EDIT-SETUPTTBL \FM.EDIT-ITEM
\FM.EDIT-PREPARETOEDIT \FM.EDIT-FINDNEXT \FM.EDIT-FINDFIRST \FM.EDIT-BACKUP
\FM.EDIT-WORDDELETE \FM.EDIT-INSERT \FM.EDIT-DELETE \FM.EDIT-GETPOINTERINFO
\FM.EDIT-MOVECARET \FM.EDIT-STRDELETE \FM.EDIT-STRINSERT
\FM.EDIT-UPDATEAFTERDELETE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA FM.ITEMPROP])
(PUTPROPS FREEMENU FILETYPE COMPILE-FILE)
(* USER INTERFACE FUNCTIONS)
(DECLARE: EVAL@COMPILE
[PUTPROPS FM.GROUPPROP MACRO
(ARGS (* access macro to group props of window. args (WINDOW GROUP PROP {VALUE}))
(COND ((NULL (CDDR ARGS))
(ERROR "Too few arguments to FM.GROUPPROP:" (CONS (QUOTE FM.GROUPPROP)
ARGS)))
[(CDDDR ARGS)
(BQUOTE (LET [(GROUP (CDR (FASSOC , (CADR ARGS)
(WINDOWPROP (\FM.INSUREWINDOW , (CAR ARGS))
(QUOTE FM.GROUPS]
(PROG1 (LISTGET GROUP , (CADDR ARGS))
(LISTPUT GROUP , (CADDR ARGS)
,
(CADDDR ARGS]
(T (BQUOTE (LISTGET [CDR (FASSOC , (CADR ARGS)
(WINDOWPROP (\FM.INSUREWINDOW , (CAR ARGS))
(QUOTE FM.GROUPS]
,
(CADDR ARGS]
[PUTPROPS FM.MENUPROP MACRO (ARGS (* access macro to TOP group props of window. args (WINDOW PROP
{VALUE}))
(COND ((NULL (CDR ARGS))
(ERROR "Too few arguments to FM.MENUPROP:"
(CONS (QUOTE FM.MENUPROP)
ARGS)))
[(CDDR ARGS)
(BQUOTE (LET [(GROUP (CDAR (WINDOWPROP (\FM.INSUREWINDOW
,
(CAR ARGS))
(QUOTE FM.GROUPS]
(PROG1 (LISTGET GROUP , (CADR ARGS))
(LISTPUT GROUP , (CADR ARGS)
,
(CADDR ARGS]
(T (BQUOTE (LISTGET (CDAR (WINDOWPROP (\FM.INSUREWINDOW
,
(CAR ARGS))
(QUOTE FM.GROUPS)))
,
(CADR ARGS]
[PUTPROPS FM.NWAYPROP MACRO
(ARGS (* access macro to nway props. args (WINDOW COLLECTION PROP {VALUE}))
(COND ((NULL (CDDR ARGS))
(ERROR "Too few arguments to FM.NWAYPROP:" (CONS (QUOTE FM.NWAYPROP)
ARGS)))
[(CDDDR ARGS)
(BQUOTE (LET [(NWAY (CDR (ASSOC , (CADR ARGS)
(WINDOWPROP (\FM.INSUREWINDOW , (CAR ARGS))
(QUOTE FM.NWAYS]
(PROG1 (LISTGET NWAY , (CADDR ARGS))
(LISTPUT NWAY , (CADDR ARGS)
,
(CADDDR ARGS]
(T (BQUOTE (LISTGET [CDR (ASSOC , (CADR ARGS)
(WINDOWPROP (\FM.INSUREWINDOW , (CAR ARGS))
(QUOTE FM.NWAYS]
,
(CADDR ARGS]
)
(DEFOPTIMIZER FM.ITEMPROP (&REST ARGS) (* access macro to FREEMENUITEM
datatype. args (ITEM PROP {VALUE}))
(COND
((NULL (CDR ARGS))
(ERROR "Too few arguments to FM.ITEMPROP:" (CONS (QUOTE FM.ITEMPROP)
ARGS)))
((NEQ (CAADR ARGS)
(QUOTE QUOTE))
(QUOTE IGNOREMACRO))
((CDDR ARGS)
(\FM.CPUTITEMPROP (BQUOTE (\FM.INSUREFM (\, (CAR ARGS))))
(CADR ARGS)
(CADDR ARGS)))
(T (\FM.CGETITEMPROP (BQUOTE (\FM.INSUREFM (\, (CAR ARGS))))
(CADR ARGS)))))
(PUTPROPS FM.ITEMPROP ARGNAMES (ITEM PROP {VALUE}))
(PUTPROPS FM.GROUPPROP ARGNAMES (WINDOW GROUP PROP {VALUE}))
(PUTPROPS FM.MENUPROP ARGNAMES (WINDOW PROP {VALUE}))
(PUTPROPS FM.NWAYPROP ARGNAMES (WINDOW COLLECTION PROP {VALUE}))
(DECLARE: EVAL@COMPILE
[PUTPROPS \FM.INSUREFM MACRO
(ARGS (* args (ITEM WINDOW)
%. Insure ITEM is freemenuitem. If WINDOW is supplied, then try to coerce item if
necessary.)
(if (CDR ARGS)
then
(* WINDOW ARGUMENT SUPPLIED)
[BQUOTE (COND ((type? FREEMENUITEM , (CAR ARGS))
,
(CAR ARGS))
(T (IF [AND (LISTP , (CAR ARGS))
(EQ \FM.GROUPSPEC (CAR , (CAR ARGS]
THEN
(ERROR "Can't describe a local item from top level:" ,
(CAR ARGS))
ELSE
(\FM.COERCEITEMPTR , (CAR ARGS)
,
(CADR ARGS]
else
(* NO WINDOW SUPPLIED: JUST TYPE CHECK ITEM)
(BQUOTE (COND ((type? FREEMENUITEM , (CAR ARGS))
,
(CAR ARGS))
(T (ERROR "Arg must be FreeMenuItem" , (CAR ARGS]
[PUTPROPS \FM.INSUREWINDOW MACRO ((WINDOW)
(COND ((AND (WINDOWP WINDOW)
(WINDOWPROP WINDOW (QUOTE FM.ITEMS)))
WINDOW)
(T (ERROR "Arg must be FreeMenu Window" WINDOW]
)
(* RUN TIME TYPE CHECKERS)
(DEFINEQ
(FREEMENU
[LAMBDA (DESCRIPTION TITLE BACKGROUND BORDER) (* jow "17-Apr-86 19:32")
(* Create a freemenu from a description. \FM.FORMAT is the recursive formatter. The defaults are passed to it here.
It returns a list of groups, the first of which is the entire menu. Each group is a property list, the first item
being the ID of the group, with group properties following.)
(SETQ DESCRIPTION (COPY DESCRIPTION)) (* leave users description untouched)
(LET ((WINDOW (\FM.CREATEW (\FM.FORMAT DESCRIPTION \FM.DEFAULTFORMAT DEFAULTFONT 0 0
\FM.ROWSPACE \FM.COLUMNSPACE)
TITLE BACKGROUND BORDER)))
(* \FM.SETATTACHPOINT (LISTGET (CDAR WINDOW) (QUOTE ITEMS)) (fetch (REGION WIDTH) of (LISTGET
(CDAR WINDOW) (QUOTE REGION))) (fetch (REGION HEIGHT) of (LISTGET (CDAR WINDOW) (QUOTE REGION))))
(\FM.MAKELINKS WINDOW)
(\FM.COLLECTNWAYS WINDOW)
(FM.RESETMENU WINDOW)
WINDOW])
(FM.ITEMPROP
[LAMBDA ARGPTR (* jow
" 4-Apr-86 14:57")
(COND
[(ILESSP ARGPTR 2)
(ERROR "Too few arguments to FM.ITEMPROP" (LIST (QUOTE FM.ITEMPROP)
(ARG ARGPTR 1]
((NOT (type? FREEMENUITEM (ARG ARGPTR 1)))
(ERROR "FM.ITEMPROP arg must be FreeMenuItem:" (ARG ARGPTR 1)))
((EQ ARGPTR 2)
(\FM.GETITEMPROP (ARG ARGPTR 1)
(ARG ARGPTR 2)))
(T (\FM.PUTITEMPROP (ARG ARGPTR 1)
(ARG ARGPTR 2)
(ARG ARGPTR 3])
(FM.GETITEM
[LAMBDA (ID GROUP WINDOW) (* jow "19-Apr-86 22:45")
(* find an item in WINDOW based on GROUP and ID which is an item id or label, If GROUP is NIL, search whole menu.)
(\FM.INSUREWINDOW WINDOW)
(LET [(ITEMS (if GROUP
then (\FM.GROUPPROP WINDOW GROUP (QUOTE ITEMS))
else (WINDOWPROP WINDOW (QUOTE FM.ITEMS]
(for ITEM in ITEMS thereis (OR (EQ ID (\FM.ITEMPROP ITEM (QUOTE ID)))
(EQUAL ID (\FM.ITEMPROP ITEM (QUOTE LABEL])
(FM.GETSTATE
[LAMBDA (WINDOW) (* jow "18-Jun-86 16:29")
(* programmer interface: goes through all items and nway collections, returns a
prop list of id / current state for any state items in the menu.
The current state is the value of the STATE field, or for edit items, the
LABEL. Don't include in state list if STATE is NIL.)
(\FM.INSUREWINDOW WINDOW)
(LET ((STATELIST (LIST NIL)))
[for NWAY in (WINDOWPROP WINDOW (QUOTE FM.NWAYS))
do (if (LISTGET (CDR NWAY)
(QUOTE STATE))
then (LCONC STATELIST (LIST (CAR NWAY)
(LISTGET (CDR NWAY)
(QUOTE STATE]
(for ITEM in (WINDOWPROP WINDOW (QUOTE FM.ITEMS))
do (SELECTQ (\FM.ITEMPROP ITEM (QUOTE TYPE))
((TOGGLE 3STATE STATE NWAY NUMBER)
[if (\FM.ITEMPROP ITEM (QUOTE STATE))
then (LCONC STATELIST (LIST (OR (\FM.ITEMPROP ITEM (QUOTE ID))
(\FM.ITEMPROP ITEM (QUOTE LABEL)))
(\FM.ITEMPROP ITEM (QUOTE STATE])
(EDIT [LCONC STATELIST (LIST (\FM.ITEMPROP ITEM (QUOTE ID))
(\FM.ITEMPROP ITEM (QUOTE LABEL])
NIL))
(CAR STATELIST])
(FM.HIGHLIGHTITEM
[LAMBDA (ITEM WINDOW) (* jow "26-Jun-86 15:05")
(* this is the user interface function
for highlighting. Type check and
coerce item, then call the real
function)
(\FM.INSUREWINDOW WINDOW)
(SETQ ITEM (\FM.INSUREFM ITEM WINDOW))
(\FM.HIGHLIGHTITEM ITEM WINDOW])
(FM.CHANGELABEL
[LAMBDA (ITEM NEWLABEL WINDOW UPDATEFLG) (* jow "26-Jun-86 14:50")
(* user interface to change the label
of an item, and redisplay as
necessary.)
(\FM.INSUREWINDOW WINDOW)
(SETQ ITEM (\FM.INSUREFM ITEM WINDOW))
(LET [(OLDREGION (\FM.ITEMPROP ITEM (QUOTE REGION]
(\FM.CHANGELABEL ITEM NEWLABEL) (* fill in background)
(* now put item back into its current state.
This only applies to particular type items
(nway, toggle, 3state)%, so do the changestate directly, rather than call
changestate)
(SELECTQ (\FM.ITEMPROP ITEM (QUOTE TYPE))
((NWAY TOGGLE)
(* remember each nway item is handled
as an individual toggle)
(\FM.TOGGLE-CHANGESTATE ITEM (\FM.ITEMPROP ITEM (QUOTE STATE))))
(3STATE (\FM.3STATE-CHANGESTATE ITEM (\FM.ITEMPROP ITEM (QUOTE STATE))))
NIL)
(if (OR UPDATEFLG (\FM.ITEMPROP ITEM (QUOTE CHANGELABELUPDATE)))
then (* update groups)
(\FM.UPDATEGROUPEXTENT (WINDOWPROP WINDOW (QUOTE FM.GROUPS)))
(WINDOWPROP WINDOW (QUOTE EXTENT)
(\FM.WINDOWEXTENT WINDOW))
(\FM.REDISPLAYMENU WINDOW)
else (* just redisplay item)
(\FM.CLEARITEM ITEM WINDOW OLDREGION) (* fill in background)
(\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE BITMAP))
WINDOW])
(FM.CHANGESTATE
[LAMBDA (X NEWSTATE WINDOW) (* jow "26-Jun-86 14:51")
(* user interface to change the state
of any (state) item or nway
collection. Redisplay the item if the
window is open)
(\FM.INSUREWINDOW WINDOW)
(if (ASSOC X (WINDOWPROP WINDOW (QUOTE FM.NWAYS)))
then (* X specifies an NWAY.
Changestate and redisplay.)
(LET [(OLDSTATE (\FM.NWAYPROP WINDOW X (QUOTE STATE]
(if NEWSTATE
then (* NIL would mean deselect)
(SETQ NEWSTATE (\FM.INSUREFM NEWSTATE WINDOW)))
(\FM.CHANGESTATE X NEWSTATE WINDOW)
(if OLDSTATE
then (\FM.DISPLAYBITMAP OLDSTATE (\FM.ITEMPROP OLDSTATE (QUOTE BITMAP))
WINDOW))
(if NEWSTATE
then (\FM.DISPLAYBITMAP NEWSTATE (\FM.ITEMPROP NEWSTATE (QUOTE BITMAP))
WINDOW)))
else (* treat X as an item)
(SETQ X (\FM.INSUREFM X WINDOW))
(\FM.CHANGESTATE X NEWSTATE WINDOW)
(\FM.DISPLAYBITMAP X (\FM.ITEMPROP X (QUOTE BITMAP))
WINDOW])
(FM.RESETSTATE
[LAMBDA (X WINDOW) (* jow "24-Apr-86 21:27")
(* Reset X, an item or nway collection, to its initial
state and redisplay)
(\FM.INSUREWINDOW WINDOW)
(LET [(INITSTATE (if (ASSOC X (WINDOWPROP WINDOW (QUOTE FM.NWAYS)))
then (\FM.NWAYPROP WINDOW X (QUOTE INITSTATE))
else (\FM.ITEMPROP (\FM.INSUREFM X WINDOW)
(QUOTE INITSTATE]
(FM.CHANGESTATE X INITSTATE WINDOW])
(FM.RESETMENU
[LAMBDA (WINDOW) (* jow "26-Jun-86 14:43")
(* reset each item to its INITSTATE)
(\FM.INSUREWINDOW WINDOW)
(\FM.ENDEDIT WINDOW T)
(for ITEM in (WINDOWPROP WINDOW (QUOTE FM.ITEMS)) do (FM.RESETSTATE ITEM WINDOW))
(for NWAY in (WINDOWPROP WINDOW (QUOTE FM.NWAYS)) do (FM.RESETSTATE (CAR NWAY)
WINDOW))
(\FM.REDISPLAYMENU WINDOW])
(FM.RESETSHAPE
[LAMBDA (WINDOW ALWAYSFLG) (* jow "19-Apr-86 22:50")
(* programmer way of reshaping a freemenu window to its minimal extent. If window is too small, it will be
reshaped, without moving the lower left corner. If window is too big, it will only be reshaped if ALWAYSFLG is T.)
(\FM.INSUREWINDOW WINDOW)
(if (OR (ILESSP (WINDOWPROP WINDOW (QUOTE WIDTH))
(WINDOWPROP WINDOW (QUOTE FM.MINWIDTH)))
(ILESSP (WINDOWPROP WINDOW (QUOTE HEIGHT))
(WINDOWPROP WINDOW (QUOTE FM.MINHEIGHT)))
ALWAYSFLG)
then (SHAPEW WINDOW (CREATEREGION (fetch (REGION LEFT) of (WINDOWPROP
WINDOW
(QUOTE REGION)))
(fetch (REGION BOTTOM) of (WINDOWPROP
WINDOW
(QUOTE REGION)))
(WIDTHIFWINDOW (WINDOWPROP WINDOW (QUOTE
FM.MINWIDTH))
(WINDOWPROP WINDOW (QUOTE BORDER)
))
(HEIGHTIFWINDOW (WINDOWPROP WINDOW (QUOTE
FM.MINHEIGHT))
(WINDOWPROP WINDOW (QUOTE
TITLE))
(WINDOWPROP WINDOW (QUOTE
BORDER])
(FM.RESETGROUPS
[LAMBDA (WINDOW GROUPLIST REDISPLAYFLG) (* jow "26-Jun-86 14:45")
(* user interface to recalculating
group extents.)
(\FM.INSUREWINDOW WINDOW)
(\FM.UPDATEGROUPEXTENT (WINDOWPROP WINDOW (QUOTE FM.GROUPS))
GROUPLIST)
(AND REDISPLAYFLG (\FM.REDISPLAYMENU WINDOW])
(FM.REDISPLAYITEM
[LAMBDA (ITEM WINDOW) (* jow "26-Jun-86 14:51")
(* user interface to displaying an
item.)
(\FM.INSUREWINDOW WINDOW)
(SETQ ITEM (\FM.INSUREFM ITEM WINDOW))
(\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE BITMAP))
WINDOW])
(FM.REDISPLAYMENU
[LAMBDA (WINDOW) (* jow "26-Jun-86 14:45")
(* use \FM.REDISPLAYMENU, which has
hooks for updating a particular
region.)
(\FM.INSUREWINDOW WINDOW)
(\FM.REDISPLAYMENU WINDOW])
(FM.SHADE
[LAMBDA (X SHADE WINDOW) (* jow "26-Jun-86 14:59")
(* X is a group id or an item.
Paint shade on top of group or item.)
(\FM.INSUREWINDOW WINDOW)
(LET [(REGION (OR (\FM.GROUPPROP WINDOW X (QUOTE REGION))
(\FM.ITEMPROP (\FM.INSUREFM X WINDOW)
(QUOTE REGION]
(if (AND REGION (OPENWP WINDOW))
then (BLTSHADE (TEXTUREP SHADE)
WINDOW NIL NIL NIL NIL (QUOTE PAINT)
REGION])
(FM.EDITP
[LAMBDA (WINDOW) (* jow "19-Apr-86 22:52")
(WINDOWPROP (\FM.INSUREWINDOW WINDOW)
(QUOTE FM.EDITITEM])
(FM.EDITITEM
[LAMBDA (ITEM WINDOW CLEARFLG) (* jow "20-Oct-86 10:48")
(* ;;; "start editing at beginning of item.")
(\FM.INSUREWINDOW WINDOW)
(SETQ ITEM (\FM.INSUREFM ITEM WINDOW))
(\FM.ENDEDIT WINDOW T)
[if CLEARFLG
then (* ; "hack to get EDIT-ITEM to clear item first.")
(SETQ CLEARFLG (QUOTE (RIGHT]
(if (OPENWP WINDOW)
then (ADD.PROCESS [BQUOTE (\FM.STARTEDIT (QUOTE (\, ITEM))
(QUOTE (\, WINDOW))
(QUOTE (\, CLEARFLG]
(QUOTE NAME)
(QUOTE FREEMENU)
(QUOTE FREEMENU.PROCESS)
T])
(FM.ENDEDIT
[LAMBDA (WINDOW WAITFLG) (* jow "24-Apr-86 21:23")
(\FM.INSUREWINDOW WINDOW)
(\FM.ENDEDIT WINDOW WAITFLG])
(FM.SKIPNEXT
[LAMBDA (WINDOW CLEARFLG) (* jow "20-Oct-86 10:57")
(if (FM.EDITP WINDOW)
then (* ;; "eval the EDITITEM change in the FREEMENU process, which must be the tty process if editing. This works even if called from the FREEMENU process, eg by LIMITCHARS")
(LET ((FM.PROCESS (TTY.PROCESS)))
(if (PROCESSPROP FM.PROCESS (QUOTE FREEMENU.PROCESS))
then [PROCESS.EVAL FM.PROCESS
(BQUOTE (PROGN (SETQ EDITITEM (\FM.EDIT-FINDNEXT))
(if EDITITEM
then (if (QUOTE (\, CLEARFLG))
then (FM.CHANGELABEL EDITITEM "" WINDOW
))
(\FM.EDIT-PREPARETOEDIT EDITITEM T)
(\FM.INSUREVISIBLE EDITITEM WINDOW)
else (\FM.ENDEDIT WINDOW]
else (ERROR "Can't find freemenu process to do skip-next" FM.PROCESS)))
else (* ;
"not editing, so start with first edit item in menu")
(LET ((EDITITEM (\FM.EDIT-FINDFIRST WINDOW)))
(if EDITITEM
then (FM.EDITITEM EDITITEM WINDOW CLEARFLG])
(FM.WHICHITEM
[LAMBDA (WINDOW POSorX Y) (* jow "19-Apr-86 22:54")
(* user interface to CHECKREGION. Return the item in WINDOW at (POSorX, Y) If WINDOW is NIL, use the window the
cursor is in, and the cursor position in that window)
(if (OR (WINDOWP WINDOW)
(SETQ WINDOW (WHICHW)))
then (COND
((POSITIONP POSorX)
(\FM.CHECKREGION WINDOW (fetch (POSITION XCOORD) of POSorX)
(fetch (POSITION YCOORD) of POSorX)))
(POSorX (\FM.CHECKREGION WINDOW POSorX Y))
(T (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW])
(FM.TOPGROUPID
[LAMBDA (WINDOW) (* jow "19-Apr-86 22:54")
(* grab id of top group)
(\FM.DTOPGROUPID (WINDOWPROP (\FM.INSUREWINDOW WINDOW)
(QUOTE FM.GROUPS])
)
(* CREATION OF FREEMENUS)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS \FM.ITEMPROP MACRO (ARGS (* access macro to FREEMENUITEM datatype. args (ITEM PROP {VALUE})
Doesnt force an INSUREFM on the item, so intended for internal
use only. PROP must be a quoted literal.)
(COND ((NULL (CDR ARGS))
(ERROR "Too few arguments to \FM.ITEMPROP:"
(CONS (QUOTE FM.ITEMPROP)
ARGS)))
((NOT (EQ (CAADR ARGS)
(QUOTE QUOTE)))
(ERROR "CANT USE \FM.ITEMPROP UNLESS PROP IS QUOTED"))
((CDDR ARGS)
(\FM.CPUTITEMPROP (CAR ARGS)
(CADR ARGS)
(CADDR ARGS)))
(T (\FM.CGETITEMPROP (CAR ARGS)
(CADR ARGS]
[PUTPROPS \FM.GROUPPROP MACRO (ARGS (* internal access macro to group props of window. doesn't check
for illegal args. args (WINDOW GROUP PROP {VALUE}))
(COND ((NULL (CDDR ARGS))
(ERROR "Too few arguments to FM.GROUPPROP:"
(CONS (QUOTE FM.GROUPPROP)
ARGS)))
[(CDDDR ARGS)
(BQUOTE (LET [(GROUP (CDR (FASSOC , (CADR ARGS)
(WINDOWPROP ,
(CAR ARGS)
(QUOTE FM.GROUPS]
(PROG1 (LISTGET GROUP , (CADDR ARGS))
(LISTPUT GROUP , (CADDR ARGS)
,
(CADDDR ARGS]
(T (BQUOTE (LISTGET [CDR (FASSOC , (CADR ARGS)
(WINDOWPROP , (CAR ARGS)
(QUOTE FM.GROUPS]
,
(CADDR ARGS]
[PUTPROPS \FM.NWAYPROP MACRO (ARGS (* internal access macro to nway props. doesn't error check args.
args (WINDOW COLLECTION PROP {VALUE}))
(COND ((NULL (CDDR ARGS))
(ERROR "Too few arguments to FM.NWAYPROP:"
(CONS (QUOTE FM.NWAYPROP)
ARGS)))
[(CDDDR ARGS)
(BQUOTE (LET [(NWAY (CDR (ASSOC , (CADR ARGS)
(WINDOWPROP , (CAR ARGS)
(QUOTE FM.NWAYS]
(PROG1 (LISTGET NWAY , (CADDR ARGS))
(LISTPUT NWAY , (CADDR ARGS)
,
(CADDDR ARGS]
(T (BQUOTE (LISTGET [CDR (ASSOC , (CADR ARGS)
(WINDOWPROP , (CAR ARGS)
(QUOTE FM.NWAYS]
,
(CADDR ARGS]
[PUTPROPS \FM.MAKEGROUP MACRO (ARGS (* access macro that will build group from (ID PROPS))
(BQUOTE (CONS , (CAR ARGS)
,
(CADR ARGS]
[PUTPROPS \FM.TOPGROUPPROP MACRO (ARGS (* access macro to top group of window. args (WINDOW PROP
{VALUE}))
(COND
((NULL (CDR ARGS))
(ERROR "BAD ARGS TO \FM.TOPGROUPPROP:" (CONS (QUOTE
\FM.TOPGROUPPROP
)
ARGS)))
[(CDDR ARGS)
(BQUOTE (LET [(GROUP (CDAR (WINDOWPROP (\FM.INSUREWINDOW
,
(CAR ARGS))
(QUOTE FM.GROUPS]
(PROG1 (LISTGET GROUP , (CADR ARGS))
(LISTPUT GROUP , (CADR ARGS)
,
(CADDR ARGS]
(T (BQUOTE (LISTGET (CDAR (WINDOWPROP (\FM.INSUREWINDOW
,
(CAR ARGS))
(QUOTE FM.GROUPS)))
,
(CADR ARGS]
(PUTPROPS \FM.DTOPGROUPID MACRO ((GROUP)
(CAAR GROUP)))
[PUTPROPS \FM.DGROUPPROP MACRO (ARGS (* access macro to groups props directly. args
(GROUPS GROUPID PROP {VALUE}))
(COND ((NULL (CDDR ARGS))
(ERROR "BAD ARGS TO \FM.DGROUPPROP" (CONS (QUOTE
\FM.DGROUPPROP
)
ARGS)))
[(CDDDR ARGS)
(BQUOTE (LET [(GROUP (CDR (FASSOC , (CADR ARGS)
,
(CAR ARGS]
(PROG1 (LISTGET GROUP , (CADDR ARGS))
(LISTPUT GROUP , (CADDR ARGS)
,
(CADDDR ARGS]
(T (BQUOTE (LISTGET (CDR (FASSOC , (CADR ARGS)
,
(CAR ARGS)))
,
(CADDR ARGS]
[PUTPROPS \FM.DTOPGROUPPROP MACRO (ARGS (* access macro to direct top group. args (GROUPS PROP
{VALUE}))
(COND ((NULL (CDR ARGS))
(ERROR "BAD ARGS TO \FM.DTOPGROUPPROP:"
(CONS (QUOTE \FM.DTOPGROUPPROP)
ARGS)))
[(CDDR ARGS)
(BQUOTE (PROG1 (LISTGET (CDAR , (CAR ARGS))
,
(CADR ARGS))
(LISTPUT (CDAR , (CAR ARGS))
,
(CADR ARGS)
,
(CADDR ARGS]
(T (BQUOTE (LISTGET (CDAR , (CAR ARGS))
,
(CADR ARGS]
)
)
(DEFINEQ
(\FM.FORMAT
[LAMBDA (DESCRIPTION FORMAT FONT LEFT BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS)
(* jow "24-Apr-86 23:14")
(* recursive formatter. MOTHER is this groups mother group id, and ID is this groups id, and PROPS is this groups
property list. Currently ID and PROPS are unspecified arguments, and are only set by SETUPPROPS
(but they are available as format arguments for later versions???) Format description based on its requested format
in PROPS. If the format type is not known, treat it as a user specified funtion to do the desired formatting, and
apply it to the description. (NOT CURRENTLY) LEFT and BOTTOM specify the corner of the groups coordinate system,
and the LEFT and BOTTOM menuprops in the group specify offsets in that system. If the group is boxed, then offset
the group before formatting, and readjust the extent after formatting to account for the box.
Return a group structure for this group.)
(\FM.SETUPPROPS DESCRIPTION (QUOTE (FORMAT FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID)))
(LET (GROUPS OLDCORNER BOXOFFSET EXTENT)
(\FM.CHECKFORBOX)
(SETQ GROUPS (SELECTQ FORMAT
(ROW (\FM.FORMATBYROW DESCRIPTION FONT LEFT BOTTOM ROWSPACE
COLUMNSPACE ID PROPS))
(COLUMN (\FM.FORMATBYCOLUMN DESCRIPTION FONT LEFT BOTTOM
ROWSPACE COLUMNSPACE ID PROPS))
(TABLE (\FM.FORMATBYGRID DESCRIPTION FONT LEFT BOTTOM ROWSPACE
COLUMNSPACE ID PROPS))
(EXPLICIT (\FM.FORMATEXPLICIT DESCRIPTION FONT LEFT BOTTOM
ROWSPACE COLUMNSPACE ID PROPS))
NIL)) (* APPLY* (LISTGET PROPS (QUOTE FORMAT)) DESCRIPTION
FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID)
(\FM.JUSTIFYITEMS GROUPS)
(\FM.JUSTIFYGROUPS GROUPS)
(SETQ EXTENT (\FM.DTOPGROUPPROP GROUPS (QUOTE REGION)))
(* UPDATEFORBOX macro uses EXTENT)
(\FM.UPDATEFORBOX)
GROUPS])
(\FM.FORMATBYROW
[LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)
(* jow "17-Apr-86 18:09")
(* Called when row formatting is specified. ID and PROPS are passed from \FM.FORMAT. ID is id of this group, and
thus passed to MOTHER of each row group. PROPS is the group proplist to build the group from.
DESCRIPTION is a list of rows, each row a list of item descriptions and groups. Reverse the rows, then build from
bottom up. Use \FM.LAYOUTROW to lay out the items in a row.)
(LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0))
(ITEMLIST (LIST NIL))
(GROUPLIST (LIST NIL))
(ROWIDS (LIST NIL))
(ROWBOTTOM BOTTOM)
GROUPS)
(for ROW in (DREVERSE DESCRIPTION)
do (SETQ GROUPS (\FM.LAYOUTROW ROW FONT LEFT ROWBOTTOM ROWSPACE COLUMNSPACE ID))
(TCONC ROWIDS (\FM.DTOPGROUPID GROUPS))
[LCONC ITEMLIST (REVERSE (\FM.DTOPGROUPPROP GROUPS (QUOTE ITEMS]
(EXTENDREGION EXTENT (\FM.DTOPGROUPPROP GROUPS (QUOTE REGION)))
(LCONC GROUPLIST GROUPS)
(add ROWBOTTOM (fetch (REGION HEIGHT) of (\FM.DTOPGROUPPROP GROUPS
(QUOTE REGION)))
ROWSPACE))
(LISTPUT PROPS (QUOTE ITEMS)
(DREVERSE (CAR ITEMLIST)))
(LISTPUT PROPS (QUOTE REGION)
EXTENT)
(LISTPUT PROPS (QUOTE DAUGHTERS)
(DREVERSE (CAR ROWIDS)))
(CONS (\FM.MAKEGROUP ID PROPS)
(CAR GROUPLIST])
(\FM.FORMATBYCOLUMN
[LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)
(* jow "17-Apr-86 18:09")
(* ID and PROPS are passed from \FM.FORMAT. ID is this groups id, and is passed as the MOTHER of each column.
DESCRIPTION is a list of columns, each column a list of items (top to bottom) and groups. \FM.LAYOUTCOLUMN takes a
column description and lays out the items. Column formatting requires a second pass, to top justify the columns.
This is done by going through the GROUPLIST and pushing up each column as necessary.)
(LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0))
(ITEMLIST (LIST NIL))
(GROUPLIST (LIST NIL))
(COLUMNIDS (LIST NIL))
(COLUMNLEFT LEFT)
GROUPS)
(for COL in DESCRIPTION
do (SETQ GROUPS (\FM.LAYOUTCOLUMN COL FONT COLUMNLEFT BOTTOM ROWSPACE COLUMNSPACE
ID))
(TCONC COLUMNIDS (\FM.DTOPGROUPID GROUPS))
[LCONC ITEMLIST (COPY (\FM.DTOPGROUPPROP GROUPS (QUOTE ITEMS]
(EXTENDREGION EXTENT (\FM.DTOPGROUPPROP GROUPS (QUOTE REGION)))
(LCONC GROUPLIST GROUPS)
(add COLUMNLEFT (fetch (REGION WIDTH) of (\FM.DTOPGROUPPROP GROUPS
(QUOTE REGION)))
COLUMNSPACE))
(SETQ GROUPLIST (CAR GROUPLIST)) (* list from LCONC pair)
[LET ((HEIGHT (fetch (REGION HEIGHT) of EXTENT))
COLHEIGHT)
(for COLID in (CAR COLUMNIDS)
do (* go through each column, pushing up each item in the
column.)
[SETQ COLHEIGHT (fetch (REGION HEIGHT) of (\FM.DGROUPPROP GROUPLIST COLID
(QUOTE REGION]
(if (NEQ COLHEIGHT HEIGHT)
then (* column doesn't reach top, so push up)
(\FM.PUSHGROUP COLID GROUPLIST (IDIFFERENCE HEIGHT COLHEIGHT)
(QUOTE UP]
(LISTPUT PROPS (QUOTE ITEMS)
(CAR ITEMLIST))
(LISTPUT PROPS (QUOTE REGION)
EXTENT)
(LISTPUT PROPS (QUOTE DAUGHTERS)
(CAR COLUMNIDS))
(CONS (\FM.MAKEGROUP ID PROPS)
GROUPLIST])
(\FM.FORMATBYGRID
[LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)
(* jow " 9-May-86 16:05")
(* ID and PROPS are specified by \FM.FORMAT. ID is this groups id, and thus the MOTHER of each grid row.
DESCRIPTION is a list of rows, each row a list of item descriptions and groups. Reverse the rows, then build from
bottom up. GRID is the list of columns. Ignore row and item offsets and make the first column LEFT.
This is okay because can achieve the offset by group offset. \FM.LAYOUTGRID formats each row, and also updates the
column grid. As a second pass, the items in each row are pushed right, to align them with the calculated grid.
This involves extending the extent to include any item/group that is on the last grid position, otherwise the
item/group could get justified out of the extent.)
(LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0))
(ITEMLIST (LIST NIL))
(GROUPLIST (LIST NIL))
(ROWIDS (LIST NIL))
(GRID (TCONC (LIST NIL)
LEFT))
(ROWBOTTOM BOTTOM)
GROUPS ROWITEMS ROWREGION ROWDAUGHTERS ALIGNREGION BOX)
(for ROWDESC in (REVERSE DESCRIPTION)
do (SETQ GROUPS (\FM.LAYOUTGRID ROWDESC FONT GRID ROWBOTTOM ROWSPACE COLUMNSPACE ID)
)
(TCONC ROWIDS (\FM.DTOPGROUPID GROUPS))
[LCONC ITEMLIST (REVERSE (\FM.DTOPGROUPPROP GROUPS (QUOTE ITEMS]
(EXTENDREGION EXTENT (\FM.DTOPGROUPPROP GROUPS (QUOTE REGION)))
(LCONC GROUPLIST GROUPS)
(add ROWBOTTOM (fetch (REGION HEIGHT) of (\FM.DTOPGROUPPROP GROUPS
(QUOTE REGION)))
ROWSPACE))
(SETQ GROUPLIST (CAR GROUPLIST)) (* grab list from LCONC pair)
(SETQ ROWIDS (DREVERSE (CAR ROWIDS)))
(SETQ GRID (CAR GRID))
(for ROWID in ROWIDS as ROWDESC in DESCRIPTION
do (SETQ ROWREGION (\FM.DGROUPPROP GROUPLIST ROWID (QUOTE REGION)))
(SETQ ROWITEMS (\FM.DGROUPPROP GROUPLIST ROWID (QUOTE ITEMS)))
(SETQ ROWDAUGHTERS (\FM.DGROUPPROP GROUPLIST ROWID (QUOTE DAUGHTERS)))
(for ITEMDESC in ROWDESC as GRIDPOS in GRID
do (if (EQ \FM.GROUPSPEC (CAR ITEMDESC))
then (SETQ ALIGNREGION (\FM.DGROUPPROP GROUPLIST (CAR ROWDAUGHTERS)
(QUOTE REGION)))
(SETQ ROWITEMS (CDR (FMEMB
[CAR (LAST (\FM.DGROUPPROP
GROUPLIST
(CAR ROWDAUGHTERS)
(QUOTE ITEMS]
ROWITEMS)))
(if (NEQ GRIDPOS (fetch (REGION LEFT) of ALIGNREGION))
then (* need to align a group)
(\FM.PUSHGROUP (CAR ROWDAUGHTERS)
GROUPLIST
(IDIFFERENCE GRIDPOS
(fetch (REGION
LEFT)
of ALIGNREGION))
(QUOTE RIGHT)))
(SETQ ROWDAUGHTERS (CDR ROWDAUGHTERS))
(* point at next item and group)
else (SETQ ALIGNREGION (\FM.ITEMPROP (CAR ROWITEMS)
(QUOTE MAXREGION)))
(replace (REGION LEFT) of (\FM.ITEMPROP (CAR ROWITEMS)
(QUOTE REGION))
with GRIDPOS)
(replace (REGION LEFT) of ALIGNREGION with GRIDPOS)
(SETQ ROWITEMS (CDR ROWITEMS))
(* point at next item))
finally (EXTENDREGION ROWREGION ALIGNREGION)
[if (SETQ BOX (\FM.DGROUPPROP GROUPLIST ROWID (QUOTE BOX)))
then (add (fetch (REGION WIDTH) of ROWREGION)
(IPLUS BOX (\FM.DGROUPPROP GROUPLIST ROWID
(QUOTE BOXSPACE]
(EXTENDREGION EXTENT ROWREGION)))
(LISTPUT PROPS (QUOTE ITEMS)
(DREVERSE (CAR ITEMLIST)))
(LISTPUT PROPS (QUOTE REGION)
EXTENT)
(LISTPUT PROPS (QUOTE DAUGHTERS)
ROWIDS)
(CONS (\FM.MAKEGROUP ID PROPS)
GROUPLIST])
(\FM.FORMATEXPLICIT
[LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)
(* jow "17-Apr-86 18:10")
(* ID and PROPS are specified by \FM.FORMAT. For an explicitely formatted group, just check that the descriptions
are valid, and figure out the groups extent. If the group is layed out in local coordinates, replace with menu
coordinates. When a group is encountered within an explicitely formatted group, the LEFT and BOTTOM specs in the
inside group locate its corner. If the outer group is expressed in group coordinates, then the corner of the outer
group is passed on, so that the inner group will be in the same system.)
(LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0))
(ITEMLIST (LIST NIL))
(GROUPLIST (LIST NIL))
(SUBGROUPIDS (LIST NIL))
(LOCAL (EQ (LISTGET PROPS (QUOTE COORDINATES))
(QUOTE GROUP)))
X) (* X holds newly created group or item.)
[for ITEMDESC in DESCRIPTION do (if (EQ \FM.GROUPSPEC (CAR ITEMDESC))
then (* if item is a group, recurse)
(if LOCAL
then (SETQ X (\FM.FORMAT
(CDR ITEMDESC)
(QUOTE EXPLICIT)
FONT LEFT BOTTOM ROWSPACE
COLUMNSPACE ID))
else (SETQ X (\FM.FORMAT
(CDR ITEMDESC)
(QUOTE EXPLICIT)
FONT 0 0 ROWSPACE COLUMNSPACE
ID)))
(TCONC SUBGROUPIDS (\FM.DTOPGROUPID
X))
[LCONC ITEMLIST
(COPY (\FM.DTOPGROUPPROP
X
(QUOTE ITEMS]
(EXTENDREGION EXTENT (\FM.DTOPGROUPPROP
X
(QUOTE REGION)))
(LCONC GROUPLIST X)
else (\FM.CHECKDESCRIPTION ITEMDESC)
(* check description and left and bottom specs)
(if LOCAL
then
(* change group coord's into menu coord's)
(SETQ X
(\FM.CREATEITEM ITEMDESC FONT
LEFT BOTTOM ID)
)
else (SETQ X
(\FM.CREATEITEM ITEMDESC FONT 0
0 ID)))
(TCONC ITEMLIST X)
(EXTENDREGION EXTENT (\FM.ITEMPROP
X
(QUOTE MAXREGION]
(LISTPUT PROPS (QUOTE ITEMS)
(DREVERSE (CAR ITEMLIST)))
(LISTPUT PROPS (QUOTE REGION)
EXTENT)
(LISTPUT PROPS (QUOTE DAUGHTERS)
(CAR SUBGROUPIDS))
(CONS (\FM.MAKEGROUP ID PROPS)
(CAR GROUPLIST])
(\FM.LAYOUTROW
[LAMBDA (ROW FONT LEFT BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS)
(* jow "17-Apr-86 18:11")
(* MOTHER mother group id. ID and PROPS belong to the group which is this row, and are currently unspecified on
entry (later versions???) Layout the items in a row starting at LEFT and BOTTOM including any individual item
offsets, leaving COLUMNSPACE bits between items in the row. Nested groups get default row format.
Return a list of groups.)
(\FM.SETUPPROPS ROW (QUOTE (ID FONT LEFT BOTTOM COLUMNSPACE)))
(LET (OLDCORNER BOXOFFSET)
(\FM.CHECKFORBOX)
(LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0))
(ITEMLIST (LIST NIL))
(GROUPLIST (LIST NIL))
(SUBGROUPIDS (LIST NIL))
(GROUPLEFT LEFT)
X) (* X holds newly created group or item)
(for ITEMDESC in ROW
do [if (EQ \FM.GROUPSPEC (CAR ITEMDESC))
then (SETQ X (\FM.FORMAT (CDR ITEMDESC)
(QUOTE ROW)
FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID))
(TCONC SUBGROUPIDS (\FM.DTOPGROUPID X))
[LCONC ITEMLIST (COPY (\FM.DTOPGROUPPROP X (QUOTE ITEMS]
(EXTENDREGION EXTENT (\FM.DTOPGROUPPROP X (QUOTE REGION)))
(LCONC GROUPLIST X)
else (\FM.CHECKDESCRIPTION ITEMDESC)
(SETQ X (\FM.CREATEITEM ITEMDESC FONT LEFT BOTTOM ID))
(TCONC ITEMLIST X)
(EXTENDREGION EXTENT (\FM.ITEMPROP X (QUOTE MAXREGION]
(SETQ LEFT (IPLUS GROUPLEFT (fetch (REGION WIDTH) of EXTENT)
COLUMNSPACE)))
(\FM.UPDATEFORBOX)
(LISTPUT PROPS (QUOTE ITEMS)
(CAR ITEMLIST))
(LISTPUT PROPS (QUOTE REGION)
EXTENT)
(LISTPUT PROPS (QUOTE DAUGHTERS)
(CAR SUBGROUPIDS))
(CONS (\FM.MAKEGROUP ID PROPS)
(CAR GROUPLIST])
(\FM.LAYOUTCOLUMN
[LAMBDA (COLUMN FONT LEFT BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS)
(* jow "17-Apr-86 18:11")
(* MOTHER is mother group id. ID and PROPS belong to the group which is this row, and are currently unspecified on
entry (later versions???) Called by \FM.FORMATBYCOLUMN to layout the items in a column. The COLUMN is reversed, so
that it is built from bottom up. Column starts at LEFT, BOTTOM, with ROWSPACE bits between items.
Nested groups default to column format. The items are returned in the order that they are declared.)
(\FM.SETUPPROPS COLUMN (QUOTE (ID FONT LEFT BOTTOM ROWSPACE)))
(LET (OLDCORNER BOXOFFSET)
(\FM.CHECKFORBOX)
(LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0))
(ITEMLIST (LIST NIL))
(GROUPLIST (LIST NIL))
(SUBGROUPIDS (LIST NIL))
(GROUPBOTTOM BOTTOM)
X) (* X holds newly created group or item)
(for ITEMDESC in (DREVERSE COLUMN)
do [if (EQ \FM.GROUPSPEC (CAR ITEMDESC))
then (SETQ X (\FM.FORMAT (CDR ITEMDESC)
(QUOTE COLUMN)
FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID))
(TCONC SUBGROUPIDS (\FM.DTOPGROUPID X))
[LCONC ITEMLIST (REVERSE (\FM.DTOPGROUPPROP X (QUOTE ITEMS]
(EXTENDREGION EXTENT (\FM.DTOPGROUPPROP X (QUOTE REGION)))
(LCONC GROUPLIST X)
else (\FM.CHECKDESCRIPTION ITEMDESC)
(SETQ X (\FM.CREATEITEM ITEMDESC FONT LEFT BOTTOM ID))
(TCONC ITEMLIST X)
(EXTENDREGION EXTENT (\FM.ITEMPROP X (QUOTE MAXREGION]
(SETQ BOTTOM (IPLUS GROUPBOTTOM (fetch (REGION HEIGHT) of EXTENT)
ROWSPACE)))
(\FM.UPDATEFORBOX)
(LISTPUT PROPS (QUOTE ITEMS)
(DREVERSE (CAR ITEMLIST)))
(LISTPUT PROPS (QUOTE REGION)
EXTENT)
(LISTPUT PROPS (QUOTE DAUGHTERS)
(DREVERSE (CAR SUBGROUPIDS)))
(CONS (\FM.MAKEGROUP ID PROPS)
(CAR GROUPLIST])
(\FM.LAYOUTGRID
[LAMBDA (ROW FONT GRID BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS)
(* jow "24-Apr-86 23:15")
(* MOTHER is mother group id. ID and PROPS belong to the group which is this row, and are currently unspecified on
entry (later versions???) ROW is a list of item descriptions. Layout the items according to GRID, updating GRID as
you go. GRID is a list (built in TCONC format) of column positions, ie the first number in the list is the left
position of the first item in each row, and so on. GRID will always specify a first column.
For each row, update GRID to accomodate the items in that row, by pushing the grid right as necessary for new
items. Then \FM.FORMATBYGRID will use this grid to align all items by column.)
(\FM.SETUPPROPS ROW (QUOTE (ID FONT BOTTOM COLUMNSPACE)))
(LET ((GRIDLEN (FLENGTH (CAR GRID)))
OLDCORNER BOXOFFSET)
(if (LISTGET PROPS (QUOTE BOX))
then (* offset group to allow for box.
Like CHECKFORBOX; slightly different for GRID.)
(OR (LISTGET PROPS (QUOTE BOXSHADE))
(LISTPUT PROPS (QUOTE BOXSHADE)
BLACKSHADE))
(OR (LISTGET PROPS (QUOTE BOXSPACE))
(LISTPUT PROPS (QUOTE BOXSPACE)
\FM.BOXSPACE))
(SETQ OLDCORNER (CONS LEFT BOTTOM))
[SETQ BOXOFFSET (IPLUS (LISTGET PROPS (QUOTE BOX))
(LISTGET PROPS (QUOTE BOXSPACE]
(\FM.UPDATEGRID 1 (IPLUS (CAAR GRID)
BOXOFFSET)) (* shift grid to account for box)
(add BOTTOM BOXOFFSET))
(LET ((EXTENT (CREATEREGION (CAAR GRID)
BOTTOM 0 0))
(ITEMLIST (LIST NIL))
(GROUPLIST (LIST NIL))
(SUBGROUPIDS (LIST NIL))
(ITEMNUM 0)
X GROUPREGION LEFT NEXTLEFT)
(for ITEMDESC in ROW
do (add ITEMNUM 1)
(SETQ LEFT (CAR (FNTH (CAR GRID)
ITEMNUM)))
(if (EQ \FM.GROUPSPEC (CAR ITEMDESC))
then (SETQ X (\FM.FORMAT (CDR ITEMDESC)
(QUOTE TABLE)
FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID))
(TCONC SUBGROUPIDS (\FM.DTOPGROUPID X))
[LCONC ITEMLIST (COPY (\FM.DTOPGROUPPROP X (QUOTE ITEMS]
(SETQ GROUPREGION (\FM.DTOPGROUPPROP X (QUOTE REGION)))
(EXTENDREGION EXTENT GROUPREGION)
(LCONC GROUPLIST X)
(SETQ LEFT (fetch (REGION LEFT) of GROUPREGION))
(SETQ NEXTLEFT (IPLUS LEFT (fetch (REGION WIDTH) of
GROUPREGION)
COLUMNSPACE))
else (\FM.CHECKDESCRIPTION ITEMDESC)
(SETQ X (\FM.CREATEITEM ITEMDESC FONT LEFT BOTTOM ID))
(TCONC ITEMLIST X)
(SETQ GROUPREGION (\FM.ITEMPROP X (QUOTE MAXREGION)))
(EXTENDREGION EXTENT GROUPREGION)
(SETQ LEFT (fetch (REGION LEFT) of GROUPREGION))
(SETQ NEXTLEFT (IPLUS LEFT (fetch (REGION WIDTH) of
GROUPREGION)
COLUMNSPACE)))
(\FM.UPDATEGRID ITEMNUM LEFT) (* mark where this one went)
(\FM.UPDATEGRID (ADD1 ITEMNUM)
NEXTLEFT) (* mark where the next one will go)
)
(\FM.UPDATEFORBOX)
(LISTPUT PROPS (QUOTE ITEMS)
(CAR ITEMLIST))
(LISTPUT PROPS (QUOTE REGION)
EXTENT)
(LISTPUT PROPS (QUOTE DAUGHTERS)
(CAR SUBGROUPIDS))
(CONS (\FM.MAKEGROUP ID PROPS)
(CAR GROUPLIST])
(\FM.JUSTIFYITEMS
[LAMBDA (GROUPS GROUPID) (* jow " 9-May-86 14:30")
(* justify the items in group GROUPID, within that items groups extent. If GROUPID is nil, do top group.
This will descend into subgroups, and justify those items within that group.)
(LET (EXTENT EXTENTLEFT EXTENTBOTTOM ITEMREGION ITEMMAXREGION ITEMWIDTH ITEMHEIGHT THISGROUP
MOTHER)
(OR GROUPID (SETQ GROUPID (\FM.DTOPGROUPID GROUPS)))
(for ITEM in (\FM.DGROUPPROP GROUPS GROUPID (QUOTE ITEMS))
when (OR (\FM.ITEMPROP ITEM (QUOTE HJUSTIFY))
(\FM.ITEMPROP ITEM (QUOTE VJUSTIFY)))
do (if (NEQ THISGROUP (\FM.ITEMPROP ITEM (QUOTE GROUPID)))
then (SETQ THISGROUP (\FM.ITEMPROP ITEM (QUOTE GROUPID)))
[if (EQ (\FM.DGROUPPROP GROUPS THISGROUP (QUOTE FORMAT))
(QUOTE EXPLICIT))
then (SETQ EXTENT (\FM.DGROUPPROP GROUPS THISGROUP (QUOTE
REGION)))
else (SETQ MOTHER (\FM.DGROUPPROP GROUPS THISGROUP (QUOTE MOTHER))
)
(SETQ EXTENT (\FM.DGROUPPROP GROUPS MOTHER (QUOTE REGION]
(SETQ EXTENTLEFT (fetch (REGION LEFT) of EXTENT))
(SETQ EXTENTBOTTOM (fetch (REGION BOTTOM) of EXTENT)))
(SETQ ITEMREGION (\FM.ITEMPROP ITEM (QUOTE REGION)))
(SETQ ITEMMAXREGION (\FM.ITEMPROP ITEM (QUOTE MAXREGION)))
(if (\FM.ITEMPROP ITEM (QUOTE HJUSTIFY))
then (SETQ ITEMWIDTH (fetch (REGION WIDTH) of ITEMMAXREGION))
(replace (REGION LEFT) of ITEMREGION
with (SELECTQ (\FM.ITEMPROP ITEM (QUOTE HJUSTIFY))
(LEFT EXTENTLEFT)
(CENTER (IPLUS EXTENTLEFT
(IQUOTIENT
(IDIFFERENCE
(fetch (REGION WIDTH)
of EXTENT)
ITEMWIDTH)
2)))
(RIGHT (IPLUS EXTENTLEFT
(IDIFFERENCE (fetch
(REGION WIDTH)
of EXTENT)
ITEMWIDTH)))
NIL))
(replace (REGION LEFT) of ITEMMAXREGION with (fetch (REGION
LEFT)
of ITEMREGION)))
(if (\FM.ITEMPROP ITEM (QUOTE VJUSTIFY))
then (SETQ ITEMHEIGHT (fetch (REGION HEIGHT) of ITEMMAXREGION))
(replace (REGION BOTTOM) of ITEMREGION
with (SELECTQ (\FM.ITEMPROP ITEM (QUOTE VJUSTIFY))
(TOP (IPLUS EXTENTBOTTOM
(IDIFFERENCE (fetch (REGION HEIGHT)
of EXTENT)
ITEMHEIGHT)))
(MIDDLE (IPLUS EXTENTBOTTOM
(IQUOTIENT
(IDIFFERENCE
(fetch (REGION HEIGHT)
of EXTENT)
ITEMHEIGHT)
2)))
(BOTTOM EXTENTBOTTOM)
NIL))
(replace (REGION BOTTOM) of ITEMMAXREGION with (fetch
(REGION BOTTOM)
of ITEMREGION])
(\FM.JUSTIFYGROUPS
[LAMBDA (GROUPS GROUPID) (* jow "12-Apr-86 14:55")
(* justify group GROUPID in GROUPS structure.
This will descend into the daughter groups.
If GROUPID is nil, start at the top.)
NIL])
(\FM.PUSHGROUP
[LAMBDA (GROUPID GROUPS AMOUNT DIR) (* jow "12-Apr-86 18:25")
(* GROUPS is freemenu groups structure, GROUPID is id of group in GROUPS to push. If GROUPID is NIL, then push top
group. Push each item by AMOUNT in the DIR direction. Update the groups region. Currently this function only knows
about pushing UP and RIGHT,)
(OR GROUPID (SETQ GROUPID (\FM.DTOPGROUPID GROUPS)))
(for ITEM in (\FM.DGROUPPROP GROUPS GROUPID (QUOTE ITEMS))
do (SELECTQ DIR
[UP (add (fetch (REGION BOTTOM) of (\FM.ITEMPROP ITEM (QUOTE REGION)))
AMOUNT)
(replace (REGION BOTTOM) of (\FM.ITEMPROP ITEM (QUOTE MAXREGION))
with (fetch (REGION BOTTOM) of (\FM.ITEMPROP ITEM (QUOTE REGION]
[RIGHT (add (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM (QUOTE REGION)))
AMOUNT)
(replace (REGION LEFT) of (\FM.ITEMPROP ITEM (QUOTE MAXREGION))
with (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM (QUOTE
REGION]
NIL))
(SELECTQ DIR
(UP (add (fetch (REGION BOTTOM) of (\FM.DGROUPPROP GROUPS GROUPID (QUOTE
REGION)))
AMOUNT))
(RIGHT (add (fetch (REGION LEFT) of (\FM.DGROUPPROP GROUPS GROUPID (QUOTE
REGION)))
AMOUNT))
NIL])
(\FM.CHECKDESCRIPTION
[LAMBDA (ID) (* jow "21-May-86 16:14")
(* check the item description for errors.
This is done before creating the item. The general errors are checked first,
and then the type specific errors are checked.
ALSO, if the item is boxed, fill out the description with all of the boxing
info.)
(LET [(LABEL (LISTGET ID (QUOTE LABEL)))
(TYPE (OR (LISTGET ID (QUOTE TYPE))
(QUOTE MOMENTARY] (* ------------------------------
TYPE FIELD)
(if (NOT (FMEMB TYPE \FM.ITEM-TYPES))
then (ERROR "Invalid TYPE:" ID)) (* ------------------------------
LABEL FIELD)
(if (NOT (OR (AND LABEL (ATOM LABEL))
(STRINGP LABEL)
(BITMAPP LABEL)))
then (ERROR "Invalid LABEL. Atom, string, or bitmap expected:" ID))
(* ------------------------------
FIXP FIELDS)
(for PROP in (QUOTE (LEFT BOTTOM MAXWIDTH HAXHEIGHT BOX BOXSPACE))
do (if [AND (LISTGET ID PROP)
(NOT (FIXP (LISTGET ID PROP]
then (ERROR (CONCAT "Invalid " PROP ". Fixp expected:")
ID))) (* ------------------------------
JUSTIFICATION FIELDS)
(if (AND (LISTGET ID (QUOTE HJUSTIFY))
(NOT (FMEMB (LISTGET ID (QUOTE HJUSTIFY))
\FM.HJUSTIFY-SPECS)))
then (ERROR (CONCAT "Invalid HJUSTIFY. One of " \FM.HJUSTIFY-SPECS " expected:" ID)))
(if (AND (LISTGET ID (QUOTE VJUSTIFY))
(NOT (FMEMB (LISTGET ID (QUOTE VJUSTIFY))
\FM.VJUSTIFY-SPECS)))
then (ERROR (CONCAT "Invalid VJUSTIFY. One of " \FM.VJUSTIFY-SPECS " expected:" ID)))
(* ------------------------------
TEXTURE FIELDS)
(for PROP in (QUOTE (BACKGROUND BOXSHADE))
do (if [AND (LISTGET ID PROP)
(NOT (TEXTUREP (LISTGET ID PROP]
then (ERROR (CONCAT "Invalid " PROP ". Shade expected:")
ID))) (* ------------------------------
HIGHLIGHT FIELD)
(if [AND (LISTGET ID (QUOTE HIGHLIGHT))
[NOT (ATOM (LISTGET ID (QUOTE HIGHLIGHT]
[NOT (STRINGP (LISTGET ID (QUOTE HIGHLIGHT]
(NOT (BITMAPP (LISTGET ID (QUOTE HIGHLIGHT]
then (ERROR "Invalid HIGHLIGHT. Texture or Label expected:" ID))
(* ------------------------------
FUNCTION FIELDS)
(for PROP in (QUOTE (SELECTEDFN DOWNFN HELDFN MOVEDFN))
do (if [AND (LISTGET ID PROP)
(NOT (ATOM (LISTGET ID PROP)))
(NOT (LISTP (LISTGET ID PROP]
then (ERROR (CONCAT "Invalid " PROP ". Atomic function name expected:")
ID))) (* ------------------------------
TYPE SPECIFIC CHECKS)
[if (LISTGET ID (QUOTE BOX))
then (* fill out box info in description)
(OR (LISTGET ID (QUOTE BOXSHADE))
(LISTPUT ID (QUOTE BOXSHADE)
BLACKSHADE))
(LISTPUT ID (QUOTE BOXOFFSET)
(IPLUS (LISTGET ID (QUOTE BOX))
(OR (LISTGET ID (QUOTE BOXSPACE))
\FM.BOXSPACE]
(SELECTQ TYPE
(3STATE (if [AND (LISTGET ID (QUOTE OFF))
[NOT (ATOM (LISTGET ID (QUOTE OFF]
[NOT (STRINGP (LISTGET ID (QUOTE OFF]
(NOT (BITMAPP (LISTGET ID (QUOTE OFF]
then (ERROR "Invalid OFF. Texture or Label expected:" ID)))
(STATE (if [AND (LISTGET ID (QUOTE CHANGESTATE))
(NOT (ATOM (LISTGET ID (QUOTE CHANGESTATE]
then (ERROR "Invalid CHANGESTATE property. Atomic function name expected:"
ID))
(if [AND (LISTGET ID (QUOTE MENUITEMS))
(NOT (LISTP (LISTGET ID (QUOTE MENUITEMS]
then (ERROR "Invalid MENUITEMS property. List of items expected:" ID)))
(NWAY (if (NOT (LISTGET ID (QUOTE COLLECTION)))
then (ERROR "Unspecified COLLECTION for NWAY item:" ID)))
(EDIT (if (BITMAPP LABEL)
then (ERROR "Edit item label must be string or atom." ID)))
NIL])
(\FM.CHECKPROPS
[LAMBDA (PROPS) (* jow
"30-Mar-86 00:53")
(if (AND (LISTGET PROPS (QUOTE FORMAT))
(NOT (FMEMB (LISTGET PROPS (QUOTE FORMAT))
\FM.FORMAT-TYPES)))
then (ERROR "PROPS Error. Invalid FORMAT:" PROPS))
(for PROP in (QUOTE (LEFT BOTTOM ROWSPACE COLUMNSPACE BOX BOXSPACE))
do (if [AND (LISTGET PROPS PROP)
(NOT (FIXP (LISTGET PROPS PROP]
then (ERROR (CONCAT "PROPS Error. FIXP expected for " PROP " property:")
PROPS)))
(for PROP in (QUOTE (BOXSHADE BACKGROUND))
do (if [AND (LISTGET PROPS PROP)
(NOT (TEXTUREP (LISTGET PROPS PROP]
then (ERROR (CONCAT "PROPS Error. TEXTURE expected for " PROP " property:")
PROPS])
(\FM.CREATEITEM
[LAMBDA (ID FONTDEFAULT LEFT BOTTOM GROUPID) (* jow "17-Apr-86 19:28")
(* create an item at position LEFT and BOTTOM as specified by the formatter. Add item offsets given in the
description to this position. Set the items region to the minimum of the label size and the max size specified.)
(add LEFT (OR (LISTGET ID (QUOTE LEFT))
0))
(add BOTTOM (OR (LISTGET ID (QUOTE BOTTOM))
0))
(LET* [(TYPE (OR (LISTGET ID (QUOTE TYPE))
(QUOTE MOMENTARY)))
(LABEL (LISTGET ID (QUOTE LABEL)))
(FONT (OR [AND (LISTGET ID (QUOTE FONT))
(APPLY* (FUNCTION FONTCREATE)
(LISTGET ID (QUOTE FONT]
FONTDEFAULT))
(REGIONS (\FM.GETREGIONS ID LEFT BOTTOM FONT))
(BITMAPS (\FM.GETBITMAPS ID FONT (CAR REGIONS)
(CADR REGIONS)))
(ITEM (create FREEMENUITEM
FM.TYPE ← TYPE
FM.LABEL ← LABEL
FM.ID ←(LISTGET ID (QUOTE ID))
FM.GROUPID ← GROUPID
FM.INITSTATE ←(LISTGET ID (QUOTE INITSTATE))
FM.FONT ← FONT
FM.BITMAP ←(CAR BITMAPS)
FM.HIGHLIGHT ←(CADR BITMAPS)
FM.REGION ←(CAR REGIONS)
FM.MAXREGION ←(CADDR REGIONS)
FM.MESSAGE ←(LISTGET ID (QUOTE MESSAGE))
FM.LINKS ←(OR (LISTGET ID (QUOTE LINKS))
(LIST NIL))
FM.DOWNFN ←(OR (LISTGET ID (QUOTE DOWNFN))
(FUNCTION NILL))
FM.HELDFN ←(OR (LISTGET ID (QUOTE HELDFN))
(FUNCTION NILL))
FM.MOVEDFN ←(OR (LISTGET ID (QUOTE MOVEDFN))
(FUNCTION NILL))
FM.SELECTEDFN ←(OR (LISTGET ID (QUOTE SELECTEDFN))
(FUNCTION NILL]
(\FM.READUSERDATA ITEM ID)
(APPLY* (PACK* "\FM." TYPE "-SETUP")
ITEM REGIONS) (* pass REGIONS to setup fn, since might need
highlightregion, etc.)
ITEM])
(\FM.GETREGIONS
[LAMBDA (ID LEFT BOTTOM FONT) (* jow "19-Apr-86 21:41")
(* Called by the formatter to determine the region an item will occupy. LEFT and BOTTOM are the items proposed
position, determined by the formatter. If the item is boxed, then the region is the region of the box, not the
label in the box. Return a list containing the item region, the highlight region, and the max region.)
(LET* [(WIDTH (\FM.ITEMWIDTH (LISTGET ID (QUOTE LABEL))
FONT))
(HEIGHT (\FM.ITEMHEIGHT (LISTGET ID (QUOTE LABEL))
FONT))
(HL (LISTGET ID (QUOTE HIGHLIGHT)))
(HIGHLIGHT (OR (AND (ATOM HL)
(NOT (TEXTUREP HL))
HL)
(BITMAPP HL)
(STRINGP HL)))
(HIGHLIGHTWIDTH (OR (AND HIGHLIGHT (\FM.ITEMWIDTH HIGHLIGHT FONT))
0))
(HIGHLIGHTHEIGHT (OR (AND HIGHLIGHT (\FM.ITEMHEIGHT HIGHLIGHT FONT))
0))
(MAXWIDTH (OR (LISTGET ID (QUOTE MAXWIDTH))
(IMAX WIDTH HIGHLIGHTWIDTH)))
(MAXHEIGHT (OR (LISTGET ID (QUOTE MAXHEIGHT))
(IMAX HEIGHT HIGHLIGHTHEIGHT)))
(BOXOFFSET (AND (LISTGET ID (QUOTE BOXOFFSET))
(ITIMES 2 (LISTGET ID (QUOTE BOXOFFSET]
(if BOXOFFSET
then (SETQ WIDTH (IPLUS BOXOFFSET MAXWIDTH))
(SETQ HEIGHT (IPLUS BOXOFFSET MAXHEIGHT))
(LIST (CREATEREGION LEFT BOTTOM WIDTH HEIGHT)
(AND HIGHLIGHT (CREATEREGION LEFT BOTTOM WIDTH HEIGHT))
(CREATEREGION LEFT BOTTOM WIDTH HEIGHT))
else (LIST (CREATEREGION LEFT BOTTOM (IMIN WIDTH MAXWIDTH)
(IMIN HEIGHT MAXHEIGHT))
(AND HIGHLIGHT (CREATEREGION LEFT BOTTOM (IMIN HIGHLIGHTWIDTH
MAXWIDTH)
(IMIN HIGHLIGHTHEIGHT MAXHEIGHT)))
(CREATEREGION LEFT BOTTOM MAXWIDTH MAXHEIGHT])
(\FM.GETBITMAPS
[LAMBDA (ID FONT ITEMREGION HIGHLIGHTREGION) (* jow "18-Apr-86 14:57")
(* Figure out the items bitmap and highlighting
requirements.)
(LET ((BOX (OR (LISTGET ID (QUOTE BOX))
0))
(BOXSHADE (LISTGET ID (QUOTE BOXSHADE)))
(HIGHLIGHT (LISTGET ID (QUOTE HIGHLIGHT)))
(WIDTH (fetch (REGION WIDTH) of ITEMREGION))
(HEIGHT (fetch (REGION HEIGHT) of ITEMREGION))
BITMAP HLBITMAP)
(SETQ BITMAP (\FM.MAKEBITMAP (LISTGET ID (QUOTE LABEL))
FONT WIDTH HEIGHT ID))
[COND
((OR (AND HIGHLIGHT (ATOM HIGHLIGHT)
(NOT (TEXTUREP HIGHLIGHT)))
(STRINGP HIGHLIGHT)
(BITMAPP HIGHLIGHT)) (* highlight label specified.)
(SETQ HLBITMAP (\FM.MAKEBITMAP HIGHLIGHT FONT (fetch (REGION WIDTH) of
HIGHLIGHTREGION)
(fetch (REGION HEIGHT) of HIGHLIGHTREGION)
ID)))
((OR (TEXTUREP HIGHLIGHT)
(AND (LISTGET ID (QUOTE BOX))
(NEQ BOXSHADE BLACKSHADE)
(SETQ HIGHLIGHT BOXSHADE))) (* highlight texture was specified, or non-black box
with default highlight (boxshade))
(SETQ HLBITMAP (BITMAPCOPY BITMAP))
(BLTSHADE HIGHLIGHT HLBITMAP BOX BOX (IDIFFERENCE WIDTH (ITIMES BOX 2))
(IDIFFERENCE HEIGHT (ITIMES BOX 2))
(QUOTE PAINT)))
(T (* invert. Start with bitmap, and invert region inside
box.)
(SETQ HLBITMAP (BITMAPCOPY BITMAP))
(BITBLT BITMAP BOX BOX HLBITMAP BOX BOX (IDIFFERENCE WIDTH (ITIMES BOX 2))
(IDIFFERENCE HEIGHT (ITIMES BOX 2))
(QUOTE INVERT]
(LIST BITMAP HLBITMAP])
(\FM.MAKEBITMAP
[LAMBDA (LABEL FONT WIDTH HEIGHT ID) (* jow "18-Apr-86 14:29")
(* use ID only for boxing info.)
(LET ((BOX (LISTGET ID (QUOTE BOX)))
(BOXOFFSET (OR (LISTGET ID (QUOTE BOXOFFSET))
0))
(BITMAP (BITMAPCREATE WIDTH HEIGHT))
CLIPPINGREGION)
[SETQ CLIPPINGREGION (CREATEREGION BOXOFFSET BOXOFFSET (IDIFFERENCE WIDTH
(ITIMES
BOXOFFSET 2))
(IDIFFERENCE HEIGHT (ITIMES BOXOFFSET 2]
(if BOX
then (* check for boxed item)
(BLTSHADE (LISTGET ID (QUOTE BOXSHADE))
BITMAP) (* do box and background)
(BLTSHADE WHITESHADE BITMAP BOX BOX (IDIFFERENCE WIDTH (ITIMES BOX 2))
(IDIFFERENCE HEIGHT (ITIMES BOX 2)))
(* copy box into HLBITMAP)
)
(if (BITMAPP LABEL)
then (BITBLT LABEL 0 0 BITMAP BOXOFFSET BOXOFFSET NIL NIL NIL NIL NIL CLIPPINGREGION)
else (LET ((STREAM (DSPCREATE BITMAP)))
(DSPFONT FONT STREAM)
(DSPXPOSITION BOXOFFSET STREAM)
(DSPYPOSITION (IPLUS BOXOFFSET (FONTPROP FONT (QUOTE DESCENT)))
STREAM)
(DSPCLIPPINGREGION CLIPPINGREGION STREAM)
(PRIN1 LABEL STREAM)))
BITMAP])
(\FM.READUSERDATA
[LAMBDA (ITEM DESCRIPTION) (* jow "15-Apr-86 16:58")
(* scans DESCRIPTION for user props.
Add any prop/value pairs found to ITEM's userdata
list.)
(for X on DESCRIPTION by (CDDR X) do (if (NOT (FMEMB (CAR X)
\FM.DESCRIPTION-PROPS))
then (LISTPUT (\FM.ITEMPROP ITEM
(QUOTE
USERDATA))
(CAR X)
(CADR X])
(\FM.MAKELINKS
[LAMBDA (WINDOW) (* jow "12-Apr-86 19:07")
(* go through items and replace link requests with
actual pointers)
(for ITEM in (WINDOWPROP WINDOW (QUOTE FM.ITEMS))
do (for LINKTAIL ITEMPTR on (CDR (\FM.ITEMPROP ITEM (QUOTE LINKS)))
by (CDDR LINKTAIL)
do (SETQ ITEMPTR (CAR LINKTAIL))
(RPLACA LINKTAIL (\FM.COERCEITEMPTR ITEMPTR WINDOW ITEM])
(\FM.COLLECTNWAYS
[LAMBDA (WINDOW) (* jow "17-Apr-86 15:28")
(* go through items in menu, building NWAYS structure. Select the first item in each collection.
NWAYS structure is list of collection proplists, each beginning with id of collection, and containing STATE of
collection, and other user props.)
(LET ((NWAYS (LIST NIL))
(NWAYIDS (LIST NIL))
NWAYPROPS ITEMPTR)
(for ITEM in (WINDOWPROP WINDOW (QUOTE FM.ITEMS))
do (if [AND (EQ (\FM.ITEMPROP ITEM (QUOTE TYPE))
(QUOTE NWAY))
(NOT (FMEMB (\FM.ITEMPROP ITEM (QUOTE COLLECTION))
(CAR NWAYIDS]
then (* this is the first nway of this collection)
(TCONC NWAYIDS (\FM.ITEMPROP ITEM (QUOTE COLLECTION)))
(* setup NWAYPROPS and STATE)
(if (\FM.ITEMPROP ITEM (QUOTE NWAYPROPS))
then (SETQ NWAYPROPS (\FM.ITEMPROP ITEM (QUOTE NWAYPROPS)))
(LISTPUT NWAYPROPS (QUOTE STATE)
ITEM)
else (SETQ NWAYPROPS (LIST (QUOTE STATE)
ITEM)))
(* setup INITSTATE)
(if (LISTGET NWAYPROPS (QUOTE INITSTATE))
then (* make link to specified INITSTATE item)
(SETQ ITEMPTR (LISTGET NWAYPROPS (QUOTE INITSTATE)))
(LISTPUT NWAYPROPS (QUOTE INITSTATE)
(\FM.COERCEITEMPTR ITEMPTR WINDOW ITEM))
else (* MAKE THIS ITEM THE INITSTATE)
(LISTPUT NWAYPROPS (QUOTE INITSTATE)
ITEM))
(TCONC NWAYS (\FM.MAKEGROUP (CADR NWAYIDS)
NWAYPROPS))
(* this is the selected item)
(\FM.TOGGLE-CHANGESTATE ITEM T)))
(WINDOWPROP WINDOW (QUOTE FM.NWAYS)
(CAR NWAYS])
(\FM.SETATTACHPOINT
[LAMBDA (ITEMS WIDTH HEIGHT) (* jow "12-Apr-86 18:02")
(* figure out each items attach point based on its
position in extent)
(for ITEM in ITEMS do (\FM.ITEMPROP ITEM (QUOTE ATTACHPOINT)
(\FM.ATTACHPOINT ITEM WIDTH HEIGHT])
(\FM.CREATEW
[LAMBDA (GROUPS TITLE BACKGROUND BORDER) (* jow "24-Apr-86 21:24")
(* Create a freemenu window.
Then setup the window with the necessary freemenu
properties.)
(LET* ([REGION (COPY (LISTGET (CDAR GROUPS)
(QUOTE REGION]
(WINDOW (CREATEW (CREATEREGION (fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
(WIDTHIFWINDOW (fetch (REGION WIDTH) of REGION)
BORDER)
(HEIGHTIFWINDOW (fetch (REGION HEIGHT)
of REGION)
TITLE BORDER))
TITLE BORDER T)))
(WINDOWPROP WINDOW (QUOTE WINDOWENTRYFN)
(QUOTE \FM.WINDOWENTRYFN))
(WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN)
(QUOTE \FM.BUTTONEVENTFN))
(WINDOWPROP WINDOW (QUOTE RIGHTBUTTONFN)
(QUOTE \FM.RIGHTBUTTONFN))
(WINDOWPROP WINDOW (QUOTE REPAINTFN)
(QUOTE \FM.REDISPLAYMENU))
(WINDOWPROP WINDOW (QUOTE RESHAPEFN)
(QUOTE \FM.RESHAPEFN))
(WINDOWPROP WINDOW (QUOTE INITCORNERSFN)
(QUOTE \FM.INITCORNERSFN))
(WINDOWPROP WINDOW (QUOTE OPENFN)
(QUOTE FM.REDISPLAYMENU))
(WINDOWPROP WINDOW (QUOTE CLOSEFN)
(QUOTE \FM.ENDEDIT))
(WINDOWPROP WINDOW (QUOTE SHRINKFN)
(QUOTE \FM.ENDEDIT))
(WINDOWPROP WINDOW (QUOTE SCROLLFN)
(QUOTE SCROLLBYREPAINTFN))
(WINDOWPROP WINDOW (QUOTE SCROLLEXTENTUSE)
(QUOTE (LIMIT . LIMIT)))
(WINDOWPROP WINDOW (QUOTE EXTENT)
REGION)
(WINDOWPROP WINDOW (QUOTE FM.MINWIDTH)
(fetch (REGION WIDTH) of REGION))
(WINDOWPROP WINDOW (QUOTE FM.MINHEIGHT)
(fetch (REGION HEIGHT) of REGION))
(WINDOWPROP WINDOW (QUOTE FM.BUSY)
NIL)
(WINDOWPROP WINDOW (QUOTE FM.BACKGROUND)
BACKGROUND)
(WINDOWPROP WINDOW (QUOTE FM.GROUPS)
GROUPS)
(WINDOWPROP WINDOW (QUOTE FM.ITEMS)
(LISTGET (CDAR GROUPS)
(QUOTE ITEMS)))
WINDOW])
(\FM.STARTEDIT
[LAMBDA (ITEM WINDOW CLEARFLG) (* jow "17-Oct-86 18:35")
(RESETLST (RESETSAVE NIL (LIST (QUOTE WINDOWPROP)
WINDOW
(QUOTE FM.BUSY)
NIL))
(WINDOWPROP WINDOW (QUOTE FM.BUSY)
T)
(\FM.EDIT-ITEM ITEM WINDOW CLEARFLG T (if (EQ (\FM.ITEMPROP ITEM (QUOTE TYPE))
(QUOTE NUMBER))
then (FUNCTION \FM.NUMBER-CHANGESTATE])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \FM.SETUPPROPS MACRO ((DESCRIPTION CHANGEPROPS)
(if (EQ \FM.PROPSPEC (CAAR DESCRIPTION))
then
(SETQ PROPS (CDAR DESCRIPTION))
(RPLNODE2 DESCRIPTION (CDR DESCRIPTION))
(* yank props out of row)
(\FM.CHECKPROPS PROPS)
(\FM.SETFORMATPROPS CHANGEPROPS)
else
(SETQ PROPS (LIST (QUOTE ITEMS)
NIL))
(SETQ ID (GENSYM "FM.GROUP-")))
(LISTPUT PROPS (QUOTE MOTHER)
MOTHER)))
[PUTPROPS \FM.SETFORMATPROPS MACRO
((CHANGEPROPS)
(for PROP in CHANGEPROPS do (SELECTQ PROP [FORMAT (AND (LISTGET PROPS (QUOTE FORMAT))
(SETQ FORMAT (LISTGET PROPS
(QUOTE FORMAT]
[FONT (AND (LISTGET PROPS (QUOTE FONT))
(SETQ FONT (APPLY* (FUNCTION FONTCREATE)
(LISTGET PROPS (QUOTE FONT]
(LEFT (add LEFT (OR (LISTGET PROPS (QUOTE LEFT))
0)))
(BOTTOM (add BOTTOM (OR (LISTGET PROPS (QUOTE BOTTOM))
0)))
[ROWSPACE (AND (LISTGET PROPS (QUOTE ROWSPACE))
(SETQ ROWSPACE (LISTGET PROPS (QUOTE
ROWSPACE
]
[COLUMNSPACE (AND (LISTGET PROPS (QUOTE COLUMNSPACE))
(SETQ COLUMNSPACE (LISTGET PROPS
(QUOTE
COLUMNSPACE
]
[ID (SETQ ID (OR (LISTGET PROPS (QUOTE ID))
(GENSYM "FM.GROUP-"]
NIL]
[PUTPROPS \FM.CHECKFORBOX MACRO (NIL (if (LISTGET PROPS (QUOTE BOX))
then
(* offset group to allow for box.)
(OR (LISTGET PROPS (QUOTE BOXSHADE))
(LISTPUT PROPS (QUOTE BOXSHADE)
BLACKSHADE))
(OR (LISTGET PROPS (QUOTE BOXSPACE))
(LISTPUT PROPS (QUOTE BOXSPACE)
\FM.BOXSPACE))
(SETQ OLDCORNER (CONS LEFT BOTTOM))
[SETQ BOXOFFSET (IPLUS (LISTGET PROPS (QUOTE BOX))
(LISTGET PROPS (QUOTE BOXSPACE]
(add LEFT BOXOFFSET)
(add BOTTOM BOXOFFSET]
[PUTPROPS \FM.UPDATEFORBOX MACRO (NIL (if BOXOFFSET then (* group is boxed: readjust group region)
(replace (REGION LEFT)
of EXTENT with (CAR OLDCORNER))
(replace (REGION BOTTOM)
of EXTENT with (CDR OLDCORNER))
(add (fetch (REGION WIDTH)
of EXTENT)
(ITIMES BOXOFFSET 2))
(add (fetch (REGION HEIGHT)
of EXTENT)
(ITIMES BOXOFFSET 2]
[PUTPROPS \FM.UPDATEGRID MACRO
((NUM LEFT)
(if (IGREATERP NUM GRIDLEN)
then
(* add this col to grid)
(TCONC GRID LEFT)
(add GRIDLEN 1)
else
(* this col exists. check alignment)
(LET ((GRIDTAIL (FNTH (CAR GRID)
NUM)))
(if (IGREATERP LEFT (CAR GRIDTAIL))
then
(* push grid column over)
(for TAIL on GRIDTAIL bind (AMOUNT ← (IDIFFERENCE LEFT (CAR GRIDTAIL)))
do
(add (CAR TAIL)
AMOUNT]
[PUTPROPS \FM.ITEMWIDTH MACRO ((LABEL FONT)
(if (BITMAPP LABEL)
then
(BITMAPWIDTH LABEL)
else
(STRINGWIDTH LABEL FONT]
[PUTPROPS \FM.ITEMHEIGHT MACRO ((LABEL FONT)
(if (BITMAPP LABEL)
then
(BITMAPHEIGHT LABEL)
else
(FONTPROP FONT (QUOTE HEIGHT]
[PUTPROPS \FM.ATTACHPOINT MACRO ((ITEM WIDTH HEIGHT)
(LET [(MAXREGION (\FM.ITEMPROP ITEM (QUOTE MAXREGION]
(CONS [FIX (FPLUS .5 (FQUOTIENT (ITIMES (fetch (REGION WIDTH)
of MAXREGION)
(fetch (REGION LEFT)
of MAXREGION))
(IDIFFERENCE WIDTH
(fetch (REGION WIDTH)
of MAXREGION]
(FIX (FPLUS .5 (FQUOTIENT (ITIMES (fetch (REGION HEIGHT)
of MAXREGION)
(fetch (REGION BOTTOM)
of MAXREGION))
(IDIFFERENCE HEIGHT
(fetch (REGION HEIGHT)
of MAXREGION]
)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \FM.FORMAT-TYPES (ROW COLUMN TABLE EXPLICIT))
(RPAQQ \FM.DEFAULTFORMAT ROW)
(RPAQQ \FM.GROUPSPEC GROUP)
(RPAQQ \FM.PROPSPEC PROPS)
(RPAQQ \FM.HJUSTIFY-SPECS (LEFT CENTER RIGHT))
(RPAQQ \FM.VJUSTIFY-SPECS (TOP MIDDLE BOTTOM))
(RPAQQ \FM.BOXSPACE 1)
(RPAQQ \FM.ROWSPACE 2)
(RPAQQ \FM.COLUMNSPACE 10)
(RPAQQ \FM.ITEM-TYPES (MOMENTARY TOGGLE 3STATE NWAY STATE NUMBER EDIT EDITSTART DISPLAY))
(RPAQQ \FM.DESCRIPTION-PROPS
(TYPE LABEL LEFT BOTTOM ID GROUPID STATE INITSTATE FONT BITMAP REGION MAXREGION MESSAGE
USERDATA LINKS SYSDOWNFN SYSMOVEDFN SYSSELECTEDFN DOWNFN HELDFN MOVEDFN SELECTEDFN))
[CONSTANTS (\FM.FORMAT-TYPES (QUOTE (ROW COLUMN TABLE EXPLICIT)))
(\FM.DEFAULTFORMAT (QUOTE ROW))
(\FM.GROUPSPEC (QUOTE GROUP))
(\FM.PROPSPEC (QUOTE PROPS))
(\FM.HJUSTIFY-SPECS (QUOTE (LEFT CENTER RIGHT)))
(\FM.VJUSTIFY-SPECS (QUOTE (TOP MIDDLE BOTTOM)))
(\FM.BOXSPACE 1)
(\FM.ROWSPACE 2)
(\FM.COLUMNSPACE 10)
(\FM.ITEM-TYPES (QUOTE (MOMENTARY TOGGLE 3STATE NWAY STATE NUMBER EDIT EDITSTART DISPLAY)))
(\FM.DESCRIPTION-PROPS (QUOTE (TYPE LABEL LEFT BOTTOM ID GROUPID STATE INITSTATE FONT BITMAP
REGION MAXREGION MESSAGE USERDATA LINKS SYSDOWNFN
SYSMOVEDFN SYSSELECTEDFN DOWNFN HELDFN MOVEDFN SELECTEDFN]
)
)
[DECLARE: EVAL@COMPILE
(DATATYPE FREEMENUITEM
(FM.TYPE FM.LABEL FM.ID FM.GROUPID FM.STATE FM.INITSTATE FM.FONT FM.BITMAP FM.HIGHLIGHT
FM.REGION FM.MAXREGION FM.MESSAGE FM.USERDATA FM.LINKS FM.SYSDOWNFN FM.SYSMOVEDFN
FM.SYSSELECTEDFN FM.DOWNFN FM.HELDFN FM.MOVEDFN FM.SELECTEDFN)
FM.USERDATA ← (LIST NIL)
FM.SYSDOWNFN ← (FUNCTION NILL)
FM.SYSMOVEDFN ← (FUNCTION NILL)
FM.SYSSELECTEDFN ← (FUNCTION NILL))
]
(/DECLAREDATATYPE (QUOTE FREEMENUITEM)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER))
(QUOTE ((FREEMENUITEM 0 POINTER)
(FREEMENUITEM 2 POINTER)
(FREEMENUITEM 4 POINTER)
(FREEMENUITEM 6 POINTER)
(FREEMENUITEM 8 POINTER)
(FREEMENUITEM 10 POINTER)
(FREEMENUITEM 12 POINTER)
(FREEMENUITEM 14 POINTER)
(FREEMENUITEM 16 POINTER)
(FREEMENUITEM 18 POINTER)
(FREEMENUITEM 20 POINTER)
(FREEMENUITEM 22 POINTER)
(FREEMENUITEM 24 POINTER)
(FREEMENUITEM 26 POINTER)
(FREEMENUITEM 28 POINTER)
(FREEMENUITEM 30 POINTER)
(FREEMENUITEM 32 POINTER)
(FREEMENUITEM 34 POINTER)
(FREEMENUITEM 36 POINTER)
(FREEMENUITEM 38 POINTER)
(FREEMENUITEM 40 POINTER)))
(QUOTE 42))
(* FREEMENU WINDOWS)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS \FM.TRANSPOSE MACRO ((POINT OLD NEW)
(FIX (FPLUS .5 (FQUOTIENT (FTIMES POINT NEW)
OLD]
)
)
(DEFINEQ
(\FM.REDISPLAYMENU
[LAMBDA (WINDOW UPDATEREGION) (* jow "26-Jun-86 14:43")
(* RIGHT NOW THIS IS DEPENDENT ON THE
ALIST/PROPLIST STRUCTURE OF GROUPS.)
(if (OPENWP WINDOW)
then (LET (REGION BOX BACKGROUND)
(\FM.RESETCLIPPINGREGION WINDOW) (* back to full window)
(\FM.FILLWINDOW WINDOW (WINDOWPROP WINDOW (QUOTE FM.BACKGROUND)))
[for GROUP in (WINDOWPROP WINDOW (QUOTE FM.GROUPS))
do (* blast all boxes and backgrounds)
(SETQ GROUP (CDR GROUP))
(if (SETQ BOX (LISTGET GROUP (QUOTE BOX)))
then (SETQ REGION (LISTGET GROUP (QUOTE REGION)))
(BLTSHADE (LISTGET GROUP (QUOTE BOXSHADE))
WINDOW NIL NIL NIL NIL NIL REGION)
(BLTSHADE (LISTGET GROUP (QUOTE BACKGROUND))
WINDOW
(IPLUS (fetch (REGION LEFT) of REGION)
BOX)
(IPLUS (fetch (REGION BOTTOM) of REGION)
BOX)
(IDIFFERENCE (fetch (REGION WIDTH) of REGION)
(IPLUS BOX BOX))
(IDIFFERENCE (fetch (REGION HEIGHT) of REGION)
(IPLUS BOX BOX)))
elseif (SETQ BACKGROUND (LISTGET GROUP (QUOTE BACKGROUND)))
then (BLTSHADE BACKGROUND WINDOW NIL NIL NIL NIL NIL (LISTGET
GROUP
(QUOTE REGION]
(for ITEM in (WINDOWPROP WINDOW (QUOTE FM.ITEMS))
do (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE BITMAP))
WINDOW])
(\FM.RESHAPEFN
[LAMBDA (WINDOW B OLDREGION) (* jow "25-Apr-86 11:21")
(if (NOT (WINDOWPROP WINDOW (QUOTE FM.DONTRESHAPE)))
then (\FM.ENDEDIT WINDOW T)
(LET [(OLDWIDTH (fetch (REGION WIDTH) of OLDREGION))
(OLDHEIGHT (fetch (REGION HEIGHT) of OLDREGION))
(NEWWIDTH (WINDOWPROP WINDOW (QUOTE WIDTH)))
(NEWHEIGHT (WINDOWPROP WINDOW (QUOTE HEIGHT)))
(MINWIDTH (WINDOWPROP WINDOW (QUOTE FM.MINWIDTH)))
(MINHEIGHT (WINDOWPROP WINDOW (QUOTE FM.MINHEIGHT]
(COND
((AND (IGEQ OLDWIDTH MINWIDTH)
(IGREATERP NEWWIDTH MINWIDTH))
(\FM.TRANSPOSEHORZ WINDOW OLDWIDTH NEWWIDTH))
((AND (IGREATERP OLDWIDTH MINWIDTH)
(ILEQ NEWWIDTH MINWIDTH)) (* transpose to minimal width)
(\FM.TRANSPOSEHORZ WINDOW OLDWIDTH MINWIDTH))
((AND (ILESSP OLDWIDTH MINWIDTH)
(IGREATERP NEWWIDTH MINWIDTH))
(* transpose from minimal width)
(\FM.TRANSPOSEHORZ WINDOW MINWIDTH NEWWIDTH)))
(COND
((AND (IGEQ OLDHEIGHT MINHEIGHT)
(IGREATERP NEWHEIGHT MINHEIGHT))
(\FM.TRANSPOSEVERT WINDOW OLDHEIGHT NEWHEIGHT))
((AND (IGREATERP OLDHEIGHT MINHEIGHT)
(ILEQ NEWHEIGHT MINHEIGHT))
(* transpose to minimal height)
(\FM.TRANSPOSEVERT WINDOW OLDHEIGHT MINHEIGHT))
((AND (ILESSP OLDHEIGHT MINHEIGHT)
(IGREATERP NEWHEIGHT MINHEIGHT))
(* transpose from minimal height)
(\FM.TRANSPOSEVERT WINDOW MINHEIGHT NEWHEIGHT)))
(\FM.UPDATEGROUPEXTENT (WINDOWPROP WINDOW (QUOTE FM.GROUPS)))
(WINDOWPROP WINDOW (QUOTE EXTENT)
(\FM.WINDOWEXTENT WINDOW))
(* grab new extent)
))
(\FM.UNSCROLLWINDOW WINDOW)
(FM.REDISPLAYMENU WINDOW])
(\FM.UNSCROLLWINDOW
[LAMBDA (WINDOW) (* jow "12-Apr-86 15:22")
(* called after reshaping WINDOW;
resets XOFFSET and YOFFSET to unscroll window Clipping
region set back to copy of full WINDOW)
(DSPXOFFSET [IPLUS (WINDOWPROP WINDOW (QUOTE BORDER))
(fetch (REGION LEFT) of (WINDOWPROP WINDOW (QUOTE REGION]
WINDOW)
(DSPYOFFSET [IPLUS (WINDOWPROP WINDOW (QUOTE BORDER))
(fetch (REGION BOTTOM) of (WINDOWPROP WINDOW (QUOTE REGION]
WINDOW)
(\FM.RESETCLIPPINGREGION WINDOW])
(\FM.RESETCLIPPINGREGION
[LAMBDA (WINDOW) (* jow "10-Apr-86 21:52")
(* reset the clipping region of WINDOW to the windows
full expanse.)
(DSPCLIPPINGREGION (CREATEREGION (IDIFFERENCE (IPLUS (fetch (REGION LEFT)
of (WINDOWPROP WINDOW
(QUOTE
REGION)))
(WINDOWPROP WINDOW (QUOTE BORDER)
))
(DSPXOFFSET NIL WINDOW))
(IDIFFERENCE (IPLUS (fetch (REGION BOTTOM)
of (WINDOWPROP WINDOW
(QUOTE
REGION)))
(WINDOWPROP WINDOW (QUOTE BORDER)
))
(DSPYOFFSET NIL WINDOW))
(WINDOWPROP WINDOW (QUOTE WIDTH))
(WINDOWPROP WINDOW (QUOTE HEIGHT)))
WINDOW])
(\FM.FILLWINDOW
[LAMBDA (WINDOW SHADE) (* jow "11-Apr-86 11:51")
(* fill entire window up to border with shade.
Rely on clippingregion being full window on entry.
Rely on border space is 2 bits.)
(LET ((REGION (DSPCLIPPINGREGION NIL WINDOW)))
(RESETLST (RESETSAVE NIL (LIST (QUOTE DSPCLIPPINGREGION)
REGION WINDOW))
(DSPCLIPPINGREGION (CREATEREGION (IDIFFERENCE (fetch (REGION LEFT)
of REGION)
2)
(IDIFFERENCE (fetch (REGION BOTTOM)
of REGION)
2)
(IPLUS 4 (fetch (REGION WIDTH)
of REGION))
(IPLUS 4 (fetch (REGION HEIGHT)
of REGION)))
WINDOW)
(DSPFILL NIL SHADE NIL WINDOW])
(\FM.INITCORNERSFN
[LAMBDA (WINDOW) (* jow
" 3-Apr-86 23:35")
(* called by SHAPEW to provide the initial corners of the reshape ghost
box, in the form (x1 y1 x2 y2), where 1 is fixed and 2 is tracked.
respond with the freemenus MINIMAL SHAPE leaving left, bottom as they are.)
(LET [[LEFT (fetch (REGION LEFT) of (WINDOWPROP WINDOW (QUOTE REGION]
(BOTTOM (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW (QUOTE REGION]
(LIST LEFT BOTTOM [IPLUS LEFT (WIDTHIFWINDOW (WINDOWPROP WINDOW (QUOTE FM.MINWIDTH))
(WINDOWPROP WINDOW (QUOTE BORDER]
(IPLUS BOTTOM (HEIGHTIFWINDOW (WINDOWPROP WINDOW (QUOTE FM.MINHEIGHT))
(WINDOWPROP WINDOW (QUOTE TITLE))
(WINDOWPROP WINDOW (QUOTE BORDER])
(\FM.TRANSPOSEHORZ
[LAMBDA (WINDOW OLDWIDTH NEWWIDTH) (* jow "12-Apr-86 18:27")
(* transpose left point.)
(for ITEM REGION in (WINDOWPROP WINDOW (QUOTE FM.ITEMS))
do (SETQ REGION (\FM.ITEMPROP ITEM (QUOTE REGION)))
(replace (REGION LEFT) of REGION with (\FM.TRANSPOSE (fetch (REGION LEFT)
of REGION)
OLDWIDTH NEWWIDTH))
(replace (REGION LEFT) of (\FM.ITEMPROP ITEM (QUOTE MAXREGION))
with (fetch (REGION LEFT) of REGION])
(\FM.TRANSPOSEVERT
[LAMBDA (WINDOW OLDHEIGHT NEWHEIGHT) (* jow "12-Apr-86 18:27")
(* transpose bottom point)
(for ITEM REGION in (WINDOWPROP WINDOW (QUOTE FM.ITEMS))
do (SETQ REGION (\FM.ITEMPROP ITEM (QUOTE REGION)))
(replace (REGION BOTTOM) of REGION with (\FM.TRANSPOSE (fetch (REGION BOTTOM)
of REGION)
OLDHEIGHT NEWHEIGHT))
(replace (REGION BOTTOM) of (\FM.ITEMPROP ITEM (QUOTE MAXREGION))
with (fetch (REGION BOTTOM) of REGION])
(\FM.UPDATEGROUPEXTENT
[LAMBDA (GROUPS GROUPLIST) (* jow "12-Apr-86 18:28")
(* THIS DEPENDS ON THE ALIST/PROPLIST GROUP STRUCTURE. GROUPS is a freemenu group alist structure.
GROUPLIST is a list of group id's to update the extent of. If GROUPLIST is NIL, then update top group.)
[OR GROUPLIST (SETQ GROUPLIST (LIST (\FM.DTOPGROUPID GROUPS]
(LET (GROUP REGION DAUGHTERS BOXOFFSET)
(for ID in GROUPLIST
do (SETQ GROUP (CDR (ASSOC ID GROUPS)))
[SETQ REGION (LISTPUT GROUP (QUOTE REGION)
(COPYALL (\FM.ITEMPROP (CAR (LISTGET GROUP
(QUOTE ITEMS))
)
(QUOTE MAXREGION]
[if (SETQ DAUGHTERS (LISTGET GROUP (QUOTE DAUGHTERS)))
then (* update subgroups first)
(\FM.UPDATEGROUPEXTENT GROUPS DAUGHTERS)
(for SUBID in DAUGHTERS do (EXTENDREGION
REGION
(LISTGET (CDR (ASSOC SUBID
GROUPS))
(QUOTE REGION]
[for ITEM in (LISTGET GROUP (QUOTE ITEMS))
do (EXTENDREGION REGION (\FM.ITEMPROP ITEM (QUOTE MAXREGION]
(if (LISTGET GROUP (QUOTE BOX))
then [SETQ BOXOFFSET (IPLUS (LISTGET GROUP (QUOTE BOX))
(LISTGET GROUP (QUOTE BOXSPACE]
(add (fetch (REGION LEFT) of REGION)
(MINUS BOXOFFSET))
(add (fetch (REGION BOTTOM) of REGION)
(MINUS BOXOFFSET))
(add (fetch (REGION WIDTH) of REGION)
(IPLUS BOXOFFSET BOXOFFSET))
(add (fetch (REGION HEIGHT) of REGION)
(IPLUS BOXOFFSET BOXOFFSET])
(\FM.WINDOWEXTENT
[LAMBDA (WINDOW) (* jow "24-Apr-86 17:13")
(* start with the top groups extent, assumed to be
correct, and then extent to account for any infinite
width items. return extended extent)
(LET ([EXTENT (COPY (\FM.TOPGROUPPROP WINDOW (QUOTE REGION]
REGION)
(for ITEM in (WINDOWPROP WINDOW (QUOTE FM.ITEMS)) when (\FM.ITEMPROP ITEM
(QUOTE
INFINITEWIDTH))
do (SETQ REGION (\FM.ITEMPROP ITEM (QUOTE REGION)))
[replace (REGION WIDTH) of REGION with (\FM.ITEMWIDTH (\FM.ITEMPROP
ITEM
(QUOTE LABEL))
(\FM.ITEMPROP
ITEM
(QUOTE FONT]
(EXTENDREGION EXTENT REGION))
EXTENT])
(\FM.UPDATEWINDOWEXTENT
[LAMBDA (WINDOW) (* jow "25-Apr-86 11:38")
(* CURRENTLY NEVER CALLED, BECAUSE PROBLEMS WITH
RECALCULATING MINWIDTH, MINHEIGHT, BECAUSE THIS
ALGORITHM JUST KEEPS ON ADDING.)
(* update the window's extent to the menu's region. If the extent is not entirely visible, then menu has grown.
Update MIN dimensions of menu to allow getting the entire menu visible again.)
(WINDOWPROP WINDOW (QUOTE EXTENT)
(\FM.WINDOWEXTENT WINDOW))
(LET [(EXTENT (WINDOWPROP WINDOW (QUOTE EXTENT]
[if (IGREATERP (fetch (REGION WIDTH) of EXTENT)
(WINDOWPROP WINDOW (QUOTE WIDTH)))
then (WINDOWPROP WINDOW (QUOTE FM.MINWIDTH)
(IPLUS (WINDOWPROP WINDOW (QUOTE FM.MINWIDTH))
(IDIFFERENCE (fetch (REGION WIDTH) of EXTENT)
(WINDOWPROP WINDOW (QUOTE WIDTH]
(if (IGREATERP (fetch (REGION HEIGHT) of EXTENT)
(WINDOWPROP WINDOW (QUOTE HEIGHT)))
then (WINDOWPROP WINDOW (QUOTE FM.MINHEIGHT)
(IPLUS (WINDOWPROP WINDOW (QUOTE FM.MINHEIGHT))
(IDIFFERENCE (fetch (REGION HEIGHT) of EXTENT)
(WINDOWPROP WINDOW (QUOTE HEIGHT])
)
(* MOUSE FUNCTIONS)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS \FM.ONITEM MACRO ((REGION X Y INFINITWIDTH)
(AND (IGEQ Y (fetch (REGION BOTTOM)
of REGION))
(IGEQ X (fetch (REGION LEFT)
of REGION))
[OR INFINITWIDTH (ILESSP X (IPLUS (fetch (REGION LEFT)
of REGION)
(fetch (REGION WIDTH)
of REGION]
(ILESSP Y (IPLUS (fetch (REGION BOTTOM)
of REGION)
(fetch (REGION HEIGHT)
of REGION]
[PUTPROPS \FM.CHECKREGION MACRO ((WINDOW X Y)
(for (ITEM REGION)
in
(WINDOWPROP WINDOW (QUOTE FM.ITEMS))
eachtime
(SETQ REGION (\FM.ITEMPROP ITEM (QUOTE REGION)))
thereis
(\FM.ONITEM REGION X Y (\FM.ITEMPROP ITEM (QUOTE INFINITEWIDTH]
)
)
(DEFINEQ
(\FM.WINDOWENTRYFN
[LAMBDA (WINDOW) (* jow "20-Oct-86 10:51")
(* ;;;
"THIS SHOULD NEVER GET CALLED NOW, BECAUSE FREEMENU DUMPS THE EDIT WHEN IT LOSES THE TTY.")
(* called when buttonevent occurs while editing with the tty process somewhere
else. should give the tty back to freemenu unless the event is right only and
not on an item. in that case, just do the window command menu.
don't worry here about calling buttoneventfn's, because once freemenu gets the
tty back, the edit button handler will notice the event and act properly.)
(if [AND (LASTMOUSESTATE (ONLY RIGHT))
(NOT (AND (INSIDEP (DSPCLIPPINGREGION NIL WINDOW)
(LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW))
(\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW]
then (DOWINDOWCOM WINDOW)
else (TTY.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS])
(\FM.BUTTONEVENTFN
[LAMBDA (WINDOW) (* jow
"13-Nov-85 22:08")
(TOTOPW WINDOW)
(if (AND (NOT (WINDOWPROP WINDOW (QUOTE FM.BUSY)))
(LASTMOUSESTATE (NOT UP)))
then (* ignore button up
events and events when
menu is busy)
(\FM.MENUHANDLER WINDOW])
(\FM.RIGHTBUTTONFN
[LAMBDA (WINDOW) (* jow "10-Apr-86 22:38")
(* if on an item, and not busy, then process the item
selection, else do the window command menu.)
(TOTOPW WINDOW)
(if (AND (INSIDEP (DSPCLIPPINGREGION NIL WINDOW)
(LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW))
(\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW)))
then (* valid item selected)
(if (NOT (WINDOWPROP WINDOW (QUOTE FM.BUSY)))
then (\FM.MENUHANDLER WINDOW))
else (* not on item)
(DOWINDOWCOM WINDOW])
(\FM.DOSELECTION
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "17-Oct-86 17:06")
(* ;;;
"run the selectedfns for this ITEM. set busy flag accordingly. ")
(RESETLST (RESETSAVE NIL (LIST (QUOTE WINDOWPROP)
WINDOW
(QUOTE FM.BUSY)
NIL))
(WINDOWPROP WINDOW (QUOTE FM.BUSY)
T)
(APPLY* (\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN))
ITEM WINDOW BUTTONS)
(BLOCK)
(APPLY* (\FM.ITEMPROP ITEM (QUOTE SELECTEDFN))
ITEM WINDOW BUTTONS) (* ;;
"return NIL so that result of process can't point to itself.")
NIL])
(\FM.MENUHANDLER
[LAMBDA (WINDOW SAMEPROCESS) (* jow "20-Oct-86 10:48")
(repeatuntil (MOUSESTATE UP) bind (TIMER ← (SETUPTIMER 0))
ITEM LASTITEM BUTTONS PROMPTFLG
do (SETQ BUTTONS (DECODEBUTTONS))
(SETQ LASTITEM ITEM)
(SETQ ITEM (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW)))
(if ITEM
then (COND
((NOT LASTITEM) (* moved on new item)
(APPLY* (\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN))
ITEM WINDOW BUTTONS)
(APPLY* (\FM.ITEMPROP ITEM (QUOTE DOWNFN))
ITEM WINDOW BUTTONS)
(SETUPTIMER MENUHELDWAIT TIMER)
(SETQ PROMPTFLG T))
((NEQ LASTITEM ITEM) (* jump between items without dead
interval. call last mouseoff, and new
mousedown)
(APPLY* (\FM.ITEMPROP LASTITEM (QUOTE SYSMOVEDFN))
LASTITEM WINDOW BUTTONS)
(APPLY* (\FM.ITEMPROP LASTITEM (QUOTE MOVEDFN))
LASTITEM WINDOW BUTTONS)
(APPLY* (\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN))
ITEM WINDOW BUTTONS)
(APPLY* (\FM.ITEMPROP ITEM (QUOTE DOWNFN))
ITEM WINDOW BUTTONS)
(SETUPTIMER MENUHELDWAIT TIMER)
(SETQ PROMPTFLG T))
((AND PROMPTFLG (TIMEREXPIRED? TIMER)) (* held on item long enough)
(PRINTOUT (OR (WINDOWPROP WINDOW (QUOTE FM.PROMPTWINDOW))
PROMPTWINDOW)
T
(if (STRINGP (\FM.ITEMPROP ITEM (QUOTE MESSAGE)))
then (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
else (APPLY* (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
ITEM WINDOW BUTTONS)))
(SETQ PROMPTFLG NIL)))
(APPLY* (\FM.ITEMPROP ITEM (QUOTE HELDFN))
ITEM WINDOW BUTTONS)
elseif LASTITEM
then (* moved off item)
(APPLY* (\FM.ITEMPROP LASTITEM (QUOTE SYSMOVEDFN))
LASTITEM WINDOW BUTTONS)
(APPLY* (\FM.ITEMPROP LASTITEM (QUOTE MOVEDFN))
LASTITEM WINDOW BUTTONS))
finally (SETQ LASTITEM ITEM)
(SETQ ITEM (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW)
(LASTMOUSEY WINDOW)))
(if LASTITEM
then (COND
((NEQ LASTITEM ITEM) (* moved off item)
(APPLY* (\FM.ITEMPROP LASTITEM (QUOTE SYSMOVEDFN))
LASTITEM WINDOW BUTTONS)
(APPLY* (\FM.ITEMPROP LASTITEM (QUOTE MOVEDFN))
LASTITEM WINDOW BUTTONS))
(ITEM (if SAMEPROCESS
then (\FM.DOSELECTION ITEM WINDOW BUTTONS)
else (ADD.PROCESS [BQUOTE (\FM.DOSELECTION (QUOTE (\, ITEM))
(QUOTE (\, WINDOW))
(QUOTE (\, BUTTONS]
(QUOTE NAME)
(QUOTE FREEMENU)
(QUOTE FREEMENU.PROCESS)
T])
)
(* ITEM SUPPORT FUNCTIONS)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS \FM.DISPLAYBITMAP MACRO ((ITEM BITMAP WINDOW)
(* take care of background shade and display the item)
(IF (OPENWP WINDOW)
THEN
(BLTSHADE (\FM.ITEMPROP ITEM (QUOTE BACKGROUND))
WINDOW NIL NIL NIL NIL NIL (\FM.ITEMPROP ITEM
(QUOTE MAXREGION)))
(BITBLT BITMAP 0 0 WINDOW (fetch (REGION LEFT)
of
(\FM.ITEMPROP ITEM
(QUOTE REGION)))
(fetch (REGION BOTTOM)
of
(\FM.ITEMPROP ITEM (QUOTE REGION)))
NIL NIL NIL (QUOTE PAINT]
[PUTPROPS \FM.COERCEITEMPTR MACRO ((ITEMPTR WINDOW ITEM)
(LET (GROUPID ITEMID)
(if (LISTP ITEMPTR)
then
(* pull apart)
(SETQ GROUPID (CAR ITEMPTR))
(SETQ ITEMID (CADR ITEMPTR)))
[if (EQ \FM.GROUPSPEC GROUPID)
then
(* DOES NOT TYPE CHECK ITEM. IF USED ITEM MUST BE A
FREEMENUITEM.)
(SETQ GROUPID (\FM.ITEMPROP ITEM (QUOTE GROUPID]
(OR (FM.GETITEM (OR ITEMID ITEMPTR)
GROUPID WINDOW)
(ERROR "Could not find item:" ITEMPTR]
)
)
(DEFINEQ
(\FM.GETITEMPROP
[LAMBDA (ITEM PROP) (* jow "11-Apr-86 11:40")
(* BACKGROUND (fetch (FREEMENUITEM FM.BACKGROUND) of
ITEM))
(* ATTACHPOINT (fetch (FREEMENUITEM FM.ATTACHPOINT) of
ITEM))
(SELECTQ PROP
(TYPE (fetch (FREEMENUITEM FM.TYPE) of ITEM))
(LABEL (fetch (FREEMENUITEM FM.LABEL) of ITEM))
(ID (fetch (FREEMENUITEM FM.ID) of ITEM))
(GROUPID (fetch (FREEMENUITEM FM.GROUPID) of ITEM))
(STATE (fetch (FREEMENUITEM FM.STATE) of ITEM))
(INITSTATE (fetch (FREEMENUITEM FM.INITSTATE) of ITEM))
(FONT (fetch (FREEMENUITEM FM.FONT) of ITEM))
(BITMAP (fetch (FREEMENUITEM FM.BITMAP) of ITEM))
(HIGHLIGHT (fetch (FREEMENUITEM FM.HIGHLIGHT) of ITEM))
(REGION (fetch (FREEMENUITEM FM.REGION) of ITEM))
(MAXREGION (fetch (FREEMENUITEM FM.MAXREGION) of ITEM))
(MESSAGE (fetch (FREEMENUITEM FM.MESSAGE) of ITEM))
(USERDATA (fetch (FREEMENUITEM FM.USERDATA) of ITEM))
(LINKS (fetch (FREEMENUITEM FM.LINKS) of ITEM))
(SYSDOWNFN (fetch (FREEMENUITEM FM.SYSDOWNFN) of ITEM))
(SYSMOVEDFN (fetch (FREEMENUITEM FM.SYSMOVEDFN) of ITEM))
(SYSSELECTEDFN (fetch (FREEMENUITEM FM.SYSSELECTEDFN) of ITEM))
(DOWNFN (fetch (FREEMENUITEM FM.DOWNFN) of ITEM))
(HELDFN (fetch (FREEMENUITEM FM.HELDFN) of ITEM))
(MOVEDFN (fetch (FREEMENUITEM FM.MOVEDFN) of ITEM))
(SELECTEDFN (fetch (FREEMENUITEM FM.SELECTEDFN) of ITEM))
(LISTGET (fetch (FREEMENUITEM FM.USERDATA) of ITEM)
PROP])
(\FM.PUTITEMPROP
[LAMBDA (ITEM PROP VALUE) (* jow "11-Apr-86 11:41")
(* store new value in item field)
(* BACKGROUND (PROG1 (fetch
(FREEMENUITEM FM.BACKGROUND) of ITEM)
(replace (FREEMENUITEM FM.BACKGROUND) of ITEM with
VALUE)))
(* ATTACHPOINT (PROG1 (fetch
(FREEMENUITEM FM.ATTACHPOINT) of ITEM)
(replace (FREEMENUITEM FM.ATTACHPOINT) of ITEM with
VALUE)))
(SELECTQ PROP
(TYPE (ERROR "Can't change the TYPE of an item" VALUE))
(LABEL (PROG1 (fetch (FREEMENUITEM FM.LABEL) of ITEM)
(replace (FREEMENUITEM FM.LABEL) of ITEM with VALUE)))
(ID (PROG1 (fetch (FREEMENUITEM FM.ID) of ITEM)
(replace (FREEMENUITEM FM.ID) of ITEM with VALUE)))
(GROUPID (fetch (FREEMENUITEM FM.GROUPID) of ITEM)
(replace (FREEMENUITEM FM.GROUPID) of ITEM with VALUE))
(STATE (PROG1 (fetch (FREEMENUITEM FM.STATE) of ITEM)
(replace (FREEMENUITEM FM.STATE) of ITEM with VALUE)))
(INITSTATE (PROG1 (fetch (FREEMENUITEM FM.INITSTATE) of ITEM)
(replace (FREEMENUITEM FM.INITSTATE) of ITEM with VALUE)))
(FONT (PROG1 (fetch (FREEMENUITEM FM.FONT) of ITEM)
(replace (FREEMENUITEM FM.FONT) of ITEM with VALUE)))
(BITMAP (PROG1 (fetch (FREEMENUITEM FM.BITMAP) of ITEM)
(replace (FREEMENUITEM FM.BITMAP) of ITEM with VALUE)))
(HIGHLIGHT (PROG1 (fetch (FREEMENUITEM FM.HIGHLIGHT) of ITEM)
(replace (FREEMENUITEM FM.HIGHLIGHT) of ITEM with VALUE)))
(REGION (PROG1 (fetch (FREEMENUITEM FM.REGION) of ITEM)
(replace (FREEMENUITEM FM.REGION) of ITEM with VALUE)))
(MAXREGION (PROG1 (fetch (FREEMENUITEM FM.MAXREGION) of ITEM)
(replace (FREEMENUITEM FM.MAXREGION) of ITEM with VALUE)))
(MESSAGE (PROG1 (fetch (FREEMENUITEM FM.MESSAGE) of ITEM)
(replace (FREEMENUITEM FM.MESSAGE) of ITEM with VALUE)))
(USERDATA (ERROR "Can't change the USERDATA of an item" VALUE))
(LINKS (PROG1 (fetch (FREEMENUITEM FM.LINKS) of ITEM)
(replace (FREEMENUITEM FM.LINKS) of ITEM with VALUE)))
(SYSDOWNFN (PROG1 (fetch (FREEMENUITEM FM.SYSDOWNFN) of ITEM)
(replace (FREEMENUITEM FM.SYSDOWNFN) of ITEM with VALUE)))
(SYSMOVEDFN (PROG1 (fetch (FREEMENUITEM FM.SYSMOVEDFN) of ITEM)
(replace (FREEMENUITEM FM.SYSMOVEDFN) of ITEM with VALUE)))
(SYSSELECTEDFN (PROG1 (fetch (FREEMENUITEM FM.SYSSELECTEDFN) of ITEM)
(replace (FREEMENUITEM FM.SYSSELECTEDFN) of ITEM
with VALUE)))
(DOWNFN (PROG1 (fetch (FREEMENUITEM FM.DOWNFN) of ITEM)
(replace (FREEMENUITEM FM.DOWNFN) of ITEM with VALUE)))
(HELDFN (PROG1 (fetch (FREEMENUITEM FM.HELDFN) of ITEM)
(replace (FREEMENUITEM FM.HELDFN) of ITEM with VALUE)))
(MOVEDFN (PROG1 (fetch (FREEMENUITEM FM.MOVEDFN) of ITEM)
(replace (FREEMENUITEM FM.MOVEDFN) of ITEM with VALUE)))
(SELECTEDFN (PROG1 (fetch (FREEMENUITEM FM.SELECTEDFN) of ITEM)
(replace (FREEMENUITEM FM.SELECTEDFN) of ITEM with VALUE)))
(PROG1 (LISTGET (fetch (FREEMENUITEM FM.USERDATA) of ITEM)
PROP)
(LISTPUT (fetch (FREEMENUITEM FM.USERDATA) of ITEM)
PROP VALUE])
(\FM.CGETITEMPROP
[LAMBDA (ITEM PROP) (* jow "12-Apr-86 16:13")
(* macro dispatch function for FM.ITEMPROP. ITEM is bound to the name of the item to be visited, and PROP is bound
to the expression (QUOTE <FIELDNAME>). This function returns the appropriate fetchfield expression to be compiled.
IF THE FREEMENUITEM RECORD IS CHANGED,THIS FUNCTION MUST BE CHANGED ACCORDINGLY)
(* BACKGROUND (BQUOTE (FETCH
(FREEMENUITEM FM.BACKGROUND) OF
(\FM.INSUREFM , ITEM))))
(* ATTACHPOINT (BQUOTE (FETCH
(FREEMENUITEM FM.ATTACHPOINT) OF
(\FM.INSUREFM , ITEM))))
(SELECTQ (CADR PROP)
(TYPE (BQUOTE (FETCH (FREEMENUITEM FM.TYPE) OF , ITEM)))
(LABEL (BQUOTE (FETCH (FREEMENUITEM FM.LABEL) OF , ITEM)))
(ID (BQUOTE (FETCH (FREEMENUITEM FM.ID) OF , ITEM)))
(GROUPID (BQUOTE (FETCH (FREEMENUITEM FM.GROUPID) OF , ITEM)))
(STATE (BQUOTE (FETCH (FREEMENUITEM FM.STATE) OF , ITEM)))
(INITSTATE (BQUOTE (FETCH (FREEMENUITEM FM.INITSTATE) OF , ITEM)))
(FONT (BQUOTE (FETCH (FREEMENUITEM FM.FONT) OF , ITEM)))
(BITMAP (BQUOTE (FETCH (FREEMENUITEM FM.BITMAP) OF , ITEM)))
(HIGHLIGHT (BQUOTE (FETCH (FREEMENUITEM FM.HIGHLIGHT) OF , ITEM)))
(REGION (BQUOTE (FETCH (FREEMENUITEM FM.REGION) OF , ITEM)))
(MAXREGION (BQUOTE (FETCH (FREEMENUITEM FM.MAXREGION) OF , ITEM)))
(MESSAGE (BQUOTE (FETCH (FREEMENUITEM FM.MESSAGE) OF , ITEM)))
(USERDATA (BQUOTE (FETCH (FREEMENUITEM FM.USERDATA) OF , ITEM)))
(LINKS (BQUOTE (FETCH (FREEMENUITEM FM.LINKS) OF , ITEM)))
(SYSDOWNFN (BQUOTE (FETCH (FREEMENUITEM FM.SYSDOWNFN) OF , ITEM)))
(SYSMOVEDFN (BQUOTE (FETCH (FREEMENUITEM FM.SYSMOVEDFN) OF , ITEM)))
(SYSSELECTEDFN (BQUOTE (FETCH (FREEMENUITEM FM.SYSSELECTEDFN) OF , ITEM)))
(DOWNFN (BQUOTE (FETCH (FREEMENUITEM FM.DOWNFN) OF , ITEM)))
(HELDFN (BQUOTE (FETCH (FREEMENUITEM FM.HELDFN) OF , ITEM)))
(MOVEDFN (BQUOTE (FETCH (FREEMENUITEM FM.MOVEDFN) OF , ITEM)))
(SELECTEDFN (BQUOTE (FETCH (FREEMENUITEM FM.SELECTEDFN) OF , ITEM)))
(BQUOTE (LISTGET (FETCH (FREEMENUITEM FM.USERDATA) OF , ITEM)
(QUOTE , (CADR PROP])
(\FM.CPUTITEMPROP
[LAMBDA (ITEM PROP VALUE) (* jow "12-Apr-86 16:10")
(* macro dispatch function for FM.ITEMPROP. ITEM is bound to the name of the item to be visited, PROP is bound to
the expression ((QUOTE <FIELDNAME>) , and VALUE is bound to the expression to be evaluated at run time to yield the
newvalue.) This function returns the appropriate prog1 expression to be compiled, which will return the old value,
and set the new value of an item prop. IF THE FREEMENUITEM RECORD IS CHANGED,THIS FUNCTION MUST BE CHANGED
ACCORDINGLY)
(* BACKGROUND (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.BACKGROUND) OF (\FM.INSUREFM , ITEM))
(REPLACE (FREEMENUITEM FM.BACKGROUND) OF , ITEM WITH , VALUE))))
(* ATTACHPOINT (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.ATTACHPOINT) OF (\FM.INSUREFM , ITEM))
(REPLACE (FREEMENUITEM FM.ATTACHPOINT) OF , ITEM WITH , VALUE))))
(SELECTQ (CADR PROP)
(TYPE (ERROR "FreeMenuItem property TYPE not settable" (LIST (QUOTE FM.ITEMPROP)
ITEM PROP VALUE)))
[LABEL (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.LABEL) OF , ITEM)
(REPLACE (FREEMENUITEM FM.LABEL) OF , ITEM
WITH , VALUE]
[ID (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.ID) OF , ITEM)
(REPLACE (FREEMENUITEM FM.ID) OF , ITEM WITH , VALUE]
[GROUPID (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.GROUPID) OF , ITEM)
(REPLACE (FREEMENUITEM FM.GROUPID) OF , ITEM
WITH , VALUE]
[STATE (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.STATE) OF , ITEM)
(REPLACE (FREEMENUITEM FM.STATE) OF , ITEM
WITH , VALUE]
[INITSTATE (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.INITSTATE) OF , ITEM)
(REPLACE (FREEMENUITEM FM.INITSTATE) OF , ITEM
WITH , VALUE]
[FONT (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.FONT) OF , ITEM)
(REPLACE (FREEMENUITEM FM.FONT) OF , ITEM
WITH , VALUE]
[BITMAP (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.BITMAP) OF , ITEM)
(REPLACE (FREEMENUITEM FM.BITMAP) OF , ITEM
WITH , VALUE]
[HIGHLIGHT (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.HIGHLIGHT) OF , ITEM)
(REPLACE (FREEMENUITEM FM.HIGHLIGHT) OF , ITEM
WITH , VALUE]
[REGION (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.REGION) OF , ITEM)
(REPLACE (FREEMENUITEM FM.REGION) OF , ITEM
WITH , VALUE]
[MAXREGION (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.MAXREGION) OF , ITEM)
(REPLACE (FREEMENUITEM FM.MAXREGION) OF , ITEM
WITH , VALUE]
[MESSAGE (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.MESSAGE) OF , ITEM)
(REPLACE (FREEMENUITEM FM.MESSAGE) OF , ITEM
WITH , VALUE]
(USERDATA (ERROR "FreeMenuItem property USERDATA not settable" (LIST (QUOTE
FM.ITEMPROP)
ITEM PROP
VALUE)))
[LINKS (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.LINKS) OF , ITEM)
(REPLACE (FREEMENUITEM FM.LINKS) OF , ITEM
WITH , VALUE]
[SYSDOWNFN (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.SYSDOWNFN) OF , ITEM)
(REPLACE (FREEMENUITEM FM.SYSDOWNFN) OF , ITEM
WITH , VALUE]
[SYSMOVEDFN (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.SYSMOVEDFN) OF , ITEM)
(REPLACE (FREEMENUITEM FM.SYSMOVEDFN)
OF , ITEM WITH , VALUE]
[SYSSELECTEDFN (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.SYSSELECTEDFN)
OF , ITEM)
(REPLACE (FREEMENUITEM FM.SYSSELECTEDFN)
OF , ITEM WITH , VALUE]
[DOWNFN (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.DOWNFN) OF , ITEM)
(REPLACE (FREEMENUITEM FM.DOWNFN) OF , ITEM
WITH , VALUE]
[HELDFN (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.HELDFN) OF , ITEM)
(REPLACE (FREEMENUITEM FM.HELDFN) OF , ITEM
WITH , VALUE]
[MOVEDFN (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.MOVEDFN) OF , ITEM)
(REPLACE (FREEMENUITEM FM.MOVEDFN) OF , ITEM
WITH , VALUE]
[SELECTEDFN (BQUOTE (PROG1 (FETCH (FREEMENUITEM FM.SELECTEDFN) OF , ITEM)
(REPLACE (FREEMENUITEM FM.SELECTEDFN)
OF , ITEM WITH , VALUE]
(BQUOTE (PROG1 (LISTGET (FETCH (FREEMENUITEM FM.USERDATA) OF , ITEM)
(QUOTE , (CADR PROP)))
(LISTPUT (FETCH (FREEMENUITEM FM.USERDATA) OF , ITEM)
(QUOTE , (CADR PROP))
, VALUE])
(\FM.DISPLAYITEM
[LAMBDA (ITEM WINDOW) (* jow "26-Jun-86 14:52")
(\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE BITMAP))
WINDOW])
(\FM.HIGHLIGHTITEM
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "26-Jun-86 14:52")
(\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT))
WINDOW])
(\FM.CHANGELABEL
[LAMBDA (ITEM NEWLABEL) (* jow "24-Apr-86 22:56")
(* change the items label. NEWDESC is a description of the new item. This includes the items USERDATA list, which
has in it all of the boxing info necessary for changing the label. Do not redisplay)
(OR (OR (ATOM NEWLABEL)
(STRINGP NEWLABEL)
(BITMAPP NEWLABEL))
(ERROR "CHANGELABEL Error. NEWLABEL must be an atom, string, or bitmap." NEWLABEL))
(LET ((FONT (\FM.ITEMPROP ITEM (QUOTE FONT)))
[LEFT (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM (QUOTE REGION]
[BOTTOM (fetch (REGION BOTTOM) of (\FM.ITEMPROP ITEM (QUOTE REGION]
[NEWDESC (APPEND (LIST (QUOTE LABEL)
NEWLABEL)
(\FM.ITEMPROP ITEM (QUOTE USERDATA]
REGIONS BITMAPS)
(SETQ REGIONS (\FM.GETREGIONS NEWDESC LEFT BOTTOM FONT))
(SETQ BITMAPS (\FM.GETBITMAPS NEWDESC FONT (CAR REGIONS)
(CADR REGIONS)))
(\FM.ITEMPROP ITEM (QUOTE LABEL)
NEWLABEL)
(\FM.ITEMPROP ITEM (QUOTE REGION)
(CAR REGIONS))
(\FM.ITEMPROP ITEM (QUOTE MAXREGION)
(CADDR REGIONS))
(\FM.ITEMPROP ITEM (QUOTE BITMAP)
(CAR BITMAPS))
(\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT)
(CADR BITMAPS))
(SELECTQ (\FM.ITEMPROP ITEM (QUOTE TYPE))
[EDIT (* use maxregion always)
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE MAXREGION]
(NUMBER (* make state a number)
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE MAXREGION)))
(\FM.NUMBER-CHANGESTATE ITEM NEWLABEL))
[TOGGLE (* reset state bitmaps)
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)
(\FM.ITEMPROP ITEM (QUOTE BITMAP]
(3STATE (* reset state bitmaps)
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)
(\FM.ITEMPROP ITEM (QUOTE BITMAP)))
(\FM.3STATE-SETUPOFFBITMAP ITEM))
[NWAY (* reset state bitmaps)
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)
(\FM.ITEMPROP ITEM (QUOTE BITMAP]
NIL])
(\FM.CHANGESTATE
[LAMBDA (X NEWSTATE WINDOW) (* jow "25-Apr-86 14:51")
(* user interface to change the state of any
(state) item or nway collection.
Redisplay the item if the window is open)
(if (ASSOC X (WINDOWPROP WINDOW (QUOTE FM.NWAYS)))
then (* X specifies an NWAY. Changestate and redisplay.)
(\FM.NWAY-CHANGESTATE X NEWSTATE WINDOW)
else (* treat X as an item)
(SELECTQ (\FM.ITEMPROP X (QUOTE TYPE))
(TOGGLE (\FM.TOGGLE-CHANGESTATE X NEWSTATE))
(3STATE (\FM.3STATE-CHANGESTATE X NEWSTATE))
(STATE (\FM.STATE-CHANGESTATE X NEWSTATE WINDOW))
(EDIT (\FM.CHANGELABEL X NEWSTATE))
(NUMBER (\FM.CHANGELABEL X NEWSTATE))
NIL])
(\FM.ENDEDIT
[LAMBDA (WINDOW WAITFLG) (* jow "20-Oct-86 10:56")
(* ;;; "used as a closefn for freemenu, as well as for ending edits as necessary during button events. Will kill the edit process and wait as requested. If editing, the freemenu process must be the ttyprocess.")
(if (FM.EDITP WINDOW)
then (SETUPTIMER 0 (WINDOWPROP WINDOW (QUOTE FM.EDIT-TIMER)))
(LET ((FM.PROCESS (TTY.PROCESS)))
(if (PROCESSPROP FM.PROCESS (QUOTE FREEMENU.PROCESS))
then (if (NEQ (THIS.PROCESS)
FM.PROCESS)
then (PROCESS.RESULT FM.PROCESS WAITFLG))
else (ERROR "Can't find freemenu process to end editing" FM.PROCESS])
(\FM.INSUREVISIBLE
[LAMBDA (ITEM WINDOW) (* jow "25-Apr-86 12:04")
(if [NOT (SUBREGIONP (DSPCLIPPINGREGION NIL WINDOW)
(\FM.ITEMPROP ITEM (QUOTE REGION]
then (* not all of ITEM is visible: ensure that left of
item is in window)
(SCROLLW WINDOW [FQUOTIENT (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM
(QUOTE
REGION)))
(fetch (REGION WIDTH) of (WINDOWPROP
WINDOW
(QUOTE EXTENT]
0])
(\FM.CLEARITEM
[LAMBDA (ITEM WINDOW REGION) (* jow "26-Jun-86 14:50")
(* clear an item in the window. If INFINITEWIDTH, then clear to edge of window.
Don't change the item. REGION defaults to items current region, and may be
passed as an arg, in order to clear an "old" region for the item.)
(if (OPENWP WINDOW)
then [OR REGION (SETQ REGION (\FM.ITEMPROP ITEM (QUOTE REGION]
(if (\FM.ITEMPROP ITEM (QUOTE INFINITEWIDTH))
then (BLTSHADE (\FM.ITEMPROP ITEM (QUOTE BACKGROUND))
WINDOW
(fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
NIL
(fetch (REGION HEIGHT) of REGION))
else (BLTSHADE (\FM.ITEMPROP ITEM (QUOTE BACKGROUND))
WINDOW NIL NIL NIL NIL NIL REGION])
)
(* MOMENTARY ITEM FUNCTIONS)
(DEFINEQ
(\FM.MOMENTARY-SETUP
[LAMBDA (ITEM) (* jow "17-Apr-86 18:16")
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
"Will select this item when you release the button."))
(\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN)
(QUOTE \FM.HIGHLIGHTITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSMOVEDFN)
(QUOTE \FM.DISPLAYITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.MOMENTARY-SELECTEDFN])
(\FM.MOMENTARY-SELECTEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "19-Apr-86 22:00")
(* setup unhighlighting on the way out by puttin in a
resetsave. we know we got called from \fm.doselection,
which RESETLISTs.)
(RESETSAVE NIL (LIST (QUOTE \FM.DISPLAYITEM)
ITEM WINDOW])
)
(* TOGGLE ITEM FUNCTIONS)
(DEFINEQ
(\FM.TOGGLE-SETUP
[LAMBDA (ITEM REGIONS) (* jow "18-Apr-86 12:22")
(* toggle items initial state NIL)
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
"Will toggle this item when you release the button."))
(\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN)
(FUNCTION \FM.TOGGLE-DOWNFN))
(\FM.ITEMPROP ITEM (QUOTE SYSMOVEDFN)
(FUNCTION \FM.DISPLAYITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.TOGGLE-SELECTEDFN)) (* save unhighlighted looks.)
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)
(\FM.ITEMPROP ITEM (QUOTE BITMAP))) (* save regions for state changes.)
(if [AND (CADR REGIONS)
(NOT (EQUAL (CADR REGIONS)
(\FM.ITEMPROP ITEM (QUOTE REGION]
then (\FM.ITEMPROP ITEM (QUOTE OFFREGION)
(\FM.ITEMPROP ITEM (QUOTE REGION)))
(\FM.ITEMPROP ITEM (QUOTE ONREGION)
(CADR REGIONS])
(\FM.TOGGLE-DOWNFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:08")
(* display the other state in the window.
Can't just invert item in window, because "highlight"
may be shade other than black.)
(if (\FM.ITEMPROP ITEM (QUOTE STATE))
then (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT))
WINDOW)
else (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT))
WINDOW])
(\FM.TOGGLE-SELECTEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 16:54")
(* change item to new state.
display already updated)
(if (\FM.ITEMPROP ITEM (QUOTE STATE))
then (\FM.TOGGLE-CHANGESTATE ITEM NIL)
else (\FM.TOGGLE-CHANGESTATE ITEM T])
(\FM.TOGGLE-CHANGESTATE
[LAMBDA (ITEM NEWSTATE) (* jow "18-Apr-86 12:22")
(\FM.ITEMPROP ITEM (QUOTE STATE)
NEWSTATE)
(if NEWSTATE
then (\FM.ITEMPROP ITEM (QUOTE BITMAP)
(\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT)))
[AND (\FM.ITEMPROP ITEM (QUOTE ONREGION))
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE ONREGION]
else (\FM.ITEMPROP ITEM (QUOTE BITMAP)
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)))
(AND (\FM.ITEMPROP ITEM (QUOTE OFFREGION))
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE OFFREGION])
)
(* 3STATE ITEM FUNCTIONS)
(DEFINEQ
(\FM.3STATE-SETUP
[LAMBDA (ITEM REGIONS) (* jow "18-Apr-86 14:40")
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
"Will change item to this state when you release the button."))
(\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN)
(FUNCTION \FM.3STATE-DOWNFN))
(\FM.ITEMPROP ITEM (QUOTE SYSMOVEDFN)
(FUNCTION \FM.DISPLAYITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.3STATE-SELECTEDFN)) (* save the unhighlighted bitmap.)
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)
(\FM.ITEMPROP ITEM (QUOTE BITMAP))) (* save regions for state changes.)
(if [AND (CADR REGIONS)
(NOT (EQUAL (CADR REGIONS)
(\FM.ITEMPROP ITEM (QUOTE REGION]
then (\FM.ITEMPROP ITEM (QUOTE NEUTRALREGION)
(\FM.ITEMPROP ITEM (QUOTE REGION)))
(\FM.ITEMPROP ITEM (QUOTE ONREGION)
(CADR REGIONS)))
(\FM.3STATE-SETUPOFFBITMAP ITEM])
(\FM.3STATE-SETUPOFFBITMAP
[LAMBDA (ITEM) (* jow "24-Apr-86 23:01")
(* used by 3state items to setup bitmap with OFF
looks.)
(LET* ((OFF (\FM.ITEMPROP ITEM (QUOTE OFF)))
(BOX (OR (\FM.ITEMPROP ITEM (QUOTE BOX))
0))
(FONT (\FM.ITEMPROP ITEM (QUOTE FONT)))
(OFFREGION (\FM.ITEMPROP ITEM (QUOTE REGION)))
ID OFFBITMAP)
(COND
((OR (AND OFF (ATOM OFF)
(NOT (TEXTUREP OFF)))
(STRINGP OFF)
(BITMAPP OFF)) (* new label specified. make anew)
(* Set REGION of OFF looks: build item description that has OFF has its HIGHLIGHT prop. Then pass to GETREGIONS
(so lie a bit) to get the region of the OFF looks.)
[SETQ ID (COPY (\FM.ITEMPROP ITEM (QUOTE USERDATA]
(LISTPUT ID (QUOTE HIGHLIGHT)
OFF)
(SETQ OFFREGION (CADR (\FM.GETREGIONS ID (fetch (REGION LEFT) of OFFREGION)
(fetch (REGION BOTTOM) of OFFREGION)
FONT)))
(SETQ OFFBITMAP (\FM.MAKEBITMAP OFF FONT (fetch (REGION WIDTH) of OFFREGION)
(fetch (REGION HEIGHT) of OFFREGION)
ID))
(\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT)
(LIST (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT))
OFFBITMAP))
(if [NOT (EQUAL OFFREGION (\FM.ITEMPROP ITEM (QUOTE REGION]
then (* different region for OFF looks.
Save regions for changing state)
(\FM.ITEMPROP ITEM (QUOTE NEUTRALREGION)
(\FM.ITEMPROP ITEM (QUOTE REGION)))
(\FM.ITEMPROP ITEM (QUOTE OFFREGION)
OFFREGION)
(EXTENDREGION (\FM.ITEMPROP ITEM (QUOTE MAXREGION))
OFFREGION)))
((TEXTUREP OFF) (* paint shade on label)
[SETQ OFFBITMAP (BITMAPCOPY (\FM.ITEMPROP ITEM (QUOTE BITMAP]
(BLTSHADE OFF OFFBITMAP BOX BOX (IDIFFERENCE (fetch (REGION WIDTH) of OFFREGION)
(ITIMES BOX 2))
(IDIFFERENCE (fetch (REGION HEIGHT) of OFFREGION)
(ITIMES BOX 2))
(QUOTE PAINT))
(\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT)
(LIST (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT))
OFFBITMAP)))
(T (* default: draw slash on label)
[SETQ OFFBITMAP (BITMAPCOPY (\FM.ITEMPROP ITEM (QUOTE BITMAP]
(LET ((STREAM (DSPCREATE OFFBITMAP)))
(DRAWLINE 0 0 (SUB1 (fetch (REGION WIDTH) of OFFREGION))
(IDIFFERENCE (fetch (REGION HEIGHT) of OFFREGION)
2)
2
(QUOTE REPLACE)
STREAM)
(\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT)
(LIST (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT))
OFFBITMAP])
(\FM.3STATE-DOWNFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "16-Apr-86 17:58")
(* called when mouse down over 3state item.
rotates the state of ITEM on the screen.
The order is OFF -
NIL -
T)
(SELECTQ (\FM.ITEMPROP ITEM (QUOTE STATE))
(OFF (* OFF to NIL)
(\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT))
WINDOW))
(T (* T to OFF)
(\FM.DISPLAYBITMAP ITEM (CADR (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT)))
WINDOW))
(NIL (* NIL to T)
(\FM.DISPLAYBITMAP ITEM (CAR (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT)))
WINDOW))
NIL])
(\FM.3STATE-SELECTEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:30")
(* called when 3state item selected.
rotates the state of ITEM and its bitmap.
The order is OFF -
NIL -
T)
(SELECTQ (\FM.ITEMPROP ITEM (QUOTE STATE))
(OFF (* OFF to NIL)
(\FM.3STATE-CHANGESTATE ITEM NIL))
(T (* T to OFF)
(\FM.3STATE-CHANGESTATE ITEM (QUOTE OFF)))
(NIL (* NIL to T)
(\FM.3STATE-CHANGESTATE ITEM T))
NIL])
(\FM.3STATE-CHANGESTATE
[LAMBDA (ITEM NEWSTATE) (* jow "18-Apr-86 15:19")
(\FM.ITEMPROP ITEM (QUOTE STATE)
NEWSTATE)
(SELECTQ NEWSTATE
[OFF (* to OFF)
[\FM.ITEMPROP ITEM (QUOTE BITMAP)
(CADR (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT]
(AND (\FM.ITEMPROP ITEM (QUOTE OFFREGION))
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE OFFREGION]
[T (* to T)
[\FM.ITEMPROP ITEM (QUOTE BITMAP)
(CAR (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT]
(AND (\FM.ITEMPROP ITEM (QUOTE ONREGION))
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE ONREGION]
[NIL (* to NIL)
(\FM.ITEMPROP ITEM (QUOTE BITMAP)
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)))
(AND (\FM.ITEMPROP ITEM (QUOTE NEUTRALREGION))
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE NEUTRALREGION]
NIL])
)
(* STATE ITEM FUNCTIONS)
(DEFINEQ
(\FM.STATE-SETUP
[LAMBDA (ITEM) (* jow "17-Apr-86 18:16")
(* The item's state is initialized to the first of the
menu items. The subitems list is replaced with a menu
of those items.)
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
"Will let you select a value from a pop up menu."))
(\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN)
(QUOTE \FM.HIGHLIGHTITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSMOVEDFN)
(QUOTE \FM.DISPLAYITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.STATE-SELECTEDFN))
(if (\FM.ITEMPROP ITEM (QUOTE MENUITEMS))
then (* build menu as specified)
(LET [(MENUITEMS (\FM.ITEMPROP ITEM (QUOTE MENUITEMS)))
(MENUFONT (APPLY (FUNCTION FONTCREATE)
(\FM.ITEMPROP ITEM (QUOTE MENUFONT]
(\FM.ITEMPROP ITEM (QUOTE STATE)
(OR (\FM.ITEMPROP ITEM (QUOTE INITSTATE))
(CAR MENUITEMS)))
(\FM.ITEMPROP ITEM (QUOTE CHANGESTATE)
(create MENU
ITEMS ← MENUITEMS
MENUFONT ← MENUFONT
CENTERFLG ← T
TITLE ←(OR (\FM.ITEMPROP ITEM (QUOTE MENUTITLE))
(\FM.ITEMPROP ITEM (QUOTE LABEL])
(\FM.STATE-SELECTEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:30")
(* Setup highlighting on the way out, to account for CHANGESTATE function and user selectedfn.
If CHANGESTATE is an atom, treat as function name to be applied to ITEM WINDOW BUTTONS, which must return the new
state (any atom, string, or bitmap) If CHANGESTATE is a menu, pop it up to select new state.
If CHANGESTATE returns NIL, don't change state)
(RESETSAVE NIL (LIST (QUOTE \FM.DISPLAYITEM)
ITEM WINDOW))
(LET [(NEWSTATE (COND
[(type? MENU (\FM.ITEMPROP ITEM (QUOTE CHANGESTATE)))
(MENU (\FM.ITEMPROP ITEM (QUOTE CHANGESTATE]
((\FM.ITEMPROP ITEM (QUOTE CHANGESTATE))
(APPLY* (\FM.ITEMPROP ITEM (QUOTE CHANGESTATE))
ITEM WINDOW BUTTONS]
(if NEWSTATE
then (\FM.STATE-CHANGESTATE ITEM NEWSTATE WINDOW])
(\FM.STATE-CHANGESTATE
[LAMBDA (ITEM NEWSTATE WINDOW) (* jow "12-Apr-86 18:31")
(* changing the state of a STATE item simply changes
the label of its display item.)
(\FM.ITEMPROP ITEM (QUOTE STATE)
NEWSTATE)
(LET [(DISPLAYITEM (LISTGET (\FM.ITEMPROP ITEM (QUOTE LINKS))
(QUOTE DISPLAY]
(if DISPLAYITEM
then (FM.CHANGELABEL DISPLAYITEM NEWSTATE WINDOW])
)
(* NWAY ITEM FUNCTIONS)
(DEFINEQ
(\FM.NWAY-SETUP
[LAMBDA (ITEM REGIONS) (* jow "24-Apr-86 21:53")
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
(FUNCTION \FM.NWAY-MESSAGE)))
(\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN)
(FUNCTION \FM.NWAY-DOWNFN))
(\FM.ITEMPROP ITEM (QUOTE SYSMOVEDFN)
(FUNCTION \FM.NWAY-MOVEDFN))
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.NWAY-SELECTEDFN))
(\FM.ITEMPROP ITEM (QUOTE UNHIGHLIGHT)
(\FM.ITEMPROP ITEM (QUOTE BITMAP))) (* save regions for state changes.)
(if [AND (CADR REGIONS)
(NOT (EQUAL (CADR REGIONS)
(\FM.ITEMPROP ITEM (QUOTE REGION]
then (\FM.ITEMPROP ITEM (QUOTE OFFREGION)
(\FM.ITEMPROP ITEM (QUOTE REGION)))
(\FM.ITEMPROP ITEM (QUOTE ONREGION)
(CADR REGIONS])
(\FM.NWAY-MESSAGE
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:07")
(IF (\FM.NWAYPROP WINDOW (\FM.ITEMPROP ITEM (QUOTE COLLECTION))
(QUOTE DESELECT))
THEN (SELECTQ (CAR BUTTONS)
(RIGHT "Will turn off this NWAY collection.")
((LEFT MIDDLE)
"Will select this item from its NWAY collection.")
NIL)
ELSE "Will select this item from its NWAY collection."])
(\FM.NWAY-DOWNFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:16")
(LET* [[NWAY (CDR (ASSOC (\FM.ITEMPROP ITEM (QUOTE COLLECTION))
(WINDOWPROP WINDOW (QUOTE FM.NWAYS]
(STATE (LISTGET NWAY (QUOTE STATE]
(if STATE
then (* an item is currently selected: unhighlight it)
(\FM.DISPLAYBITMAP STATE (\FM.ITEMPROP STATE (QUOTE UNHIGHLIGHT))
WINDOW))
(if [NOT (AND (EQ (CAR BUTTONS)
(QUOTE RIGHT))
(LISTGET NWAY (QUOTE DESELECT]
then (* highlight this item unless deselect group.)
(\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE HIGHLIGHT))
WINDOW])
(\FM.NWAY-MOVEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:16")
(LET* [[NWAY (CDR (ASSOC (\FM.ITEMPROP ITEM (QUOTE COLLECTION))
(WINDOWPROP WINDOW (QUOTE FM.NWAYS]
(STATE (LISTGET NWAY (QUOTE STATE]
(if STATE
then (* there is an item currently selected to redisplay)
(\FM.DISPLAYBITMAP STATE (\FM.ITEMPROP STATE (QUOTE BITMAP))
WINDOW))
(if [NOT (AND (EQ (CAR BUTTONS)
(QUOTE RIGHT))
(LISTGET NWAY (QUOTE DESELECT]
then (* this item was highlighted by downfn, so redisplay.)
(\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM (QUOTE BITMAP))
WINDOW])
(\FM.NWAY-SELECTEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "19-Apr-86 23:07")
(if (AND (EQ (CAR BUTTONS)
(QUOTE RIGHT))
(\FM.NWAYPROP WINDOW (\FM.ITEMPROP ITEM (QUOTE COLLECTION))
(QUOTE DESELECT)))
then (* group deselected)
(\FM.NWAY-CHANGESTATE (\FM.ITEMPROP ITEM (QUOTE COLLECTION))
NIL WINDOW)
else (* new item selected)
(\FM.NWAY-CHANGESTATE (\FM.ITEMPROP ITEM (QUOTE COLLECTION))
ITEM WINDOW])
(\FM.NWAY-CHANGESTATE
[LAMBDA (COLLECTION NEWSTATE WINDOW) (* jow "19-Apr-86 23:09")
(LET [(STATE (\FM.NWAYPROP WINDOW COLLECTION (QUOTE STATE]
(if (NEQ STATE NEWSTATE)
then (* actually have something to change)
(if STATE
then (* STATE item is unselected)
(\FM.TOGGLE-CHANGESTATE STATE NIL))
(if NEWSTATE
then (\FM.TOGGLE-CHANGESTATE NEWSTATE T))
(\FM.NWAYPROP WINDOW COLLECTION (QUOTE STATE)
NEWSTATE])
)
(* NUMBER ITEM FUNCTIONS)
(DEFINEQ
(\FM.NUMBER-SETUP
[LAMBDA (ITEM) (* jow "24-Apr-86 21:51")
(* This is EDIT-SETUP with number specifics added.)
(OR \FM.EDIT-TTBL (\FM.EDIT-SETUPTTBL)) (* since have edit item, setup term table)
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE MAXREGION))) (* always sensitive on maxregion)
[if [AND (\FM.ITEMPROP ITEM (QUOTE BOX))
(NOT (\FM.ITEMPROP ITEM (QUOTE MAXWIDTH]
then (* boxing implies maxwidth)
(\FM.ITEMPROP ITEM (QUOTE MAXWIDTH)
(IDIFFERENCE (fetch (REGION WIDTH) of (\FM.ITEMPROP ITEM
(QUOTE
REGION)))
(ITIMES 2 (\FM.ITEMPROP ITEM (QUOTE BOXOFFSET]
(if (\FM.ITEMPROP ITEM (QUOTE MAXWIDTH))
then (* setup stopwidth)
(\FM.ITEMPROP ITEM (QUOTE LABELMAXWIDTH)
(\FM.ITEMPROP ITEM (QUOTE MAXWIDTH)))
else (* make item infinite)
(\FM.ITEMPROP ITEM (QUOTE INFINITEWIDTH)
T))
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
(FUNCTION \FM.NUMBER-MESSAGE)))
(\FM.ITEMPROP ITEM (QUOTE INITSTATE)
(\FM.ITEMPROP ITEM (QUOTE LABEL)))
[if (FMEMB (\FM.ITEMPROP ITEM (QUOTE NUMBERTYPE))
(QUOTE (FLOAT FLOATP)))
then (\FM.ITEMPROP ITEM (QUOTE LIMITCHARS)
(QUOTE (1 2 3 4 5 6 7 8 9 0 %.)))
else (\FM.ITEMPROP ITEM (QUOTE LIMITCHARS)
(QUOTE (1 2 3 4 5 6 7 8 9 0]
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.NUMBER-SELECTEDFN])
(\FM.NUMBER-MESSAGE
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:06")
(SELECTQ (CAR BUTTONS)
(RIGHT "Will clear this number, then start editing.")
((LEFT MIDDLE)
"Will start editing this number at this position.")
NIL])
(\FM.NUMBER-SELECTEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "17-Oct-86 18:36")
(\FM.EDIT-ITEM ITEM WINDOW BUTTONS NIL (FUNCTION \FM.NUMBER-CHANGESTATE])
(\FM.NUMBER-CHANGESTATE
[LAMBDA (ITEM) (* jow "24-Apr-86 20:50")
(\FM.ITEMPROP ITEM (QUOTE STATE)
(if [NOT (EQUAL "" (\FM.ITEMPROP ITEM (QUOTE LABEL]
then (MKATOM (\FM.ITEMPROP ITEM (QUOTE LABEL])
)
(* TITLE ITEM FUNCTIONS)
(DEFINEQ
(\FM.DISPLAY-SETUP
[LAMBDA (ITEM) (* jow "17-Apr-86 18:17")
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
""])
)
(* EDITSTART ITEM FUNCTIONS)
(DEFINEQ
(\FM.EDITSTART-SETUP
[LAMBDA (ITEM) (* jow "24-Apr-86 22:00")
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
(FUNCTION \FM.EDITSTART-MESSAGE)))
(\FM.ITEMPROP ITEM (QUOTE SYSDOWNFN)
(QUOTE \FM.HIGHLIGHTITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSMOVEDFN)
(QUOTE \FM.DISPLAYITEM))
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.EDITSTART-SELECTEDFN])
(\FM.EDITSTART-MESSAGE
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:04")
(SELECTQ (CAR BUTTONS)
(RIGHT "Will clear first, then start editing.")
((LEFT MIDDLE)
"Will start editing.")
NIL])
(\FM.EDITSTART-SELECTEDFN
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "18-Jun-86 16:39")
(* start editing at the beginning of
item in the EDIT link.)
(\FM.DISPLAYITEM ITEM WINDOW)
(LET [(EDITITEM (LISTGET (\FM.ITEMPROP ITEM (QUOTE LINKS))
(QUOTE EDIT]
(if (type? FREEMENUITEM EDITITEM)
then (\FM.ITEMPROP ITEM (QUOTE SELECTEDFN)
(FUNCTION NILL)) (* insure editstart item won't have
selectedfn side effect, because end of
edit is not well defined)
(\FM.INSUREVISIBLE EDITITEM WINDOW)
(\FM.EDIT-ITEM EDITITEM WINDOW BUTTONS T])
)
(* EDIT ITEMS)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \FM.EDIT-TIMEOUT 100000)
(RPAQQ \FM.EDIT-RIGHTENDSPACE 5)
(RPAQQ \FM.EDIT-BLOCKSIZE 50)
(RPAQQ \FM.EDIT-CONTROLCHARS (9 10 12 13))
(RPAQQ \FM.EDIT-CONTROLCHARSECHO 255)
(RPAQQ \FM.EDIT-WORDDELIMCHARS
(32 123 125 91 93 60 62 47 92 46 44 59 42 40 41 45))
[CONSTANTS (\FM.EDIT-TIMEOUT 100000)
(\FM.EDIT-RIGHTENDSPACE 5)
(\FM.EDIT-BLOCKSIZE 50)
(\FM.EDIT-CONTROLCHARS (QUOTE (9 10 12 13)))
(\FM.EDIT-CONTROLCHARSECHO 255)
(\FM.EDIT-WORDDELIMCHARS (QUOTE (32 123 125 91 93 60 62 47 92 46 44 59 42 40 41 45]
)
)
(RPAQQ \FM.EDIT-TTBL NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \FM.EDIT-TTBL)
)
(DECLARE: EVAL@COMPILE
[PUTPROPS \FM.EDIT-MAXWIDTH MACRO (NIL (OR LABELMAXWIDTH (IPLUS (WINDOWPROP WINDOW (QUOTE WIDTH))
(fetch (REGION LEFT)
of
(DSPCLIPPINGREGION NIL WINDOW)
)
(MINUS LEFT]
(PUTPROPS \FM.EDIT-SCROLLAMOUNT MACRO (NIL (IQUOTIENT (WINDOWPROP WINDOW (QUOTE WIDTH))
2)))
)
(DEFINEQ
(\FM.EDIT-SETUP
[LAMBDA (ITEM) (* jow "24-Apr-86 22:06")
(* LABELMAXWIDTH is maximum width string can reach.
Right now it is set to MAXWIDTH, leaving no right end
space.)
(OR \FM.EDIT-TTBL (\FM.EDIT-SETUPTTBL)) (* since have edit item, setup term table)
(\FM.ITEMPROP ITEM (QUOTE REGION)
(\FM.ITEMPROP ITEM (QUOTE MAXREGION))) (* always sensitive on maxregion)
[if [AND (\FM.ITEMPROP ITEM (QUOTE BOX))
(NOT (\FM.ITEMPROP ITEM (QUOTE MAXWIDTH]
then (* boxing implies maxwidth)
(\FM.ITEMPROP ITEM (QUOTE MAXWIDTH)
(IDIFFERENCE (fetch (REGION WIDTH) of (\FM.ITEMPROP ITEM
(QUOTE
REGION)))
(ITIMES 2 (\FM.ITEMPROP ITEM (QUOTE BOXOFFSET]
(if (\FM.ITEMPROP ITEM (QUOTE MAXWIDTH))
then (* setup stopwidth)
(\FM.ITEMPROP ITEM (QUOTE LABELMAXWIDTH)
(\FM.ITEMPROP ITEM (QUOTE MAXWIDTH)))
else (* make item infinite)
(\FM.ITEMPROP ITEM (QUOTE INFINITEWIDTH)
T))
(OR (\FM.ITEMPROP ITEM (QUOTE MESSAGE))
(\FM.ITEMPROP ITEM (QUOTE MESSAGE)
(FUNCTION \FM.EDIT-MESSAGE)))
(\FM.ITEMPROP ITEM (QUOTE INITSTATE)
(\FM.ITEMPROP ITEM (QUOTE LABEL)))
(\FM.ITEMPROP ITEM (QUOTE SYSSELECTEDFN)
(FUNCTION \FM.EDIT-ITEM])
(\FM.EDIT-MESSAGE
[LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:05")
(SELECTQ (CAR BUTTONS)
(RIGHT "Will clear first, then start editing.")
((LEFT MIDDLE)
"Will start editing at this position.")
NIL])
(\FM.EDIT-SETUPTTBL
[LAMBDA NIL (* jow "21-Aug-86 12:50")
(* creates a new term table in
\FM.TTBL with no line buffering or
control character echoing.)
(SETQ \FM.EDIT-TTBL (COPYTERMTABLE (QUOTE ORIG)))
(ECHOMODE NIL \FM.EDIT-TTBL)
(for CC from 0 to 31 do (ECHOCONTROL CC (QUOTE REAL)
\FM.EDIT-TTBL])
(\FM.EDIT-ITEM
[LAMBDA (EDITITEM WINDOW BUTTONS STARTFLG DONEFN) (* jow "17-Oct-86 18:08")
(* ;;; "called when an edit item gets selected. If STARTFLG is T, start editing the item at the beginning, rather than at the current mouse position.")
(if (EQ (CAR BUTTONS)
(QUOTE RIGHT))
then (FM.CHANGELABEL EDITITEM "" WINDOW))
(LET ((TIMEOUT (SETUPTIMER 0))
FONT BITMAP LEFT DISPLAYLEFT DISPLAYBOTTOM BOXOFFSET CHCODE CHARWIDTH MAXWIDTH STRINGPTR
TAILPTR MOUSEX MOUSEY ITEM ITEMWIDTH LIMITCHARS ECHOCHAR STREAM)
(RESETLST (* ; "setup system")
(RESETSAVE (SETTERMTABLE \FM.EDIT-TTBL))
(RESETSAVE (TTYDISPLAYSTREAM WINDOW))
(RESETSAVE (CURSOR T))
(RESETSAVE NIL (LIST (QUOTE WINDOWPROP)
WINDOW
(QUOTE FM.EDITITEM)
NIL))
(RESETSAVE NIL (LIST (QUOTE WINDOWPROP)
WINDOW
(QUOTE FM.EDIT-TIMER)
NIL))
(RESETSAVE NIL (LIST (QUOTE WINDOWPROP)
WINDOW
(QUOTE PROCESS)
NIL))
(\FM.EDIT-PREPARETOEDIT EDITITEM STARTFLG) (* ; "setup item info")
(RESETSAVE (TTY.PROCESS (THIS.PROCESS)))
(* ;
"grab the tty last, so won't have it unless the menu thinks it's editing.")
(do (SETUPTIMER \FM.EDIT-TIMEOUT TIMEOUT)
(* ;;
"wait for something interesting to happen. while waiting, call tty fns to make caret flash, etc,")
(until (OR (MOUSESTATE (NOT UP))
(READP)
(TIMEREXPIRED? TIMEOUT)
(NOT (TTY.PROCESSP))) do (\TTYBACKGROUND))
[COND
[(NOT (TTY.PROCESSP))
(RETURN (AND DONEFN (APPLY* DONEFN EDITITEM WINDOW]
[(LASTMOUSESTATE (NOT UP))
(SETQ BUTTONS (DECODEBUTTONS))
(SETQ MOUSEX (LASTMOUSEX WINDOW))
(SETQ MOUSEY (LASTMOUSEY WINDOW))
(SETQ ITEM (\FM.CHECKREGION WINDOW MOUSEX MOUSEY))
(COND
((EQ ITEM EDITITEM)
(SELECTQ (CAR BUTTONS)
(LEFT (\FM.EDIT-MOVECARET))
(RIGHT (\FM.EDIT-DELETE))
NIL))
(ITEM (* ; "run new buttonfn, in THIS PROCESS.*")
(\CARET.DOWN)
(AND DONEFN (SETQ BUTTONS (APPLY* DONEFN EDITITEM WINDOW)))
(* ; "just reuse BUTTONS to hold result DONEFN")
(\FM.MENUHANDLER WINDOW T)
(RETURN BUTTONS))
(T (* ; "let other button events run")
(BLOCK]
((READP)
(SETQ CHCODE (\GETKEY))
(SELECTQ CHCODE
(530 (* ; "SKIP-NEXT key")
(FM.SKIPNEXT WINDOW))
(562 (* ; "SHIFT-SKIP-NEXT key means clear first")
(FM.SKIPNEXT WINDOW T))
(SELECTQ (GETSYNTAX CHCODE \FM.EDIT-TTBL)
(CHARDELETE (* ; "backup char,")
(\FM.EDIT-BACKUP))
(WORDDELETE (* ; "delete word")
(\FM.EDIT-WORDDELETE))
(\FM.EDIT-INSERT]
(COND
((TIMEREXPIRED? TIMEOUT)
(RETURN (APPLY* DONEFN EDITITEM WINDOW])
(\FM.EDIT-PREPARETOEDIT
[LAMBDA (EDITITEM STARTFLG) (* jow "17-Oct-86 17:11")
(* ;;; "called to prepare edit info, displaystream, and window for EDITITEM. References variables bound in FM.EDIT-ITEM.")
(\FM.ITEMPROP EDITITEM (QUOTE SELECTEDFN)
(FUNCTION NILL)) (* ;
"insure edit item won't have selectedfn side effect, because end of edit is not well defined")
(WINDOWPROP WINDOW (QUOTE FM.EDITITEM)
EDITITEM)
(WINDOWPROP WINDOW (QUOTE FM.EDIT-TIMER)
TIMEOUT)
(SETQ BOXOFFSET (OR (\FM.ITEMPROP EDITITEM (QUOTE BOXOFFSET))
0))
(SETQ FONT (\FM.ITEMPROP EDITITEM (QUOTE FONT)))
(SETQ BITMAP (\FM.ITEMPROP EDITITEM (QUOTE BITMAP)))
(SETQ ITEMWIDTH (STRINGWIDTH (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
FONT))
(SETQ MAXWIDTH (\FM.ITEMPROP EDITITEM (QUOTE MAXWIDTH)))
(SETQ LIMITCHARS (\FM.ITEMPROP EDITITEM (QUOTE LIMITCHARS)))
(SETQ ECHOCHAR (\FM.ITEMPROP EDITITEM (QUOTE ECHOCHAR))) (* setup edit pointer info)
(SETQ STREAM (DSPCREATE BITMAP))
(LET ((REGION (\FM.ITEMPROP EDITITEM (QUOTE REGION)))
POINTER)
(SETQ DISPLAYLEFT (fetch (REGION LEFT) of REGION))
(SETQ DISPLAYBOTTOM (fetch (REGION BOTTOM) of REGION))
(SETQ LEFT (IPLUS DISPLAYLEFT BOXOFFSET))
[SETQ POINTER (if STARTFLG
then (CONS 1 0)
else (\FM.EDIT-GETPOINTERINFO (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
FONT LEFT (LASTMOUSEX WINDOW]
(SETQ STRINGPTR (CAR POINTER))
(SETQ TAILPTR (IPLUS BOXOFFSET (CDR POINTER))) (* ;
"setup window x and y position, so caret it right place")
(DSPXPOSITION (IPLUS LEFT (CDR POINTER))
WINDOW)
(DSPYPOSITION (IPLUS DISPLAYBOTTOM (FONTPROP FONT (QUOTE DESCENT))
BOXOFFSET)
WINDOW) (* ;
"setup edit stream, used for printing inserted characters to the bitmap")
(DSPXPOSITION TAILPTR STREAM)
(DSPYPOSITION (IPLUS (FONTPROP FONT (QUOTE DESCENT))
BOXOFFSET)
STREAM)
(DSPFONT FONT STREAM])
(\FM.EDIT-FINDNEXT
[LAMBDA NIL (* jow "14-Nov-85 00:05")
(* find the next edit item in the freemenu after ITEM.
Return NIL if there isn't another one.)
(for I in [CDR (FMEMB EDITITEM (WINDOWPROP WINDOW (QUOTE FM.ITEMS]
thereis (EQ (\FM.ITEMPROP I (QUOTE TYPE))
(QUOTE EDIT])
(\FM.EDIT-FINDFIRST
[LAMBDA (WINDOW) (* jow "18-Jun-86 17:01")
(* start editing the first edit item
in the menu.)
(for I in (WINDOWPROP WINDOW (QUOTE FM.ITEMS)) thereis (EQ (\FM.ITEMPROP I (QUOTE TYPE))
(QUOTE EDIT])
(\FM.EDIT-BACKUP
[LAMBDA NIL (* jow "24-Apr-86 16:23")
(* backup 1 character, if possible)
(if (IGREATERP STRINGPTR 1)
then (SETQ STRINGPTR (SUB1 STRINGPTR))
(SETQ CHARWIDTH (CHARWIDTH (NTHCHARCODE (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
STRINGPTR)
FONT))
(RELMOVETO (MINUS CHARWIDTH)
0 WINDOW)
(RELMOVETO (MINUS CHARWIDTH)
0 STREAM)
(if (ILESSP (DSPXPOSITION NIL WINDOW)
(fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL WINDOW)))
then (SCROLLW WINDOW (\FM.EDIT-SCROLLAMOUNT)
0) (* about to backup off window: scroll.)
)
(BITBLT BITMAP TAILPTR BOXOFFSET BITMAP (IDIFFERENCE TAILPTR CHARWIDTH)
BOXOFFSET
(IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR))
(FONTPROP FONT (QUOTE HEIGHT)))
(\FM.ITEMPROP EDITITEM (QUOTE LABEL)
(\FM.EDIT-STRDELETE (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
STRINGPTR STRINGPTR))
(SETQ ITEMWIDTH (IDIFFERENCE ITEMWIDTH CHARWIDTH))
(SETQ TAILPTR (IDIFFERENCE TAILPTR CHARWIDTH))
(\FM.EDIT-UPDATEAFTERDELETE])
(\FM.EDIT-WORDDELETE
[LAMBDA NIL (* jow "24-Apr-86 16:54")
(* called on ↑W. The list \FM.EDIT-WRODDELIMCHARS specifies a list of character codes that stop word delete.
Backup over any number of these chars, then any number of non-delim chars, until get to another delim char, leaving
that char in the string.)
(if (NEQ STRINGPTR 1)
then (LET ((END (SUB1 STRINGPTR))
(STRING (\FM.ITEMPROP EDITITEM (QUOTE LABEL)))
(ENDTAILPTR BOXOFFSET))
(while (AND (NEQ END 1)
(FMEMB (NTHCHARCODE STRING (SUB1 END))
\FM.EDIT-WORDDELIMCHARS))
do (* move END back to the farthest sequential delim
char)
(SETQ END (SUB1 END)))
(while (AND (NEQ END 1)
(NOT (FMEMB (NTHCHARCODE STRING (SUB1 END))
\FM.EDIT-WORDDELIMCHARS)))
do (* move END back to the farthest sequential non-delim
char)
(SETQ END (SUB1 END))) (* now END is pointing to the farthest char to be
deleted)
[if (NEQ END 1)
then (SETQ ENDTAILPTR (IPLUS BOXOFFSET (STRINGWIDTH
(SUBSTRING STRING 1 (SUB1 END))
FONT]
(BITBLT BITMAP TAILPTR BOXOFFSET BITMAP ENDTAILPTR BOXOFFSET
(IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR))
(FONTPROP FONT (QUOTE HEIGHT)))
(\FM.ITEMPROP EDITITEM (QUOTE LABEL)
(\FM.EDIT-STRDELETE STRING END (SUB1 STRINGPTR)))
(SETQ ITEMWIDTH (STRINGWIDTH (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
FONT))
(SETQ STRINGPTR END)
(SETQ TAILPTR ENDTAILPTR)
(DSPXPOSITION (IPLUS LEFT TAILPTR)
WINDOW)
(DSPXPOSITION TAILPTR STREAM)
(if (ILESSP (DSPXPOSITION NIL WINDOW)
(fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL WINDOW)))
then (SCROLLW WINDOW (\FM.EDIT-SCROLLAMOUNT)
0) (* about to backup off window: scroll.)
)
(\FM.EDIT-UPDATEAFTERDELETE])
(\FM.EDIT-INSERT
[LAMBDA NIL (* jow "10-Jun-86 16:09")
(if [OR (NOT LIMITCHARS)
(AND (LISTP LIMITCHARS)
(FMEMB (CHARACTER CHCODE)
LIMITCHARS))
(AND (ATOM LIMITCHARS)
(APPLY* LIMITCHARS EDITITEM WINDOW (CHARACTER CHCODE]
then (* insert a single character, CHCODE
into the string)
(SETQ CHARWIDTH (CHARWIDTH CHCODE FONT))
(if (OR (NOT MAXWIDTH)
(ILEQ (IPLUS ITEMWIDTH CHARWIDTH)
MAXWIDTH))
then (* i am going to insert)
(RELMOVETO CHARWIDTH 0 WINDOW)
(if [IGREATERP (DSPXPOSITION NIL WINDOW)
(IPLUS (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL WINDOW))
(fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL WINDOW]
then (* about to type off window: scroll
back.)
(add (fetch (REGION WIDTH) of (WINDOWPROP WINDOW (QUOTE EXTENT)))
\FM.EDIT-BLOCKSIZE)
(SCROLLW WINDOW (MINUS (\FM.EDIT-SCROLLAMOUNT))
0))
(if (IGREATERP (IPLUS ITEMWIDTH CHARWIDTH)
(BITMAPWIDTH BITMAP))
then (* current bitmap too small, make new
one. This won't get done if item is
boxed.)
(\FM.ITEMPROP EDITITEM (QUOTE BITMAP)
(BITMAPCREATE (IPLUS (BITMAPWIDTH BITMAP)
\FM.EDIT-BLOCKSIZE)
(BITMAPHEIGHT BITMAP)))
(BITBLT BITMAP 0 0 (\FM.ITEMPROP EDITITEM (QUOTE BITMAP))
0 0)
(SETQ BITMAP (\FM.ITEMPROP EDITITEM (QUOTE BITMAP)))
(DSPDESTINATION BITMAP STREAM))
(* now insert character into bitmap)
(BITBLT BITMAP TAILPTR BOXOFFSET BITMAP (IPLUS TAILPTR CHARWIDTH)
BOXOFFSET
(IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR))
(FONTPROP FONT (QUOTE HEIGHT)))
(SETQ ITEMWIDTH (IPLUS ITEMWIDTH CHARWIDTH))
(if (FMEMB CHCODE \FM.EDIT-CONTROLCHARS)
then (* for CR, LF, TAB, etc, echo non
control action char)
(PRIN1 (OR ECHOCHAR (CHARACTER \FM.EDIT-CONTROLCHARSECHO))
STREAM)
else (PRIN1 (OR ECHOCHAR (CHARACTER CHCODE))
STREAM))
(\CARET.DOWN)
(BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH)
(\FM.ITEMPROP EDITITEM (QUOTE LABEL)
(\FM.EDIT-STRINSERT (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
(CHARACTER CHCODE)
STRINGPTR))
(SETQ STRINGPTR (ADD1 STRINGPTR))
(SETQ TAILPTR (IPLUS TAILPTR CHARWIDTH))
(EXTENDREGION (WINDOWPROP WINDOW (QUOTE EXTENT))
(CREATEREGION LEFT 0 (IPLUS ITEMWIDTH BOXOFFSET)
0])
(\FM.EDIT-DELETE
[LAMBDA NIL (* jow "10-Jun-86 16:12")
(* Called when a right button event occurs in ITEM's region, while it is being
edited. Delete the substring of the items string starting at the current
position, and ending at the position of MOUSEX, inclusive.)
(\CARET.DOWN)
(while (MOUSESTATE (NOT UP)) bind (REGION ← (\FM.ITEMPROP EDITITEM (QUOTE REGION)))
(INFINITEWIDTH ← (\FM.ITEMPROP EDITITEM (QUOTE INFINITEWIDTH)))
(BOTTOM ← (IPLUS BOXOFFSET DISPLAYBOTTOM))
(HEIGHT ← (FONTPROP FONT (QUOTE HEIGHT)))
(PIVOT ← (IPLUS DISPLAYLEFT TAILPTR))
END POINTER OLDPOINTER MOVEDOFF eachtime (SETQ MOUSEX
(LASTMOUSEX WINDOW))
(SETQ MOUSEY (LASTMOUSEY
WINDOW))
do (if (\FM.ONITEM REGION MOUSEX MOUSEY INFINITEWIDTH)
then (SETQ OLDPOINTER POINTER)
(SETQ POINTER (\FM.EDIT-GETPOINTERINFO (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
FONT LEFT MOUSEX))
[if (OR MOVEDOFF (NOT (EQUAL POINTER OLDPOINTER)))
then (SETQ MOVEDOFF NIL)
(SETQ END (IPLUS LEFT (CDR POINTER)))
(BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH)
(if (IGREATERP END PIVOT)
then (* highlight from pivot to end)
(BLTSHADE BLACKSHADE WINDOW PIVOT BOTTOM (IDIFFERENCE END PIVOT)
HEIGHT
(QUOTE INVERT))
else (* highlight from end to pivot)
(BLTSHADE BLACKSHADE WINDOW END BOTTOM (IDIFFERENCE PIVOT END)
HEIGHT
(QUOTE INVERT]
elseif (NOT MOVEDOFF)
then (BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH)
(SETQ MOVEDOFF T))
finally (if (AND (\FM.ONITEM REGION MOUSEX MOUSEY INFINITEWIDTH)
(NEQ (CAR POINTER)
STRINGPTR))
then (if (IGREATERP END PIVOT)
then (* from current to right: pointers and
xpositions remain the same)
(BITBLT BITMAP (IPLUS BOXOFFSET (CDR POINTER))
BOXOFFSET BITMAP TAILPTR BOXOFFSET (IPLUS BOXOFFSET ITEMWIDTH
(MINUS TAILPTR))
HEIGHT)
[\FM.ITEMPROP EDITITEM (QUOTE LABEL)
(\FM.EDIT-STRDELETE (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
STRINGPTR
(SUB1 (CAR POINTER]
else (* from current to left:)
(BITBLT BITMAP TAILPTR BOXOFFSET BITMAP (IPLUS BOXOFFSET (CDR POINTER)
)
BOXOFFSET
(IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR))
HEIGHT)
(\FM.ITEMPROP EDITITEM (QUOTE LABEL)
(\FM.EDIT-STRDELETE (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
(CAR POINTER)
(SUB1 STRINGPTR)))
(SETQ STRINGPTR (CAR POINTER))
(SETQ TAILPTR (IPLUS BOXOFFSET (CDR POINTER)))
(DSPXPOSITION END WINDOW)
(DSPXPOSITION TAILPTR STREAM))
(SETQ ITEMWIDTH (STRINGWIDTH (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
FONT))
(\FM.EDIT-UPDATEAFTERDELETE])
(\FM.EDIT-GETPOINTERINFO
[LAMBDA (STRING FONT LEFT MOUSEX) (* jow "22-Apr-86 14:58")
(* calculate string pointer and tail pointer from mouse location within string. Assume mousex in window
coordinates, not REGION coordinates. Return as dotted pair (stringptr . tailptr) -- Each character is sensitive 2
bits to the left to allow for mousing between chars)
(SETQ MOUSEX (IDIFFERENCE MOUSEX LEFT))
(LET ((PTR))
(for N (WIDTH ← -2) from 1 to (NCHARS STRING)
do (add WIDTH (CHARWIDTH (NTHCHARCODE STRING N)
FONT))
(if (IGREATERP WIDTH MOUSEX)
then (SETQ PTR N)
(RETURN)))
(if PTR
then (* mouse at PTR in string)
(CONS PTR (STRINGWIDTH (OR (SUBSTRING STRING 1 (SUB1 PTR))
"")
FONT))
else (* mouse at end of string)
(CONS (ADD1 (NCHARS STRING))
(STRINGWIDTH STRING FONT])
(\FM.EDIT-MOVECARET
[LAMBDA NIL (* jow "10-Sep-86 10:33")
(* mouse event has occured at MOUSEX
in ITEM's region while editing.
Move the edit caret to that position)
(\CARET.DOWN)
(SETQ POINTER (\FM.EDIT-GETPOINTERINFO (\FM.ITEMPROP EDITITEM (QUOTE LABEL))
FONT LEFT MOUSEX))
(DSPXPOSITION (IPLUS LEFT (CDR POINTER))
WINDOW) (* move caret)
(SETQ STRINGPTR (CAR POINTER)) (* update edit pointers)
(SETQ TAILPTR (IPLUS BOXOFFSET (CDR POINTER)))
(DSPXPOSITION TAILPTR STREAM])
(\FM.EDIT-STRDELETE
[LAMBDA (STRING N M) (* jow
"17-Jul-85 00:29")
(* delete from
characters N through M
of STRING. no bounds
checks are made on N
and M. returns a new
string)
(CONCAT (OR (SUBSTRING STRING 1 (SUB1 N))
"")
(OR (SUBSTRING STRING (ADD1 M)
(NCHARS STRING))
""])
(\FM.EDIT-STRINSERT
[LAMBDA (STRING CHAR N) (* jow
"17-Jul-85 00:40")
(* return new string
with CHAR inserted as
new character at
position N. just
appends CHAR if N is 1
greater than nchars)
(CONCAT (OR (SUBSTRING STRING 1 (SUB1 N))
"")
CHAR
(OR (SUBSTRING STRING N (NCHARS STRING))
""])
(\FM.EDIT-UPDATEAFTERDELETE
[LAMBDA NIL (* jow "10-Jun-86 16:09")
(* called to update the screen after a
delete has occured.)
(\CARET.DOWN)
(BLTSHADE WHITESHADE BITMAP (IPLUS BOXOFFSET ITEMWIDTH)
BOXOFFSET
(IDIFFERENCE (BITMAPWIDTH BITMAP)
(IPLUS ITEMWIDTH BOXOFFSET BOXOFFSET))
(FONTPROP FONT (QUOTE HEIGHT))) (* whiteout to rightmargin)
(BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FM.ITEMPROP)
)
(PUTPROPS FREEMENU COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14453 31237 (FREEMENU 14463 . 15510) (FM.ITEMPROP 15512 . 16231) (FM.GETITEM 16233 .
16814) (FM.GETSTATE 16816 . 18426) (FM.HIGHLIGHTITEM 18428 . 19035) (FM.CHANGELABEL 19037 . 21058) (
FM.CHANGESTATE 21060 . 22794) (FM.RESETSTATE 22796 . 23376) (FM.RESETMENU 23378 . 23963) (
FM.RESETSHAPE 23965 . 25237) (FM.RESETGROUPS 25239 . 25710) (FM.REDISPLAYITEM 25712 . 26157) (
FM.REDISPLAYMENU 26159 . 26615) (FM.SHADE 26617 . 27311) (FM.EDITP 27313 . 27492) (FM.EDITITEM 27494
. 28360) (FM.ENDEDIT 28362 . 28536) (FM.SKIPNEXT 28538 . 30249) (FM.WHICHITEM 30251 . 30941) (
FM.TOPGROUPID 30943 . 31235)) (41112 88370 (\FM.FORMAT 41122 . 43283) (\FM.FORMATBYROW 43285 . 44885)
(\FM.FORMATBYCOLUMN 44887 . 47220) (\FM.FORMATBYGRID 47222 . 51523) (\FM.FORMATEXPLICIT 51525 . 54433)
(\FM.LAYOUTROW 54435 . 56506) (\FM.LAYOUTCOLUMN 56508 . 58730) (\FM.LAYOUTGRID 58732 . 62529) (
\FM.JUSTIFYITEMS 62531 . 65607) (\FM.JUSTIFYGROUPS 65609 . 65957) (\FM.PUSHGROUP 65959 . 67431) (
\FM.CHECKDESCRIPTION 67433 . 73096) (\FM.CHECKPROPS 73098 . 74109) (\FM.CREATEITEM 74111 . 76197) (
\FM.GETREGIONS 76199 . 78181) (\FM.GETBITMAPS 78183 . 80139) (\FM.MAKEBITMAP 80141 . 81680) (
\FM.READUSERDATA 81682 . 82272) (\FM.MAKELINKS 82274 . 82854) (\FM.COLLECTNWAYS 82856 . 85006) (
\FM.SETATTACHPOINT 85008 . 85404) (\FM.CREATEW 85406 . 87730) (\FM.STARTEDIT 87732 . 88368)) (99273
113076 (\FM.REDISPLAYMENU 99283 . 101692) (\FM.RESHAPEFN 101694 . 103878) (\FM.UNSCROLLWINDOW 103880
. 104596) (\FM.RESETCLIPPINGREGION 104598 . 105534) (\FM.FILLWINDOW 105536 . 106469) (
\FM.INITCORNERSFN 106471 . 107517) (\FM.TRANSPOSEHORZ 107519 . 108166) (\FM.TRANSPOSEVERT 108168 .
108823) (\FM.UPDATEGROUPEXTENT 108825 . 110683) (\FM.WINDOWEXTENT 110685 . 111630) (
\FM.UPDATEWINDOWEXTENT 111632 . 113074)) (114579 122299 (\FM.WINDOWENTRYFN 114589 . 115768) (
\FM.BUTTONEVENTFN 115770 . 116431) (\FM.RIGHTBUTTONFN 116433 . 117279) (\FM.DOSELECTION 117281 .
118190) (\FM.MENUHANDLER 118192 . 122297)) (124570 144634 (\FM.GETITEMPROP 124580 . 126510) (
\FM.PUTITEMPROP 126512 . 130482) (\FM.CGETITEMPROP 130484 . 133210) (\FM.CPUTITEMPROP 133212 . 138222)
(\FM.DISPLAYITEM 138224 . 138422) (\FM.HIGHLIGHTITEM 138424 . 138627) (\FM.CHANGELABEL 138629 .
141072) (\FM.CHANGESTATE 141074 . 142044) (\FM.ENDEDIT 142046 . 142938) (\FM.INSUREVISIBLE 142940 .
143582) (\FM.CLEARITEM 143584 . 144632)) (144672 145635 (\FM.MOMENTARY-SETUP 144682 . 145202) (
\FM.MOMENTARY-SELECTEDFN 145204 . 145633)) (145670 148460 (\FM.TOGGLE-SETUP 145680 . 146777) (
\FM.TOGGLE-DOWNFN 146779 . 147354) (\FM.TOGGLE-SELECTEDFN 147356 . 147758) (\FM.TOGGLE-CHANGESTATE
147760 . 148458)) (148495 155503 (\FM.3STATE-SETUP 148505 . 149563) (\FM.3STATE-SETUPOFFBITMAP 149565
. 152620) (\FM.3STATE-DOWNFN 152622 . 153556) (\FM.3STATE-SELECTEDFN 153558 . 154338) (
\FM.3STATE-CHANGESTATE 154340 . 155501)) (155537 158491 (\FM.STATE-SETUP 155547 . 156978) (
\FM.STATE-SELECTEDFN 156980 . 157954) (\FM.STATE-CHANGESTATE 157956 . 158489)) (158524 162901 (
\FM.NWAY-SETUP 158534 . 159464) (\FM.NWAY-MESSAGE 159466 . 159926) (\FM.NWAY-DOWNFN 159928 . 160771) (
\FM.NWAY-MOVEDFN 160773 . 161620) (\FM.NWAY-SELECTEDFN 161622 . 162280) (\FM.NWAY-CHANGESTATE 162282
. 162899)) (162936 165660 (\FM.NUMBER-SETUP 162946 . 164848) (\FM.NUMBER-MESSAGE 164850 . 165153) (
\FM.NUMBER-SELECTEDFN 165155 . 165358) (\FM.NUMBER-CHANGESTATE 165360 . 165658)) (165694 165921 (
\FM.DISPLAY-SETUP 165704 . 165919)) (165959 167739 (\FM.EDITSTART-SETUP 165969 . 166473) (
\FM.EDITSTART-MESSAGE 166475 . 166746) (\FM.EDITSTART-SELECTEDFN 166748 . 167737)) (169168 197310 (
\FM.EDIT-SETUP 169178 . 170866) (\FM.EDIT-MESSAGE 170868 . 171151) (\FM.EDIT-SETUPTTBL 171153 . 171773
) (\FM.EDIT-ITEM 171775 . 176422) (\FM.EDIT-PREPARETOEDIT 176424 . 178947) (\FM.EDIT-FINDNEXT 178949
. 179421) (\FM.EDIT-FINDFIRST 179423 . 179905) (\FM.EDIT-BACKUP 179907 . 181285) (\FM.EDIT-WORDDELETE
181287 . 183601) (\FM.EDIT-INSERT 183603 . 187841) (\FM.EDIT-DELETE 187843 . 192729) (
\FM.EDIT-GETPOINTERINFO 192731 . 193868) (\FM.EDIT-MOVECARET 193870 . 194739) (\FM.EDIT-STRDELETE
194741 . 195684) (\FM.EDIT-STRINSERT 195686 . 196628) (\FM.EDIT-UPDATEAFTERDELETE 196630 . 197308))))
)
STOP