(FILECREATED "12-Feb-86 18:31:27" {ERIS}<LISPUSERS>KOTO>PIECE-MENUS.;2 11035
changes to: (FNS CHUNK.MENU.CREATE CHUNK.MENU.INVOKE KEYWORD.MENU.CREATE KEYWORD.MENU.GET.MENU
KEYWORD.MENU.INVOKE)
(VARS PIECE-MENUSCOMS)
previous date: "16-May-84 21:45:33" {PHYLEX:PARC:XEROX}<LISP>INTERMEZZO>LISPUSERS>PIECE-MENUS.;1
)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PIECE-MENUSCOMS)
(RPAQQ PIECE-MENUSCOMS ((FNS CHUNK.MENU.CREATE CHUNK.MENU.GET.REAL.MENU CHUNK.MENU.INVOKE
KEYWORD.MENU.CREATE KEYWORD.MENU.GET.MENU KEYWORD.MENU.INVOKE
KEYWORD.MENU.MAKE.MENU PIECE.MENU.MAKE.MENU)
(BITMAPS CHUNK.MENU.DOWN.BITMAP CHUNK.MENU.UP.BITMAP
KEYWORD.MENU.KEYWORD.BITMAP)
(DECLARE: DOEVAL@LOAD (LOCALVARS .T)
(GLOBALVARS CHUNK.MENU.DOWN.BITMAP CHUNK.MENU.UP.BITMAP
KEYWORD.MENU.KEYWORD.BITMAP))))
(DEFINEQ
(CHUNK.MENU.CREATE
[LAMBDA (ITEMS PROPERTIES REQUIRED.ITEMS) (* edited: "12-Feb-86 18:31")
(PROG (BLANK.ITEM UP.ITEM DOWN.ITEM CHUNK.COUNT IT.LISTS ITS N MENU.COUNT BLOCK.ITS ITM STR
MENUS)
(SETQ BLANK.ITEM (LIST " " (KWOTE (QUOTE $BLANK$))
"No action"))
(SETQ UP.ITEM (LIST CHUNK.MENU.UP.BITMAP (KWOTE (QUOTE $UP$))
"Jump to preceding section"))
(SETQ DOWN.ITEM (LIST CHUNK.MENU.DOWN.BITMAP (KWOTE (QUOTE $DOWN$))
"Jump to following section"))
(SETQ CHUNK.COUNT (OR (LISTGET PROPERTIES (QUOTE CHUNK.COUNT))
30))
(SETQ IT.LISTS (CONS))
(SETQ ITS (CONS))
(SETQ N 0)
(for ITEM in ITEMS
do (if (EQP N CHUNK.COUNT)
then (TCONC IT.LISTS (CAR ITS))
(SETQ ITS (CONS))
(SETQ N 0))
(TCONC ITS ITEM)
(SETQ N (ADD1 N))
finally (TCONC IT.LISTS (CAR ITS)))
(SETQ IT.LISTS (CAR IT.LISTS))
(SETQ MENU.COUNT (LENGTH IT.LISTS))
[SETQ BLOCK.ITS (for LST in IT.LISTS as I from 1
collect (SETQ ITM (CAR LST))
(SETQ STR (if (LISTP ITM)
then (CAR ITM)
else ITM))
(LIST (CONCAT STR "...")
(LIST (QUOTE QUOTE)
(CONS (QUOTE $CHUNK$)
I))
(CONCAT "Jump to menu chunk starting with item "
STR]
(SETQ MENUS (for LST in IT.LISTS as I from 1
collect (SETQ ITS (CONS))
(if REQUIRED.ITEMS
then (for RIT in REQUIRED.ITEMS
do (TCONC ITS RIT))
(TCONC ITS BLANK.ITEM))
(if (IGREATERP MENU.COUNT 1)
then (for BLOCK.ITM in BLOCK.ITS as J
from 1 do (if (EQ J I)
then (if (NEQ I 1)
then
(TCONC ITS
UP.ITEM))
(if (NEQ I
MENU.COUNT)
then
(TCONC ITS
DOWN.ITEM))
else (TCONC ITS BLOCK.ITM)))
(TCONC ITS BLANK.ITEM))
(SETQ ITS (NCONC (CAR ITS)
LST))
(PIECE.MENU.MAKE.MENU ITS PROPERTIES)))
(RETURN (CONS MENUS 1])
(CHUNK.MENU.GET.REAL.MENU
[LAMBDA (CHUNK.MENU) (* edited: "16-May-84 21:14")
(PROG (MENUS N)
(SETQ MENUS (CAR CHUNK.MENU))
(SETQ N (CDR CHUNK.MENU))
(RETURN (CAR (NTH MENUS N])
(CHUNK.MENU.INVOKE
[LAMBDA (CHUNK.MENU POSITION) (* edited: "12-Feb-86 18:31")
(PROG (MENUS N CURRENT.MENU DONE POS NEW.POSITION RESULT THUMB.ITEMS THUMB.MENU PROPERTIES)
(SETQ MENUS (CAR CHUNK.MENU))
(GETMOUSESTATE)
(SETQ POS (OR POSITION (create POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY)))
[until DONE
do (SETQ N (CDR CHUNK.MENU))
(SETQ CURRENT.MENU (CAR (NTH MENUS N)))
[SETQ NEW.POSITION (create POSITION
XCOORD ←(IDIFFERENCE (fetch (POSITION XCOORD)
of POS)
(IQUOTIENT
(fetch (MENU
IMAGEWIDTH)
of CURRENT.MENU)
2))
YCOORD ←(IDIFFERENCE (fetch (POSITION YCOORD)
of POS)
(IQUOTIENT
(fetch (MENU
IMAGEHEIGHT)
of CURRENT.MENU)
2]
(SETQ RESULT (MENU CURRENT.MENU NEW.POSITION))
(if (LISTP RESULT)
then (SELECTQ (CAR RESULT)
($CHUNK$ (RPLACD CHUNK.MENU (CDR RESULT)))
(SETQ DONE T))
else (SELECTQ RESULT
($BLANK$)
($UP$ (RPLACD CHUNK.MENU (SUB1 N)))
($DOWN$ (RPLACD CHUNK.MENU (ADD1 N)))
(SETQ DONE T]
(RETURN RESULT])
(KEYWORD.MENU.CREATE
[LAMBDA (OBJECTS KEYWORDFN PROPERTIES ITEMFN) (* edited: "12-Feb-86 18:31")
(PROG (TITLE ALST ENTRY ITEM ITEMS KEYWORD.ITEMS KEYWORD)
[for OBJECT in OBJECTS
do (SETQ ITEM (if ITEMFN
then (APPLY* ITEMFN OBJECT)
else OBJECT))
(for KEYWD in (APPLY* KEYWORDFN OBJECT)
do (SETQ ENTRY (FASSOC KEYWD ALST))
(if ENTRY
then (SETQ ITEMS (CADR ENTRY))
(NCONC1 ITEMS ITEM)
else (SETQ ALST (CONS (CONS KEYWD (CONS (LIST ITEM)
NIL))
ALST))
(SETQ ALST (SORT ALST T]
[SETQ KEYWORD.ITEMS (for ENT in ALST
collect (SETQ KEYWORD (CAR ENT))
(LIST (CONCAT KEYWORD "'s")
(KWOTE (CONS (QUOTE $KEYWORD$)
KEYWORD))
(CONCAT "Jump to section for " KEYWORD]
(RETURN (LIST (CAAR ALST)
ALST PROPERTIES KEYWORD.ITEMS])
(KEYWORD.MENU.GET.MENU
[LAMBDA (ENTRY KEYWORD.MENU) (* edited: "12-Feb-86 18:31")
(OR (CDDR ENTRY)
(PROG (ITEMS KEYWORD PROPERTIES KEYWORD.ITEMS TITLE)
(SETQ ITEMS (CADR ENTRY))
(SETQ KEYWORD (CAR ENTRY))
(SETQ PROPERTIES (CADDR KEYWORD.MENU))
(SETQ KEYWORD.ITEMS (CADDDR KEYWORD.MENU))
(RPLACD (CDR ENTRY)
(CHUNK.MENU.CREATE ITEMS (NCONC (LIST (QUOTE TITLE)
(if (SETQ TITLE
(LISTGET
PROPERTIES
(QUOTE TITLE)))
then (CONCAT TITLE
": "
KEYWORD)
else KEYWORD))
PROPERTIES)
KEYWORD.ITEMS))
(RETURN (CDDR ENTRY])
(KEYWORD.MENU.INVOKE
[LAMBDA (KEYWORD.MENU POSITION) (* edited: "12-Feb-86 18:31")
(PROG (ALST DONE ENTRY RESULT SUBMENU REALMENU NEW.POS POS)
(SETQ ALST (CADR KEYWORD.MENU))
(SETQ POS (if POSITION
else (GETMOUSESTATE)
(create POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY)))
(until DONE
do (SETQ ENTRY (FASSOC (CAR KEYWORD.MENU)
ALST))
(SETQ SUBMENU (KEYWORD.MENU.GET.MENU ENTRY KEYWORD.MENU))
(SETQ REALMENU (CHUNK.MENU.GET.REAL.MENU SUBMENU))
[SETQ NEW.POS (create POSITION
XCOORD ←(IDIFFERENCE (fetch (POSITION XCOORD)
of POS)
(IQUOTIENT
(fetch (MENU IMAGEWIDTH)
of REALMENU)
2))
YCOORD ←(IDIFFERENCE (fetch (POSITION YCOORD)
of POS)
(IQUOTIENT
(fetch (MENU IMAGEHEIGHT)
of REALMENU)
2]
(SETQ RESULT (CHUNK.MENU.INVOKE SUBMENU NEW.POS))
(if (AND (LISTP RESULT)
(EQ (CAR RESULT)
(QUOTE $KEYWORD$)))
then (RPLACA KEYWORD.MENU (CDR RESULT))
else (SETQ DONE T)))
(RETURN RESULT])
(KEYWORD.MENU.MAKE.MENU
[LAMBDA (ITEMS TITLE PROPERTIES) (* DAHJr "10-AUG-83 17:28")
(CHUNK.MENU.CREATE ITEMS (NCONC (LIST (QUOTE TITLE)
TITLE)
PROPERTIES])
(PIECE.MENU.MAKE.MENU
[LAMBDA (ITEMS PROPERTIES) (* edited: "16-May-84 20:47")
(PROG (MENU VALUE)
(SETQ MENU (create MENU
ITEMS ← ITEMS))
(AND (SETQ VALUE (LISTGET PROPERTIES (QUOTE TITLE)))
(replace (MENU TITLE) of MENU with VALUE))
(AND (SETQ VALUE (LISTGET PROPERTIES (QUOTE CENTERFLG)))
(replace (MENU CENTERFLG) of MENU with VALUE))
(AND (SETQ VALUE (LISTGET PROPERTIES (QUOTE MENUFONT)))
(replace (MENU MENUFONT) of MENU with VALUE))
(AND (SETQ VALUE (LISTGET PROPERTIES (QUOTE ITEMWIDTH)))
(replace (MENU ITEMWIDTH) of MENU with VALUE))
(AND (SETQ VALUE (LISTGET PROPERTIES (QUOTE ITEMHEIGHT)))
(replace (MENU ITEMHEIGHT) of MENU with VALUE))
(AND (SETQ VALUE (LISTGET PROPERTIES (QUOTE MENUBORDERSIZE)))
(replace (MENU MENUBORDERSIZE) of MENU with VALUE))
(AND (SETQ VALUE (LISTGET PROPERTIES (QUOTE MENUOUTLINESIZE)))
(replace (MENU MENUOUTLINESIZE) of MENU with VALUE))
(RETURN MENU])
)
(RPAQ CHUNK.MENU.DOWN.BITMAP (READBITMAP))
(56 12
"@@@@@@@@@@@@@@@@"
"@@@@@@@@@@@@@@@@"
"@@@@@L@@C@@@@@@@"
"@@@@@F@@F@@@@@@@"
"@@@@@C@@L@@@@@@@"
"@@@@@AHAH@@@@@@@"
"@@@@@@LC@@@@@@@@"
"@@@@@@FF@@@@@@@@"
"@@@@@@CL@@@@@@@@"
"@@@@@@AH@@@@@@@@"
"@@@@@@@@@@@@@@@@"
"@@@@@@@@@@@@@@@@")
(RPAQ CHUNK.MENU.UP.BITMAP (READBITMAP))
(56 12
"@@@@@@@@@@@@@@@@"
"@@@@@@@@@@@@@@@@"
"@@@@@@AH@@@@@@@@"
"@@@@@@CL@@@@@@@@"
"@@@@@@FF@@@@@@@@"
"@@@@@@LC@@@@@@@@"
"@@@@@AHAH@@@@@@@"
"@@@@@C@@L@@@@@@@"
"@@@@@F@@F@@@@@@@"
"@@@@@L@@C@@@@@@@"
"@@@@@@@@@@@@@@@@"
"@@@@@@@@@@@@@@@@")
(RPAQ KEYWORD.MENU.KEYWORD.BITMAP (READBITMAP))
(24 10
"AL@@@@@@"
"CF@@@@@@"
"FC@@@@@@"
"LAOOOO@@"
"LAOOOO@@"
"FC@@AH@@"
"CF@@GN@@"
"AL@@GF@@"
"@@@@FF@@"
"@@@@DB@@")
(DECLARE: DOEVAL@LOAD
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS .T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CHUNK.MENU.DOWN.BITMAP CHUNK.MENU.UP.BITMAP KEYWORD.MENU.KEYWORD.BITMAP)
)
)
(PUTPROPS PIECE-MENUS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (913 10028 (CHUNK.MENU.CREATE 923 . 3453) (CHUNK.MENU.GET.REAL.MENU 3455 . 3730) (
CHUNK.MENU.INVOKE 3732 . 5203) (KEYWORD.MENU.CREATE 5205 . 6290) (KEYWORD.MENU.GET.MENU 6292 . 7139) (
KEYWORD.MENU.INVOKE 7141 . 8528) (KEYWORD.MENU.MAKE.MENU 8530 . 8753) (PIECE.MENU.MAKE.MENU 8755 .
10026)))))
STOP