(FILECREATED "20-Nov-84 15:47:28" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-UTIL.;3 48325
changes to: (FNS ADD.FRAME.CLASS)
previous date: "19-Nov-84 17:12:16" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-UTIL.;2)
(* Copyright (c) 1984 by Xerox Corporation)
(PRETTYCOMPRINT TRI-UTILCOMS)
(RPAQQ TRI-UTILCOMS [(FNS ACQUIRE.LIST.ITEMS ADD.FRAME.CLASS COLLECT.ITEM COMPARE.ON.PROPERTY
COMPRESS.PROPLIST CONFIRM CONVERT.NONGRIDDED.OFFSETS COORDS
DEFINING.ITEMS.OF.FRAME DEFINING.ITEMS.OF.ITEM DEFINING.ITEMS.OF.PTYPE
DEFINING.PTYPENAMES.OF.ITEM DEFINING.PTYPES.OF.FRAME
DEFINING.PTYPES.OF.ITEM DEFINING.PTYPES.OF.PTYPE DRAW.GRID ENCLOSESP
EVAL.WITHIN.ITEM FIND.BITMAP FIND.COLOR.NUMBER FIND.ENCLOSED.ITEMS
FIND.FRAME FIND.INTERFACE FIND.REPRESENTATIVE.GRAY FLASH.REGION FLIP.BOX
FLIP.ITEM FLIP.REGION.IN.WINDOW FLIP.SPOT FONTS.IN.CORE FRAME.CLASSES
FRAME.NAME FUNCTION.FOR.PTYPE GET.ITEM.TYPE.MENU GET.PARAM.DEFAULT
GET.TRILLIUM.PRINTOUT.WINDOW GRIDIFY GRIDNEAR INDEFINITE INTERFACE.WINDOW
INVERT.MENU.ITEM ITEM.KIND ITEM.TYPE.CLASSES ITEM.TYPE.MENU.ITEM
ITEM.TYPE.PARAMETER ITEM.TYPE.PARAMETER.NAMES ITEM.TYPE.PARAMETER.TYPE
ITEM.TYPES.OF.FRAME ITEM.TYPES.OF.INTERFACE ITEMP LOWERLEFTW MOUSEBUTTONS
NEW.ITEM OBS OFFSPRING OFFSPRING.1 OFFSPRING.N OFFSPRING.OF.DESCRIPTION
ON.GRID PRINT.IN.REGION PRINT.ITEM PRINT.ITEM.TYPES PRINTOUT.ITEM.TYPES
PROMPT.READ PROPLIST.PROPERTIES REPORT.ERROR REPORT.LISP.ERROR
REPORT.TRILLIUM.ERROR RESET.ITEM.TYPE.DESCRIPTION SCREEN.COORDS
SET.CLIPPING.REGION SET.PLACEMENT SORT.ON.PROPERTY STRICTLY.ENCLOSESP
SUPERFRAMES* SWAP.CURSOR.AUX TRILLIUM.CLEAR.ALL.PROMPTING TRILLIUM.EVAL
TRILLIUM.GRID.SETUP TRILLIUM.PRINTOUT.STRING TROUBLE.WITH.TRILLIUM
TTYCONFIRM UNMARK.INTERFACE UNMARK.ITEM.TYPE USED.ITEM.TYPES VECTOR/FROM.TO
WAITBUG WAITNOBUG WAITNOBUG.AUX WALK.FRAME WALK.INTERFACE WALK.ITEM
WALK.OBJECT)
(VARS ITEM.OPERATIONS (TRILLIUM.CLEARPROMPT)
(ITEM.TYPE.MENU)
PLACEMENT.PTYPES PRINT.SEPARATOR.STRING (THINKING.LEVEL 0))
(UGLYVARS READING.CURSOR)
(TEMPLATES GET.FIELDQ SET.FIELDQ THINKING)
(MACROS SWAP.CURSOR)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA
TROUBLE.WITH.TRILLIUM)
(NLAML)
(LAMA])
(DEFINEQ
(ACQUIRE.LIST.ITEMS
[LAMBDA (MENU.LIST MENU.TITLE) (* HaKo " 9-SEP-83 11:01")
(* PT "5-AUG-83 13:23")
(* Function to collect a list of menu items (instead of only one); requires invert.menu.item.
ARGS: list of items and a menu title)
(DECLARE (GLOBALVARS LASTMOUSEX LASTMOUSEY))
(PROG (FRAME.MENU CHOICE POSITION PICKS)
(GETMOUSESTATE)
(SETQ POSITION (CONS LASTMOUSEX LASTMOUSEY))
[SETQ FRAME.MENU (create MENU
ITEMS ←(APPEND (QUOTE (*DONE* *CLEAR* *ALL* (" " NIL)))
MENU.LIST)
CENTERFLG ← T
TITLE ← MENU.TITLE
MENUCOLUMNS ←(ADD1 (IQUOTIENT (LENGTH MENU.LIST)
35]
LOOP(SETQ CHOICE (MENU FRAME.MENU POSITION))
[COND
((EQ CHOICE (QUOTE *DONE*))
(RETURN PICKS))
((EQ CHOICE (QUOTE *CLEAR*))
(for ITEM in PICKS do (INVERT.MENU.ITEM FRAME.MENU ITEM))
(SETQ PICKS NIL))
((EQ CHOICE (QUOTE *ALL*))
(for ITEM in MENU.LIST do (OR (MEMB ITEM PICKS)
(INVERT.MENU.ITEM FRAME.MENU ITEM)))
(SETQ PICKS MENU.LIST))
(CHOICE (INVERT.MENU.ITEM FRAME.MENU CHOICE)
(COND
((MEMB CHOICE PICKS)
(SETQ PICKS (REMOVE CHOICE PICKS)))
(T (SETQ PICKS (CONS CHOICE PICKS]
(GO LOOP])
(ADD.FRAME.CLASS
[LAMBDA (FRAME CLASS) (* edited: "20-Nov-84 15:43")
(* HaKo "25-Jul-84 17:26")
(DECLARE (GLOBALVARS FRAME.NAME.MENU))
(PROG (CLASSES)
[COND
((NULL CLASS)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Name of class for frame " (GET.FIELDQ FRAME NAME)
": ")
(SETQ CLASS (PROMPT.READ]
(SETQ CLASSES (CONS CLASS (GET.FIELDQ FRAME CLASSES)))
(SETQ CLASSES (INTERSECTION CLASSES CLASSES))
(SET.FIELDQ FRAME CLASSES (SORT CLASSES))
(SETQ FRAME.NAME.MENU)
(SETQ CURRENT.BITMAP.FRAMES)
(RETURN CLASSES])
(COLLECT.ITEM
[LAMBDA (ITEM PTYPE CONTEXT SELF ITEMS) (* HaKo "15-Aug-84 14:14")
(* edited: "20-May-84 12:50")
(COND
((OR (NLISTP PTYPE)
(EQ (CAR PTYPE)
(QUOTE ITEM)))
(TCONC ITEMS ITEM)))
NIL])
(COMPARE.ON.PROPERTY
[LAMBDA (OBJECT1 OBJECT2)
(DECLARE (SPECVARS PROP))
(ALPHORDER (LISTGET OBJECT1 PROP)
(LISTGET OBJECT2 PROP])
(COMPRESS.PROPLIST
[LAMBDA (PLST) (* edited: "13-MAR-82 11:58")
(PROG (END)
(SETQ END PLST)
(for ELEM on (CDDR PLST) by (CDDR ELEM) when (CADR ELEM)
do (RPLACD (CDR END)
ELEM)
(SETQ END ELEM)
finally (RPLACD (CDR END)
NIL))
(SETQ END (CDDR PLST))
[COND
((AND END (NULL (CADR PLST)))
(RPLACA PLST (CAR END))
(RPLACD PLST (CDR END]
(RETURN PLST])
(CONFIRM
[LAMBDA (MESSAGE ONLY.IF.BEING.CAREFUL) (* DAHJr "23-Feb-84 14:35")
(DECLARE (GLOBALVARS TRILLIUM.BEING.CAREFUL))
(COND
((AND ONLY.IF.BEING.CAREFUL (NOT TRILLIUM.BEING.CAREFUL))
T)
(T (MENU (create MENU
TITLE ← MESSAGE
ITEMS ←[QUOTE ((YES T)
(NO (QUOTE NIL]
CENTERFLG ← T
CHANGEOFFSETFLG ← T])
(CONVERT.NONGRIDDED.OFFSETS
[LAMBDA (ITEM X.PARAM Y.PARAM NEW.PARAM) (* edited: "21-Aug-84 14:18")
(PROG (X Y DEFAULT.OFFSET)
(SETQ X (GET.FIELD ITEM X.PARAM))
(SETQ Y (GET.FIELD ITEM Y.PARAM))
(COND
((OR X Y)
(SETQ DEFAULT.OFFSET (GET.PARAM.DEFAULT ITEM NEW.PARAM))
(SET.PARAM ITEM X.PARAM)
(SET.PARAM ITEM Y.PARAM)
[SET.PARAM ITEM NEW.PARAM (NEW.POSITION (OR X (fetch (POSITION XCOORD) of
DEFAULT.OFFSET))
(OR Y (fetch (POSITION YCOORD) of
DEFAULT.OFFSET]
(COMPRESS.PROPLIST ITEM])
(COORDS
[LAMBDA (PLACEMENT) (* DAHJr "18-APR-83 17:51")
(DECLARE (GLOBALVARS TRILLIUM.GRID.DX TRILLIUM.GRID.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0))
(COND
[(NLISTP (CDR PLACEMENT))
(create POSITION
XCOORD ←(XCOORD (fetch (LOCATION X) of PLACEMENT))
YCOORD ←(YCOORD (fetch (LOCATION Y) of PLACEMENT]
[(LISTP (CDDDDR PLACEMENT))
(create POSITION2
XCOORD1 ←(XCOORD (fetch (LOCATION2 X1) of PLACEMENT))
YCOORD1 ←(YCOORD (fetch (LOCATION2 Y1) of PLACEMENT))
XCOORD2 ←(XCOORD (fetch (LOCATION2 X2) of PLACEMENT))
YCOORD2 ←(YCOORD (fetch (LOCATION2 Y2) of PLACEMENT]
(T (create REGION
LEFT ←(XCOORD (fetch (GRIDREGION LEFT) of PLACEMENT))
BOTTOM ←(YCOORD (fetch (GRIDREGION BOTTOM) of PLACEMENT))
WIDTH ←(XDIST (fetch (GRIDREGION WIDTH) of PLACEMENT))
HEIGHT ←(YDIST (fetch (GRIDREGION HEIGHT) of PLACEMENT])
(DEFINING.ITEMS.OF.FRAME
[LAMBDA (FRAME) (* HaKo "15-Aug-84 14:14")
(* DAHJr "28-MAR-83 15:48")
(PROG ((ITEMS (CONS)))
(WALK.FRAME FRAME NIL (FUNCTION COLLECT.ITEM)
ITEMS)
(RETURN (CAR ITEMS])
(DEFINING.ITEMS.OF.ITEM
[LAMBDA (ITEM) (* DAHJr " 5-DEC-83 17:10")
(PROG (ITYPE PARAMETERS SUBITEMS VALUE)
(SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ PARAMETERS (GET.FIELDQ (ITEM.TYPE.DESCRIPTION ITYPE)
PARAMETERS ITEM.TYPE))
(SETQ SUBITEMS (for PARAMETER in PARAMETERS WHEN (SETQ VALUE (LISTGET ITEM
(GET.FIELDQ PARAMETER
NAME)))
join (DEFINING.ITEMS.OF.PTYPE (GET.FIELDQ PARAMETER TYPE)
VALUE)))
(RETURN (CONS ITEM SUBITEMS])
(DEFINING.ITEMS.OF.PTYPE
[LAMBDA (PTYPE OBJECT) (* HaKo " 8-SEP-83 12:35")
(COND
((LISTP PTYPE) (* A LISP OBJECT)
(SELECTQ (CAR PTYPE)
(ITEM (DEFINING.ITEMS.OF.ITEM OBJECT))
(LIST (for SUB.OBJECT in OBJECT bind (SUB.TYPE ←(CADR PTYPE))
join (DEFINING.ITEMS.OF.PTYPE SUB.TYPE SUB.OBJECT)))
(STRUCTURE (for FIELD in (CADR PTYPE) as SUB.OBJECT in OBJECT
join (DEFINING.ITEMS.OF.PTYPE (CADR FIELD)
SUB.OBJECT)))
NIL))
(T (* AN ITEM OF SPECIFIED TYPE)
(DEFINING.ITEMS.OF.ITEM OBJECT])
(DEFINING.PTYPENAMES.OF.ITEM
[LAMBDA (PTYPE ITEM) (* HaKo "27-Jul-84 16:38")
(PROG (SUB.OBJECTS (ITYPE (ITEM.TYPE ITEM)))
[SETQ SUB.OBJECTS (COND
((EQ ITYPE (QUOTE GROUP))
(for SUBITEM in (GET.PARAMQ ITEM MEMBERS) join (DEFINING.PTYPENAMES.OF.ITEM PTYPE
SUBITEM)))
(T (for PARAMETER in (GET.FIELDQ (ITEM.TYPE.DESCRIPTION ITYPE)
PARAMETERS ITEM.TYPE)
join (DEFINING.PTYPES.OF.PTYPE PTYPE (GET.FIELDQ PARAMETER TYPE)
(GET.FIELDQ PARAMETER NAME]
(RETURN (COND
((EQ PTYPE ITYPE)
(CONS ITEM SUB.OBJECTS))
(T SUB.OBJECTS])
(DEFINING.PTYPES.OF.FRAME
[LAMBDA (PTYPE FRAME) (* DAHJr "28-MAR-83 16:10")
(for ITEM in (GET.FIELDQ FRAME ITEMS) join (DEFINING.PTYPES.OF.ITEM PTYPE ITEM])
(DEFINING.PTYPES.OF.ITEM
[LAMBDA (PTYPE ITEM) (* HaKo "27-Jul-84 16:53")
(PROG (SUB.OBJECTS (ITYPE (ITEM.TYPE ITEM)))
[SETQ SUB.OBJECTS (COND
((EQ ITYPE (QUOTE GROUP))
(for SUBITEM in (GET.PARAMQ ITEM MEMBERS) join (DEFINING.PTYPES.OF.ITEM PTYPE SUBITEM)
))
(T (for PARAMETER in (GET.FIELDQ (ITEM.TYPE.DESCRIPTION ITYPE)
PARAMETERS ITEM.TYPE)
join (DEFINING.PTYPES.OF.PTYPE PTYPE (GET.FIELDQ PARAMETER TYPE)
(GET.PARAM ITEM (GET.FIELDQ PARAMETER NAME]
(RETURN (COND
((EQ PTYPE ITYPE)
(CONS ITEM SUB.OBJECTS))
(T SUB.OBJECTS])
(DEFINING.PTYPES.OF.PTYPE
[LAMBDA (DESIRED.PTYPE PTYPE OBJECT) (* DAHJr "28-MAR-83 16:10")
(PROG (SUB.OBJECTS SUB.TYPE)
[SETQ SUB.OBJECTS (COND
((LISTP PTYPE) (* A LISP OBJECT)
(SELECTQ (CAR PTYPE)
(ITEM (DEFINING.PTYPES.OF.ITEM DESIRED.PTYPE OBJECT))
(LIST (SETQ SUB.TYPE (CADR PTYPE))
(for SUB.OBJECT in OBJECT join (DEFINING.PTYPES.OF.PTYPE DESIRED.PTYPE
SUB.TYPE
SUB.OBJECT)))
(STRUCTURE (for FIELD in (CADR PTYPE) as SUB.OBJECT in OBJECT
join (DEFINING.PTYPES.OF.PTYPE DESIRED.PTYPE (CADR FIELD)
SUB.OBJECT)))
NIL))
(T (* AN ITEM OF SPECIFIED TYPE)
(DEFINING.PTYPES.OF.ITEM DESIRED.PTYPE OBJECT]
(RETURN (COND
((EQUAL DESIRED.PTYPE PTYPE)
(CONS OBJECT SUB.OBJECTS))
(T SUB.OBJECTS])
(DRAW.GRID
[LAMBDA NIL (* HaKo "27-Jul-84 10:26")
(* * Flipflop which draws or removes a grid from the current interface window. Grid is displayed either with lines
or points.)
(DECLARE (GLOBALVARS CURRENT.INTERFACE.WINDOW TRILLIUM.GRID.DX TRILLIUM.GRID.DY
TRILLIUM.GRID.POINTS.FLG TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0))
(PROG ((ORIGX TRILLIUM.GRID.X0)
(ORIGY TRILLIUM.GRID.Y0)
(DELTAX TRILLIUM.GRID.DX)
(DELTAY TRILLIUM.GRID.DY)
(MAXX (WINDOWPROP CURRENT.INTERFACE.WINDOW (QUOTE WIDTH)))
(MAXY (WINDOWPROP CURRENT.INTERFACE.WINDOW (QUOTE HEIGHT)))
(GRIDDSP (WINDOWPROP CURRENT.INTERFACE.WINDOW (QUOTE DSP)))
(GRIDOPERATION (QUOTE INVERT)))
(if TRILLIUM.GRID.POINTS.FLG
then [for X from ORIGX to MAXX by DELTAX
do (for Y from ORIGY to MAXY by DELTAY
do (BITMAPBIT GRIDDSP X Y (if (ZEROP (BITMAPBIT GRIDDSP X Y))
then 1
else 0]
else (for X from ORIGX to MAXX by DELTAX
do (DRAWLINE X 0 X MAXY 1 GRIDOPERATION GRIDDSP))
(for Y from ORIGY to MAXY by DELTAY
do (DRAWLINE 0 Y MAXX Y 1 GRIDOPERATION GRIDDSP])
(ENCLOSESP
[LAMBDA (ENCLOSINGREGION ENCLOSEDREGION) (* edited: " 1-MAR-82 13:28")
(AND (NOT (IGREATERP (fetch (REGION LEFT) of ENCLOSINGREGION)
(fetch (REGION LEFT) of ENCLOSEDREGION)))
(NOT (IGREATERP (fetch (REGION BOTTOM) of ENCLOSINGREGION)
(fetch (REGION BOTTOM) of ENCLOSEDREGION)))
(NOT (ILESSP (fetch (REGION RIGHT) of ENCLOSINGREGION)
(fetch (REGION RIGHT) of ENCLOSEDREGION)))
(NOT (ILESSP (fetch (REGION TOP) of ENCLOSINGREGION)
(fetch (REGION TOP) of ENCLOSEDREGION])
(EVAL.WITHIN.ITEM
[LAMBDA (FORM ITEM) (* HaKo "27-Jul-84 16:53")
(PROG (ITYPE DESCRIPTION ITEMS BINDINGS)
(SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
[SETQ BINDINGS (for PARAMETER.NAME in (ITEM.TYPE.PARAMETER.NAMES ITYPE)
collect (CONS PARAMETER.NAME (GET.PARAM ITEM PARAMETER.NAME]
(RETURN (EVALA FORM BINDINGS])
(FIND.BITMAP
[LAMBDA (BITMAP.NAME) (* HaKo "27-Jul-84 16:39")
(DECLARE (GLOBALVARS CURRENT.BITMAP.FRAMES CURRENT.FRAME UNKNOWN.BITMAP))
(for FRAME bind (BITMAP) in (CONS CURRENT.FRAME (OR CURRENT.BITMAP.FRAMES (
SET.CURRENT.BITMAP.FRAMES)))
when [SETQ BITMAP (for ITEM in (GET.FIELDQ FRAME ITEMS FRAME)
when (AND (EQUAL (ITEM.TYPE ITEM)
(QUOTE BITMAP))
(EQUAL (GET.PARAMQ ITEM NAME)
BITMAP.NAME))
do (RETURN (GET.PARAMQ ITEM BITMAP]
do (RETURN BITMAP)
finally (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS T "Can't find bitmap " BITMAP.NAME T)
(RETURN UNKNOWN.BITMAP])
(FIND.COLOR.NUMBER
[LAMBDA (COLOR.NAME) (* HaKo "27-Jul-84 16:40")
(DECLARE (GLOBALVARS CURRENT.INTERFACE))
(SELECTQ COLOR.NAME
(CLEAR NIL)
(WHITE 0)
(BLACK 15)
(for ITEM in (GET.FIELDQ (FIND.FRAME CURRENT.INTERFACE (QUOTE COLORS))
ITEMS FRAME)
when (AND (EQ (ITEM.TYPE ITEM)
(QUOTE COLOR))
(EQ (GET.PARAMQ ITEM NAME)
COLOR.NAME))
do (RETURN (GET.PARAMQ ITEM COLOR)) finally (RETURN 15])
(FIND.ENCLOSED.ITEMS
[LAMBDA (REGION FRAME) (* edited: "23-JUN-82 12:51")
(for ITEM in (GET.FIELDQ FRAME ITEMS FRAME) when (AND (TYPE.DEFINEDP ITEM)
(ENCLOSESP REGION (GET.FIELDQ ITEM
BOUNDING.BOX)))
collect ITEM])
(FIND.FRAME
[LAMBDA (INTERFACE FRAME.NAME) (* edited: "15-APR-83 17:50")
(COND
((ATOM FRAME.NAME)
(for FRAME in (GET.FIELDQ INTERFACE FRAMES INTERFACE) do (COND
((EQ (GET.FIELDQ FRAME NAME FRAME)
FRAME.NAME)
(RETURN FRAME)))
finally (RETURN NIL)))
((AND (LISTP FRAME.NAME)
(EQ (CAR FRAME.NAME)
(QUOTE FRAME)))
FRAME.NAME)
(T (TROUBLE.WITH.TRILLIUM "Unrecognized frame/frame.name" FRAME.NAME])
(FIND.INTERFACE
[LAMBDA (INTERFACE.NAME) (* edited: "15-APR-83 17:14")
(DECLARE (GLOBALVARS INTERFACES))
(COND
((MEMBER INTERFACE.NAME INTERFACES)
(GETDEF.INTERFACE INTERFACE.NAME (QUOTE INTERFACES)))
(T NIL])
(FIND.REPRESENTATIVE.GRAY
[LAMBDA (COLOR.NAME) (* HaKo "27-Jul-84 16:40")
(DECLARE (GLOBALVARS CURRENT.INTERFACE))
(SELECTQ COLOR.NAME
(WHITE WHITESHADE)
(BLACK BLACKSHADE)
(for ITEM in (GET.FIELDQ (FIND.FRAME CURRENT.INTERFACE (QUOTE COLORS))
ITEMS FRAME)
when (AND (EQ (ITEM.TYPE ITEM)
(QUOTE COLOR))
(EQ (GET.PARAMQ ITEM NAME)
COLOR.NAME))
do (RETURN (GET.PARAMQ ITEM REPRESENTATIVE.GRAY)) finally (RETURN 42405])
(FLASH.REGION
[LAMBDA (REGION WINDOW) (* DAHJr "22-APR-83 18:52")
(DECLARE (GLOBALVARS BLACKSHADE))
(FLIP.REGION.IN.WINDOW REGION WINDOW BLACKSHADE)
(TRILLIUM.PAUSE 200)
(FLIP.REGION.IN.WINDOW REGION WINDOW BLACKSHADE])
(FLIP.BOX
[LAMBDA (BOX TEXTURE) (* kkm "19-Nov-84 14:05")
(DECLARE (GLOBALVARS CURRENT.DSP IN.LIVING.COLOR))
(FLIP.REGION.IN.WINDOW BOX CURRENT.DSP TEXTURE)
(COND
(IN.LIVING.COLOR (COLORFILL BOX 8 NIL (QUOTE INVERT])
(FLIP.ITEM
[LAMBDA (ITEM) (* HaKo "27-Jul-84 16:41")
(DECLARE (GLOBALVARS CURRENT.INTERFACE.WINDOW))
(PROG (BOX NAME)
(SETQ BOX (BOUNDING.BOX ITEM))
(COND
[BOX (FLIP.BOX BOX)
(SETQ NAME (GET.PARAMQ ITEM NAME))
(COND
(NAME (PRINT.IN.REGION NAME CURRENT.INTERFACE.WINDOW BOX (QUOTE CENTER)
(QUOTE CENTER)
(QUOTE INPUT)
(QUOTE INVERT]
(T (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS
"Item with undefined bounding box encountered: "
ITEM])
(FLIP.REGION.IN.WINDOW
[LAMBDA (REGION WINDOW TEXTURE) (* DAHJr "22-APR-83 19:04")
(DECLARE (GLOBALVARS CURRENT.INTERFACE.WINDOW))
(BITBLT NIL NIL NIL (OR WINDOW CURRENT.INTERFACE.WINDOW)
(fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
(fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
(QUOTE TEXTURE)
(QUOTE INVERT)
(OR TEXTURE BLACKSHADE])
(FLIP.SPOT
[LAMBDA (XCOORD YCOORD) (* edited: "15-MAR-82 16:33")
(DECLARE (GLOBALVARS CURRENT.DSP TRILLIUM.SPOT.BITMAP))
(PROG (WIDTH HEIGHT)
(SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of TRILLIUM.SPOT.BITMAP))
(SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of TRILLIUM.SPOT.BITMAP))
(BITBLT TRILLIUM.SPOT.BITMAP 0 0 CURRENT.DSP (IDIFFERENCE XCOORD (IQUOTIENT WIDTH 2))
(IDIFFERENCE YCOORD (IQUOTIENT HEIGHT 2))
WIDTH HEIGHT (QUOTE INPUT)
(QUOTE INVERT])
(FONTS.IN.CORE
[LAMBDA NIL (* edited: " 4-DEC-82 15:28")
(DECLARE (GLOBALVARS \FONTSINCORE))
(for FAMILY in \FONTSINCORE join (for SIZE in (CDR FAMILY)
join (for FACE in (CDR SIZE)
when (EQ (CAR (CADR (CADR FACE)))
(QUOTE DISPLAY))
collect (LIST (CAR FAMILY)
(CAR SIZE)
(CAR FACE])
(FRAME.CLASSES
[LAMBDA (FRAME) (* T.Bigham "16-Oct-84 03:40")
(PROG (CLASSES (FRAME.NAME (GET.FIELDQ FRAME NAME)))
(SETQ CLASSES (DREMOVE NIL (GET.FIELDQ FRAME CLASSES)))
(for CLASSDEFPTR on (GET.FIELDQ TRILLIUM.PROFILE FRAME.CLASSES) by (CDDR CLASSDEFPTR)
when (MEMB FRAME.NAME (CADR CLASSDEFPTR)) do (SETQ CLASSES (CONS (CAR CLASSDEFPTR)
CLASSES)))
(RETURN (COND
(CLASSES (SORT (INTERSECTION CLASSES CLASSES)))
(T (QUOTE (UNCLASSIFIED])
(FRAME.NAME
[LAMBDA (FRAME)
(GET.FIELDQ FRAME NAME])
(FUNCTION.FOR.PTYPE
[LAMBDA (PTYPE SELECTOR) (* HaKo "17-Aug-84 16:14")
(GETPROP (COND
((LISTP PTYPE)
(CAR PTYPE))
(T PTYPE))
SELECTOR])
(GET.ITEM.TYPE.MENU
[LAMBDA NIL (* DAHJr " 7-APR-83 20:51")
(DECLARE (GLOBALVARS ITEM.TYPE.MENU ITEM.TYPES))
[OR (EQUAL (CAR ITEM.TYPE.MENU)
ITEM.TYPES)
(SETQ ITEM.TYPE.MENU (CONS (COPYALL ITEM.TYPES)
(create MENU
TITLE ← "Choose item type"
ITEMS ←(for ITYPE in ITEM.TYPES
collect (LIST ITYPE (KWOTE ITYPE)
(GET.FIELDQ (ITEM.TYPE.DESCRIPTION
ITYPE)
COMMENT ITEM.TYPE)))
CHANGEOFFSETFLG ← T]
(CDR ITEM.TYPE.MENU])
(GET.PARAM.DEFAULT
[LAMBDA (ITEM PARAM.NAME) (* HaKo " 6-Aug-84 12:02")
(CDR (FASSOC PARAM.NAME (GETPROP (ITEM.TYPE ITEM)
(QUOTE DEFAULTS])
(GET.TRILLIUM.PRINTOUT.WINDOW
[LAMBDA (WINDOW.NAME BREAK.TYPE) (* PH " 7-Sep-84 17:46")
(* HaKo "17-Aug-84 17:38")
(* ACTS LIKE PRINTOUT FOR SOME CASES; IF TRILLIUM.CLEARPROMPT IS T THEN CLEARS THE WINDOW, OTHERWISE PUTS IN AN
AUTOMATIC CR; FIRST SPEC MAY BE A KEYWORD: SAME.LINE -
NO INITIAL CR; SAME.BLOCK -
NEVER CLEARS THE WINDOW;)
(DECLARE (GLOBALVARS PROMPTWINDOW TRILLIUM.CLEARPROMPT TRILLIUM.DESCRIPTIONS.WINDOW
TRILLIUM.HAVE.PROMPTED))
(PROG (WINDOW)
(SETQ WINDOW (COND
((EQ WINDOW.NAME (QUOTE TRILLIUM.DESCRIPTIONS))
TRILLIUM.DESCRIPTIONS.WINDOW)
(T PROMPTWINDOW)))
(* * OLD WAY (if (NULL WINDOW) then (TRILLIUM.PRINTOUT "Indicate a region for the window " WINDOW.NAME)
(SETQ WINDOW (CREATEW NIL WINDOW.NAME)) (DSPSCROLL (QUOTE ON) (WINDOWPROP WINDOW (QUOTE DSP)))
(LISTPUT TRILLIUM.PRINTOUT.WINDOWS WINDOW.NAME WINDOW)))
(SELECTQ BREAK.TYPE
[NEW.BLOCK (COND
(TRILLIUM.CLEARPROMPT (CLEARW WINDOW))
(T (TERPRI WINDOW]
(SAME.BLOCK (TERPRI WINDOW))
(SAME.LINE NIL)
(SHOULDNT "Unrecognized key in TRILLIUM.PRINTOUT"))
[COND
((EQ WINDOW.NAME (QUOTE TRILLIUM.DESCRIPTIONS))
(PROG [(DSP (WINDOWPROP WINDOW (QUOTE DSP]
(COND
((ILESSP (DSPYPOSITION NIL DSP)
(FONTPROP (DSPFONT NIL DSP)
(QUOTE HEIGHT)))
(PAGEFULLFN DSP)
(CLEARW WINDOW]
(SETQ TRILLIUM.HAVE.PROMPTED T) (* Is this needed?)
(RETURN WINDOW])
(GRIDIFY
[LAMBDA (PLACEMENT) (* HK "21-JUL-82 15:17")
(DECLARE (GLOBALVARS TRILLIUM.GRID.DX TRILLIUM.GRID.DY TRILLIUM.GRID.HALF.DX
TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0))
(COND
[(NLISTP (CDR PLACEMENT))
(create POSITION
XCOORD ←(XGRIDIFY (fetch (POSITION XCOORD) of PLACEMENT))
YCOORD ←(YGRIDIFY (fetch (POSITION YCOORD) of PLACEMENT]
[(LISTP (CDDDDR PLACEMENT))
(create POSITION2
XCOORD1 ←(XGRIDIFY (fetch (POSITION2 XCOORD1) of PLACEMENT))
YCOORD1 ←(YGRIDIFY (fetch (POSITION2 YCOORD1) of PLACEMENT))
XCOORD2 ←(XGRIDIFY (fetch (POSITION2 XCOORD2) of PLACEMENT))
YCOORD2 ←(YGRIDIFY (fetch (POSITION2 YCOORD2) of PLACEMENT]
(T (create REGION
LEFT ←(XGRIDIFY (fetch (REGION LEFT) of PLACEMENT))
BOTTOM ←(YGRIDIFY (fetch (REGION BOTTOM) of PLACEMENT))
WIDTH ←(fetch (REGION WIDTH) of PLACEMENT)
HEIGHT ←(fetch (REGION HEIGHT) of PLACEMENT])
(GRIDNEAR
[LAMBDA (PLACEMENT) (* HK "21-JUL-82 15:18")
(DECLARE (GLOBALVARS TRILLIUM.GRID.DX TRILLIUM.GRID.DY TRILLIUM.GRID.HALF.DX
TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0))
(COND
[(NLISTP (CDR PLACEMENT))
(create LOCATION
X ←(XGRIDNEAR (fetch (POSITION XCOORD) of PLACEMENT))
Y ←(YGRIDNEAR (fetch (POSITION YCOORD) of PLACEMENT]
[(LISTP (CDDDDR PLACEMENT))
(create LOCATION2
X1 ←(XGRIDNEAR (fetch (POSITION2 XCOORD1) of PLACEMENT))
Y1 ←(YGRIDNEAR (fetch (POSITION2 YCOORD1) of PLACEMENT))
X2 ←(XGRIDNEAR (fetch (POSITION2 XCOORD2) of PLACEMENT))
Y2 ←(YGRIDNEAR (fetch (POSITION2 YCOORD2) of PLACEMENT]
(T (create GRIDREGION
LEFT ←(XGRIDNEAR (fetch (REGION LEFT) of PLACEMENT))
BOTTOM ←(YGRIDNEAR (fetch (REGION BOTTOM) of PLACEMENT))
WIDTH ←(XDIST (fetch (REGION WIDTH) of PLACEMENT))
HEIGHT ←(YDIST (fetch (REGION HEIGHT) of PLACEMENT])
(INDEFINITE
[LAMBDA (NAME) (* DAHJr "10-AUG-83 20:42")
(MKATOM (CONCAT "{" NAME "}"])
(INTERFACE.WINDOW
[LAMBDA (WINDOW) (* DAHJr " 3-AUG-83 09:01")
(PROG (WINDOW.DEPENDED.UPON)
(SETQ WINDOW.DEPENDED.UPON (WINDOW.DEPENDED.UPON WINDOW))
(RETURN (COND
((NULL WINDOW.DEPENDED.UPON)
NIL)
((EQ (WINDOWPROP WINDOW.DEPENDED.UPON (QUOTE TRILLIUM.WINDOW.TYPE))
(QUOTE INTERFACE.WINDOW))
WINDOW.DEPENDED.UPON)
(T (INTERFACE.WINDOW WINDOW.DEPENDED.UPON])
(INVERT.MENU.ITEM
[LAMBDA (MENUX ITEM) (* SGK "11-AUG-83 09:01")
(* This inverts a menu item by BITBLT to the menu's
bitmap. Requires a complete menu arg and the item to
invert)
(DECLARE (GLOBALVARS BLACKSHADE))
(PROG (ITEM.REGION)
(COND
((MEMBER ITEM (fetch (MENU ITEMS) of MENUX))
(SETQ ITEM.REGION (MENUITEMREGION ITEM MENUX))
(BITBLT NIL NIL NIL (FETCHFIELD (QUOTE (WINDOW 4 POINTER))
(fetch (MENU IMAGE) of MENUX))
(fetch (REGION LEFT) of ITEM.REGION)
(fetch (REGION BOTTOM) of ITEM.REGION)
(fetch (REGION WIDTH) of ITEM.REGION)
(fetch (REGION HEIGHT) of ITEM.REGION)
(QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE NIL])
(ITEM.KIND
[LAMBDA (ITEM) (* DAHJr " 7-APR-83 20:51")
(GET.FIELDQ (ITEM.TYPE.DESCRIPTION (ITEM.TYPE ITEM))
KIND ITEM.TYPE])
(ITEM.TYPE.CLASSES
[LAMBDA (ITYPE.NAME) (* HaKo "17-Aug-84 12:10")
(PROG ((CLASSES (GET.FIELDQ (ITEM.TYPE.DESCRIPTION ITYPE.NAME)
CLASSES)))
(for CLASSDEFPTR on (GET.FIELDQ TRILLIUM.PROFILE ITEM.TYPE.CLASSES) by CDDR
when (MEMB ITYPE.NAME (CADR CLASSDEFPTR)) do (SETQ CLASSES (CONS (CAR CLASSDEFPTR)
CLASSES)))
(RETURN (COND
(CLASSES (SORT (INTERSECTION CLASSES CLASSES)))
(T (QUOTE (UNCLASSIFIED])
(ITEM.TYPE.MENU.ITEM
[LAMBDA (ITYPE) (* edited: "13-Jun-84 17:07")
(LIST ITYPE (KWOTE ITYPE)
(GET.FIELDQ (ITEM.TYPE.DESCRIPTION ITYPE)
COMMENT])
(ITEM.TYPE.PARAMETER
[LAMBDA (ITEM.TYPE FIELD) (* DAHJr "23-JUN-83 17:41")
(for PARAMETER in (GET.FIELDQ (ITEM.TYPE.DESCRIPTION ITEM.TYPE)
PARAMETERS ITEM.TYPE)
when (EQ (GET.FIELDQ PARAMETER NAME)
FIELD)
do (RETURN PARAMETER) finally (SHOULDNT "Unrecognized field in ITEM.TYPE.PARAMETER.TYPE"])
(ITEM.TYPE.PARAMETER.NAMES
[LAMBDA (ITEM.TYPE) (* DAHJr "23-JUN-83 17:41")
(for PARAMETER in (GET.FIELDQ (ITEM.TYPE.DESCRIPTION ITEM.TYPE)
PARAMETERS ITEM.TYPE)
collect (GET.FIELDQ PARAMETER NAME])
(ITEM.TYPE.PARAMETER.TYPE
[LAMBDA (ITEM.TYPE FIELD) (* DAHJr "23-JUN-83 17:42")
(GET.FIELDQ (ITEM.TYPE.PARAMETER ITEM.TYPE FIELD)
TYPE])
(ITEM.TYPES.OF.FRAME
[LAMBDA (FRAME) (* edited: " 4-OCT-82 17:01")
(PROG (TYPES)
(SETQ TYPES (for ITEM in (GET.FIELDQ FRAME ITEMS FRAME) collect (ITEM.TYPE ITEM)))
(RETURN (SORT (INTERSECTION TYPES TYPES])
(ITEM.TYPES.OF.INTERFACE
[LAMBDA (DIALOG) (* edited: " 4-OCT-82 17:01")
(PROG (TYPES)
(SETQ TYPES (for FRAME in (GET.FIELDQ DIALOG FRAMES) join (ITEM.TYPES.OF.FRAME FRAME)))
(RETURN (SORT (INTERSECTION TYPES TYPES])
(ITEMP
[LAMBDA (OBJECT) (* DAHJr "10-AUG-83 20:33")
(AND (LISTP OBJECT)
(EQ (CAR OBJECT)
(QUOTE \TYPE))
(ITEM.TYPE.DESCRIPTION (CADR OBJECT])
(LOWERLEFTW
[LAMBDA (WINDOW) (* DAHJr "12-NOV-81 16:21")
(WXOFFSET (WXOFFSET NIL WINDOW)
WINDOW)
(WYOFFSET (WYOFFSET NIL WINDOW)
WINDOW])
(MOUSEBUTTONS
[LAMBDA NIL (* DAHJr "23-MAR-81 16:36")
(DECLARE (GLOBALVARS LASTMOUSEBUTTONS))
(GETMOUSESTATE)
LASTMOUSEBUTTONS])
(NEW.ITEM
[LAMBDA (ITEM.TYPE WITH.DEFAULTS) (* HaKo "27-Jul-84 17:15")
(PROG (NEW.ITEM)
(SETQ NEW.ITEM (LIST (QUOTE \TYPE)
ITEM.TYPE))
[COND
(WITH.DEFAULTS (for PARAMETER.NAME in (ITEM.TYPE.PARAMETER.NAMES ITEM.TYPE)
do (SET.PARAM NEW.ITEM PARAMETER.NAME (GET.PARAM.DEFAULT NEW.ITEM
PARAMETER.NAME]
(RETURN NEW.ITEM])
(OBS
[LAMBDA (MESSAGE) (* HaKo " 7-Aug-84 12:54")
(DECLARE (SPECVARS ITEM))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Obsolete function: " (STKNTHNAME -1 (QUOTE OBS)))
(COND
(MESSAGE (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS SAME.LINE " : " MESSAGE)))
[COND
((BOUNDP (QUOTE ITEM))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS SAME.LINE " for " (ITEM.TYPE ITEM]
(ERROR])
(OFFSPRING
[LAMBDA (ITYPE) (* edited: "31-MAR-82 18:22")
(OFFSPRING.OF.DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE])
(OFFSPRING.1
[LAMBDA (SPEC OFFSPRING) (* HK "21-JUL-82 13:52")
(SELECTQ (CAR SPEC)
[ITEM (OR (LISTP (CADR SPEC))
(TCONC OFFSPRING (CADR SPEC]
(FOREACH (OFFSPRING.N (CDR (MEMB (QUOTE DO)
(CDR SPEC)))
OFFSPRING))
(LABEL (OFFSPRING.1 (CADDR SPEC)
OFFSPRING))
(SELECT (for PHRASE in (CDDR SPEC) do (OFFSPRING.N (CDR PHRASE)
OFFSPRING)))
(IF (for PHRASE in (CDDR SPEC) unless (OR (EQ PHRASE (QUOTE THEN))
(EQ PHRASE (QUOTE ELSE)))
do (OFFSPRING.1 PHRASE OFFSPRING)))
((INCREMENT HELP))
(EVAL (for TYPE in (CADDR SPEC) do (TCONC OFFSPRING TYPE)))
(SHOULDNT "Unrecognized keyword in OFFSPRING.1"])
(OFFSPRING.N
[LAMBDA (SPECS OFFSPRING)
(for SPEC in SPECS do (OFFSPRING.1 SPEC OFFSPRING])
(OFFSPRING.OF.DESCRIPTION
[LAMBDA (DESCRIPTION) (* DAHJr " 7-APR-83 20:52")
(PROG ((OFFSPRING (CONS)))
(OFFSPRING.N (GET.FIELDQ DESCRIPTION SUBITEM.SPECS ITEM.TYPE)
OFFSPRING)
(SETQ OFFSPRING (CAR OFFSPRING))
(RETURN (SORT (INTERSECTION OFFSPRING OFFSPRING])
(ON.GRID
[LAMBDA (ITEM) (* DAHJr "23-JUN-83 17:43")
(COND
([for PARAMETER in (GET.FIELDQ (ITEM.TYPE.DESCRIPTION (ITEM.TYPE ITEM))
PARAMETERS ITEM.TYPE)
bind PTYPE
thereis (SETQ PTYPE (GET.FIELDQ PARAMETER TYPE))
(AND (LISTP PTYPE)
(FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE LTRANSLATE]
T)
(T NIL])
(PRINT.IN.REGION
[LAMBDA (OBJECT DSP REGION X.ALIGNMENT Y.ALIGNMENT SOURCE OPERATION TEXTURE FONT)
(* HaKo " 8-SEP-83 11:59")
(DECLARE (GLOBALVARS CURRENT.DSP))
(OR DSP (SETQ DSP CURRENT.DSP))
(OR FONT (SETQ FONT (DSPFONT NIL DSP)))
(PROG ((LEFT (fetch (REGION LEFT) of REGION))
(BOTTOM (fetch (REGION BOTTOM) of REGION))
(WIDTH (fetch (REGION WIDTH) of REGION))
(HEIGHT (fetch (REGION HEIGHT) of REGION))
(FONT.HEIGHT (FONTPROP FONT (QUOTE HEIGHT)))
LINES.X LINES.Y)
(RESETFORM (SET.CLIPPING.REGION REGION)
[SETQ LINES.X (SELECTQ X.ALIGNMENT
(LEFT LEFT)
(RIGHT (IPLUS LEFT WIDTH))
(IPLUS LEFT (RSH WIDTH 1]
[SETQ LINES.Y (SELECTQ Y.ALIGNMENT
(BOTTOM BOTTOM)
(TOP (IPLUS BOTTOM (IDIFFERENCE HEIGHT FONT.HEIGHT)))
(IPLUS BOTTOM (RSH (IDIFFERENCE HEIGHT FONT.HEIGHT)
1]
(SHOW.PRINTED.LINES (MKLIST OBJECT)
LINES.X LINES.Y X.ALIGNMENT Y.ALIGNMENT SOURCE OPERATION
TEXTURE FONT DSP])
(PRINT.ITEM
[LAMBDA (ITEM) (* HaKo "16-Aug-84 16:35")
(PROG (ITEM.TYPE PARAMETER.NAMES FIELD.NAMES)
(SETQ ITEM.TYPE (ITEM.TYPE ITEM))
(TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS SAME.BLOCK "An item of type " ITEM.TYPE)
(COND
((TYPE.DEFINEDP ITEM)
(SETQ PARAMETER.NAMES (ITEM.TYPE.PARAMETER.NAMES ITEM.TYPE))
(for PARAMETER.NAME in PARAMETER.NAMES do (TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS
SAME.BLOCK " "
PARAMETER.NAME "="
(GET.PARAM ITEM
PARAMETER.NAME)
"; ")))
(T (SETQ PARAMETER.NAMES NIL)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS SAME.BLOCK " " " this type is undefined"
"; ")))
(SETQ FIELD.NAMES (PROPLIST.PROPERTIES ITEM))
(SETQ FIELD.NAMES (LDIFFERENCE FIELD.NAMES PARAMETER.NAMES))
[SETQ FIELD.NAMES (LDIFFERENCE FIELD.NAMES (QUOTE (\TYPE SUBITEMS BOUNDING.BOX]
[COND
(FIELD.NAMES (TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS SAME.BLOCK "other information: ")
(for FIELD.NAME in FIELD.NAMES do (TRILLIUM.PRINTOUT ON
TRILLIUM.DESCRIPTIONS
SAME.BLOCK " "
FIELD.NAME "="
(GET.FIELD ITEM
FIELD.NAME)
"; "]
(RETURN])
(PRINT.ITEM.TYPES
[LAMBDA (FRAME) (* HaKo "16-Aug-84 16:36")
(DECLARE (GLOBALVARS PRINT.SEPARATOR.STRING))
(PROG (ITYPE ANY)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Select item.types to be printed; stop by missing.")
(while (SETQ ITYPE (ACQUIRE.ITEM.TYPE))
do (TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS PRINT.SEPARATOR.STRING)
(PRINT.ITEM.TYPE ITYPE)
(SETQ ANY T))
(COND
(ANY (TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS PRINT.SEPARATOR.STRING T])
(PRINTOUT.ITEM.TYPES
[LAMBDA (FILENAME) (* edited: " 5-JUL-82 16:32")
(DECLARE (GLOBALVARS ITEM.TYPES USERNAME))
(PROG (FN)
(SETQ FN (OR FILENAME (QUOTE TRILLIUM-ITEM-TYPES)))
(RETURN (RESETFORM (OUTFILE FN)
(THINKING (printout NIL "Trillium item types; " USERNAME "; " (DATE))
(printout NIL T)
(for ITYPE in ITEM.TYPES as I from 1
do (printout NIL T I " " ITYPE))
(printout NIL T T)
(printout T T)
(for ITYPE in ITEM.TYPES as I from 1
do (printout T ITYPE " ")
(printout NIL T T I " ")
(PRINTDEF (ITEM.TYPE.DESCRIPTION ITYPE)))
(CLOSEF])
(PROMPT.READ
[LAMBDA NIL (* DAHJr " 5-DEC-83 17:20")
(* EVAL.IN.TTY.PROCESS (LIST
(QUOTE PROMPT.READ.1)) T)
(DECLARE (GLOBALVARS PROMPTWINDOW READING.CURSOR))
(SWAP.CURSOR READING.CURSOR (CAR (PROCESS.READ PROMPTWINDOW])
(PROPLIST.PROPERTIES
[LAMBDA (PROPLIST) (* edited: "12-MAR-82 11:21")
(for ELEM on PROPLIST by (CDDR ELEM) collect (CAR ELEM])
(REPORT.ERROR
[LAMBDA (ACTIVITY NATURE VALUE ITEM FORM) (* HaKo "25-Jul-84 17:32")
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Error while " ACTIVITY ":" T " Nature of error: "
NATURE T " Offending value: " VALUE)
(COND
(ITEM (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS " Item: " ITEM)))
(COND
(FORM (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS " Form: " FORM])
(REPORT.LISP.ERROR
[LAMBDA (ACTIVITY ITEM FORM) (* HaKo " 7-Aug-84 10:26")
(DECLARE (GLOBALVARS TRILLIUM.KNOWS.LISP))
(PROG ((ERROR.INFO (ERRORN)))
(REPORT.ERROR ACTIVITY (ERRORSTRING (CAR ERROR.INFO))
(CADR ERROR.INFO)
ITEM FORM)
(if TRILLIUM.KNOWS.LISP
then (BREAK1 NIL T])
(REPORT.TRILLIUM.ERROR
[LAMBDA (NATURE VALUE ITEM ACTIVITY) (* edited: "22-DEC-82 13:07")
(REPORT.ERROR NATURE VALUE ITEM ACTIVITY])
(RESET.ITEM.TYPE.DESCRIPTION
[LAMBDA (DESCRIPTION) (* DAHJr " 3-AUG-83 10:30")
(COMPRESS.PROPLIST DESCRIPTION])
(SCREEN.COORDS
[LAMBDA (POSITION WINDOW) (* DAHJr "22-APR-83 17:42")
(create POSITION
XCOORD ←(IPLUS (fetch (POSITION XCOORD) of POSITION)
(DSPXOFFSET NIL WINDOW))
YCOORD ←(IPLUS (fetch (POSITION YCOORD) of POSITION)
(DSPYOFFSET NIL WINDOW])
(SET.CLIPPING.REGION
[LAMBDA (REGION)
(DECLARE (GLOBALVARS CURRENT.DSP))
(DSPCLIPPINGREGION REGION CURRENT.DSP])
(SET.PLACEMENT
[LAMBDA (ITEM PLACEMENT) (* DAHJr "15-JAN-83 16:45")
(for ENTRY in PLACEMENT do (SET.FIELD ITEM (CAR ENTRY)
(CDR ENTRY])
(SORT.ON.PROPERTY
[LAMBDA (OBJECTS PROP)
(SORT OBJECTS (FUNCTION COMPARE.ON.PROPERTY])
(STRICTLY.ENCLOSESP
[LAMBDA (ENCLOSINGREGION ENCLOSEDREGION) (* DAHJr "16-FEB-83 10:43")
(AND (ENCLOSESP ENCLOSINGREGION ENCLOSEDREGION)
(OR (NEQ (fetch (REGION WIDTH) of ENCLOSINGREGION)
(fetch (REGION WIDTH) of ENCLOSEDREGION))
(NEQ (fetch (REGION HEIGHT) of ENCLOSINGREGION)
(fetch (REGION HEIGHT) of ENCLOSEDREGION])
(SUPERFRAMES*
[LAMBDA (FRAME) (* edited: "19-JAN-83 13:01")
(DECLARE (GLOBALVARS CURRENT.INTERFACE))
(for SUPERFRAME.NAME in (GET.FIELDQ FRAME SUPERFRAMES) join (CONS SUPERFRAME.NAME
(SUPERFRAMES* (FIND.FRAME
CURRENT.INTERFACE
SUPERFRAME.NAME])
(SWAP.CURSOR.AUX
[LAMBDA (OLD.CURSOR NEW.CURSOR) (* DAHJr "10-AUG-83 18:57")
(COND
(OLD.CURSOR (SETCURSOR OLD.CURSOR))
(T (PROG1 (CURSOR)
(SETCURSOR NEW.CURSOR])
(TRILLIUM.CLEAR.ALL.PROMPTING
[LAMBDA NIL (* DAHJr "19-JAN-83 17:32")
(DECLARE (GLOBALVARS PROMPTWINDOW TRILLIUM.CLEARPROMPT TRILLIUM.HAVE.PROMPTED))
(COND
((AND TRILLIUM.CLEARPROMPT TRILLIUM.HAVE.PROMPTED)
(SETQ TRILLIUM.HAVE.PROMPTED)
(CLEARW PROMPTWINDOW])
(TRILLIUM.EVAL
[LAMBDA (FORM ACTIVITY) (* DAHJr " 5-JAN-84 21:08")
(PROG (RESULT)
(RETURN (COND
((NLSETQ (SETQ RESULT (EVAL FORM)))
RESULT)
(T (REPORT.LISP.ERROR (OR ACTIVITY "evaluating a form")
NIL FORM])
(TRILLIUM.GRID.SETUP
[LAMBDA (X0 Y0 DX DY DISPLAY.METHOD) (* HaKo "27-Jul-84 10:10")
(* DAHJr "18-APR-83 17:59")
(DECLARE (GLOBALVARS TRILLIUM.GRID.DX TRILLIUM.GRID.DY TRILLIUM.GRID.HALF.DX
TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.POINTS.FLG TRILLIUM.GRID.X0
TRILLIUM.GRID.Y0))
(SETQ TRILLIUM.GRID.X0 (IREMAINDER X0 DX))
(SETQ TRILLIUM.GRID.Y0 (IREMAINDER Y0 DY))
(SETQ TRILLIUM.GRID.DX DX)
(SETQ TRILLIUM.GRID.HALF.DX (IQUOTIENT DX 2))
(SETQ TRILLIUM.GRID.DY DY)
(SETQ TRILLIUM.GRID.HALF.DY (IQUOTIENT DY 2))
(SETQ TRILLIUM.GRID.POINTS.FLG (SELECTQ DISPLAY.METHOD
(NIL NIL)
(POINTS T)
(LINES NIL)
(HELP "Unknown DISPLAY.METHOD in TRILLIUM.GRID.SETUP: "
DISPLAY.METHOD])
(TRILLIUM.PRINTOUT.STRING
[LAMBDA (STR) (* DAHJr "23-JAN-83 16:24")
(DECLARE (GLOBALVARS PROMPTWINDOW))
(PROG (N FIRST.CHAR CHAR)
(SETQ N (NCHARS STR))
[for I to N
do (SETQ CHAR (NTHCHAR STR I))
(COND
((EQ CHAR (QUOTE % ))
(COND
(FIRST.CHAR (PRIN1 (SUBSTRING STR FIRST.CHAR (SUB1 I))
PROMPTWINDOW)
(SETQ FIRST.CHAR)))
(PRIN1 (QUOTE % )
PROMPTWINDOW))
(T (COND
((NULL FIRST.CHAR)
(SETQ FIRST.CHAR I]
(COND
(FIRST.CHAR (PRIN1 (SUBSTRING STR FIRST.CHAR N)
PROMPTWINDOW])
(TROUBLE.WITH.TRILLIUM
[NLAMBDA PARTICULARS (* HaKo " 7-Aug-84 10:16")
(DECLARE (GLOBALVARS TRILLIUM.KNOWS.LISP))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS)
(for SPEC in PARTICULARS do (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS SAME.LINE
(if (ATOM SPEC)
then (EVALV SPEC)
else SPEC)
1))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS SAME.LINE "in " (STKNTHNAME -1 (QUOTE
TROUBLE.WITH.TRILLIUM))
T)
(if TRILLIUM.KNOWS.LISP
then (HELP PARTICULARS])
(TTYCONFIRM
[LAMBDA (MESSAGE ONLY.IF.BEING.CAREFUL) (* HaKo " 5-AUG-83 12:00")
(DECLARE (GLOBALVARS TRILLIUM.BEING.CAREFUL))
(COND
((AND ONLY.IF.BEING.CAREFUL (NOT TRILLIUM.BEING.CAREFUL))
T)
(T (TERPRI T)
(PROG1 [ASKUSER NIL NIL MESSAGE (QUOTE ((Y "es" RETURN T)
(N "o" RETURN NIL]
(TERPRI T])
(UNMARK.INTERFACE
[LAMBDA (INTERFACE) (* HaKo "16-Aug-84 16:36")
(PROG ((NAME (GET.FIELDQ INTERFACE NAME INTERFACE))
(TYPE (QUOTE DIALOGS)))
(COND
((MARKASCHANGED NAME TYPE)
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Marking interface " NAME " as unchanged")
(UNMARKASCHANGED NAME TYPE])
(UNMARK.ITEM.TYPE
[LAMBDA (ITYPE) (* HaKo "16-Aug-84 16:36")
(PROG ((TYPE (QUOTE ITEMTYPES)))
(COND
((MARKASCHANGEDP ITYPE TYPE)
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Marking item type " ITYPE " as unchanged")
(UNMARKASCHANGED ITYPE TYPE])
(USED.ITEM.TYPES
[LAMBDA (INTERFACE) (* edited: "15-APR-83 17:50")
(PROG (ITYPES ITYPE)
(SETQ ITYPES (CONS))
[for FRAME in (GET.FIELDQ INTERFACE FRAMES INTERFACE)
do (for ITEM in (GET.FIELDQ FRAME ITEMS FRAME)
do (SETQ ITYPE (ITEM.TYPE ITEM))
(COND
((FMEMB ITYPE (CAR ITYPES)))
(T (TCONC ITYPES ITYPE]
(RETURN (SORT (CAR ITYPES])
(VECTOR/FROM.TO
[LAMBDA (FROM.POINT TO.POINT) (* DAHJr "17-JAN-83 11:16")
(create POSITION
XCOORD ←(IDIFFERENCE (fetch (POSITION XCOORD) of TO.POINT)
(fetch (POSITION XCOORD) of FROM.POINT))
YCOORD ←(IDIFFERENCE (fetch (POSITION YCOORD) of TO.POINT)
(fetch (POSITION YCOORD) of FROM.POINT])
(WAITBUG
[LAMBDA NIL (* DAHJr "21-APR-83 18:10")
(DECLARE (GLOBALVARS LASTMOUSEBUTTONS))
(until (MOUSESTATE (NOT UP)) do NIL])
(WAITNOBUG
[LAMBDA NIL (* HaKo " 7-Aug-84 16:41")
(DECLARE (GLOBALVARS EVENT.MODE LASTMOUSEBUTTONS))
(SELECTQ EVENT.MODE
(OFF (until (MOUSESTATE UP) do NIL))
(RECORDING (END.EVENT)
(until (MOUSESTATE UP) do NIL)
(BEGIN.EVENT))
(PLAYBACK (END.EVENT)
(BEGIN.EVENT))
(ERROR "Unknown EVENT.MODE :" EVENT.MODE])
(WAITNOBUG.AUX
[LAMBDA NIL (* DAHJr "12-AUG-83 17:48")
(DECLARE (GLOBALVARS LASTMOUSEBUTTONS))
(until (MOUSESTATE UP) do NIL)
T])
(WALK.FRAME
[LAMBDA (FRAME CONTEXT ACTIONFN ACTIONFNARG) (* HaKo "15-Aug-84 14:03")
(for ITEM in (GET.FIELDQ FRAME ITEMS) bind (RESULT (NEWCONTEXT ←(LIST FRAME CONTEXT)))
when (SETQ RESULT (WALK.OBJECT ITEM (QUOTE (ITEM))
NEWCONTEXT ACTIONFN ACTIONFNARG))
do (RETURN RESULT])
(WALK.INTERFACE
[LAMBDA (INTERFACE CONTEXT ACTIONFN ACTIONFNARG) (* HaKo "17-Aug-84 19:40")
(for FRAME in (GET.FIELDQ INTERFACE FRAMES) bind (RESULT (NEWCONTEXT ←(LIST INTERFACE CONTEXT)))
when (SETQ RESULT (WALK.FRAME FRAME NEWCONTEXT ACTIONFN ACTIONFNARG)) do (RETURN RESULT])
(WALK.ITEM
[LAMBDA (ITEM CONTEXT ACTIONFN ACTIONFNARG) (* HaKo "15-Aug-84 14:57")
(for PARAMETER in (GET.FIELDQ (ITEM.TYPE.DESCRIPTION (ITEM.TYPE ITEM))
PARAMETERS ITEM.TYPE)
bind (PTYPE PNAME PVALUE RESULT (NEWCONTEXT ←(LIST ITEM CONTEXT)))
do (SETQ PNAME (GET.FIELDQ PARAMETER NAME))
(COND
((SETQ PVALUE (LISTGET ITEM PNAME))
(SETQ PTYPE (GET.FIELDQ PARAMETER TYPE))
(COND
((SETQ RESULT (WALK.OBJECT PVALUE PTYPE (CONS PNAME NEWCONTEXT)
ACTIONFN ACTIONFNARG))
(RETURN RESULT])
(WALK.OBJECT
[LAMBDA (OBJECT PTYPE CONTEXT ACTIONFN ACTIONFNARG) (* HaKo "15-Aug-84 13:43")
(OR (APPLY* (OR ACTIONFN (FUNCTION EDIT.FORM))
OBJECT PTYPE CONTEXT ACTIONFN ACTIONFNARG)
(APPLY* (OR (FUNCTION.FOR.PTYPE PTYPE (QUOTE WALK))
(FUNCTION NILL))
OBJECT PTYPE CONTEXT ACTIONFN ACTIONFNARG])
)
(RPAQQ ITEM.OPERATIONS (ANALYZE BOUNDING.BOX CLEAR DISPLAY RELOCATE SENSE SHOW))
(RPAQQ TRILLIUM.CLEARPROMPT NIL)
(RPAQQ ITEM.TYPE.MENU NIL)
(RPAQQ PLACEMENT.PTYPES (POSITION LOCATION POSITION2 LOCATION2 REGION GRIDREGION))
(RPAQQ PRINT.SEPARATOR.STRING "***************")
(RPAQQ THINKING.LEVEL 0)
(READVARS READING.CURSOR)
(({(READBITMAP)(16 16
"GOON"
"L@@C"
"H@@A"
"IOOI"
"IOOI"
"HAHA"
"HAHA"
"HAHA"
"HAHA"
"HAHA"
"HAHA"
"HAHA"
"HAHA"
"H@@A"
"L@@C"
"GOON")} 7 . 8))
(SETTEMPLATE (QUOTE GET.FIELDQ)
(QUOTE (EVAL NIL NIL)))
(SETTEMPLATE (QUOTE SET.FIELDQ)
(QUOTE (EVAL NIL EVAL NIL)))
(SETTEMPLATE (QUOTE THINKING)
(QUOTE (.. EFFECT RETURN)))
(DECLARE: EVAL@COMPILE
(PUTPROPS SWAP.CURSOR MACRO [SWAP.CURSOR.FORMS (CONS (QUOTE RESETFORM)
(CONS (LIST (QUOTE SWAP.CURSOR.AUX)
NIL
(CAR SWAP.CURSOR.FORMS))
(CDR SWAP.CURSOR.FORMS])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TROUBLE.WITH.TRILLIUM)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS TRI-UTIL COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2382 47171 (ACQUIRE.LIST.ITEMS 2392 . 3814) (ADD.FRAME.CLASS 3816 . 4539) (COLLECT.ITEM
4541 . 4856) (COMPARE.ON.PROPERTY 4858 . 5014) (COMPRESS.PROPLIST 5016 . 5536) (CONFIRM 5538 . 5945)
(CONVERT.NONGRIDDED.OFFSETS 5947 . 6596) (COORDS 6598 . 7594) (DEFINING.ITEMS.OF.FRAME 7596 . 7942) (
DEFINING.ITEMS.OF.ITEM 7944 . 8535) (DEFINING.ITEMS.OF.PTYPE 8537 . 9272) (DEFINING.PTYPENAMES.OF.ITEM
9274 . 9971) (DEFINING.PTYPES.OF.FRAME 9973 . 10196) (DEFINING.PTYPES.OF.ITEM 10198 . 10897) (
DEFINING.PTYPES.OF.PTYPE 10899 . 11894) (DRAW.GRID 11896 . 13194) (ENCLOSESP 13196 . 13801) (
EVAL.WITHIN.ITEM 13803 . 14267) (FIND.BITMAP 14269 . 15012) (FIND.COLOR.NUMBER 15014 . 15546) (
FIND.ENCLOSED.ITEMS 15548 . 15864) (FIND.FRAME 15866 . 16384) (FIND.INTERFACE 16386 . 16664) (
FIND.REPRESENTATIVE.GRAY 16666 . 17221) (FLASH.REGION 17223 . 17515) (FLIP.BOX 17517 . 17806) (
FLIP.ITEM 17808 . 18387) (FLIP.REGION.IN.WINDOW 18389 . 18881) (FLIP.SPOT 18883 . 19444) (
FONTS.IN.CORE 19446 . 19887) (FRAME.CLASSES 19889 . 20471) (FRAME.NAME 20473 . 20535) (
FUNCTION.FOR.PTYPE 20537 . 20746) (GET.ITEM.TYPE.MENU 20748 . 21338) (GET.PARAM.DEFAULT 21340 . 21535)
(GET.TRILLIUM.PRINTOUT.WINDOW 21537 . 23197) (GRIDIFY 23199 . 24257) (GRIDNEAR 24259 . 25315) (
INDEFINITE 25317 . 25460) (INTERFACE.WINDOW 25462 . 25937) (INVERT.MENU.ITEM 25939 . 26862) (ITEM.KIND
26864 . 27047) (ITEM.TYPE.CLASSES 27049 . 27576) (ITEM.TYPE.MENU.ITEM 27578 . 27790) (
ITEM.TYPE.PARAMETER 27792 . 28176) (ITEM.TYPE.PARAMETER.NAMES 28178 . 28453) (ITEM.TYPE.PARAMETER.TYPE
28455 . 28644) (ITEM.TYPES.OF.FRAME 28646 . 28940) (ITEM.TYPES.OF.INTERFACE 28942 . 29249) (ITEMP
29251 . 29458) (LOWERLEFTW 29460 . 29671) (MOUSEBUTTONS 29673 . 29874) (NEW.ITEM 29876 . 30324) (OBS
30326 . 30776) (OFFSPRING 30778 . 30952) (OFFSPRING.1 30954 . 31759) (OFFSPRING.N 31761 . 31877) (
OFFSPRING.OF.DESCRIPTION 31879 . 32235) (ON.GRID 32237 . 32657) (PRINT.IN.REGION 32659 . 33797) (
PRINT.ITEM 33799 . 35201) (PRINT.ITEM.TYPES 35203 . 35764) (PRINTOUT.ITEM.TYPES 35766 . 36562) (
PROMPT.READ 36564 . 36935) (PROPLIST.PROPERTIES 36937 . 37133) (REPORT.ERROR 37135 . 37553) (
REPORT.LISP.ERROR 37555 . 37927) (REPORT.TRILLIUM.ERROR 37929 . 38101) (RESET.ITEM.TYPE.DESCRIPTION
38103 . 38269) (SCREEN.COORDS 38271 . 38601) (SET.CLIPPING.REGION 38603 . 38733) (SET.PLACEMENT 38735
. 38937) (SORT.ON.PROPERTY 38939 . 39035) (STRICTLY.ENCLOSESP 39037 . 39441) (SUPERFRAMES* 39443 .
39826) (SWAP.CURSOR.AUX 39828 . 40044) (TRILLIUM.CLEAR.ALL.PROMPTING 40046 . 40382) (TRILLIUM.EVAL
40384 . 40680) (TRILLIUM.GRID.SETUP 40682 . 41535) (TRILLIUM.PRINTOUT.STRING 41537 . 42195) (
TROUBLE.WITH.TRILLIUM 42197 . 42802) (TTYCONFIRM 42804 . 43164) (UNMARK.INTERFACE 43166 . 43534) (
UNMARK.ITEM.TYPE 43536 . 43861) (USED.ITEM.TYPES 43863 . 44324) (VECTOR/FROM.TO 44326 . 44715) (
WAITBUG 44717 . 44920) (WAITNOBUG 44922 . 45352) (WAITNOBUG.AUX 45354 . 45564) (WALK.FRAME 45566 .
45917) (WALK.INTERFACE 45919 . 46252) (WALK.ITEM 46254 . 46837) (WALK.OBJECT 46839 . 47169)))))
STOP