(FILECREATED "23-DEC-82 15:33:38" {DSK}GEV.LSP;70 52547
changes to: (VARS GEVCOMS GEVTYPENAMES)
previous date: "23-DEC-82 11:46:40" {DSK}GEV.LSP;67)
(PRETTYCOMPRINT GEVCOMS)
(RPAQQ GEVCOMS [(GLISPGLOBALS GEVACTIVEFLG GEVCHARWIDTH GEVEDITCHAIN GEVEDITFLG GEVMENUWINDOW
GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY)
(GLISPOBJECTS AREA EDITCHAIN EDITFRAME GSEITEM MOUSESTATE DOLPHINREGION MENU VECTOR WINDOW)
(FNS AREA-CONTAINS GEV GEVA GEVBUTTONEVENTFN GEVCOMMANDFN GEVCOMMANDPROP GEVCOMMANDPROPNAMES
GEVCOMPPROP GEVDATANAMES GEVDATANAMESB GEVDISPLAYNEWPROP GEVDOPROP GEVEDIT GEVEXPROP
GEVFILLWINDOW GEVFILTER GEVFINDITEMPOS GEVFINDLISTPOS GEVFINDPOS GEVGETNAMES GEVGETPROP
GEVGLISPP GEVHORIZLINE GEVINIT GEVINITEDITWINDOW GEVINVERTENTRY GEVLENGTHBOUND
GEVMAKENEWFN GEVMATCH GEVMATCHA GEVMATCHATOM GEVMATCHALIST GEVMATCHB GEVMATCHLISTOF
GEVMATCHOBJECT GEVMATCHPROPLIST GEVMATCHRECORD GEVMOUSELOOP GEVMOVEWINDOWFN GEVPOP
GEVPOSTEST GEVPPS GEVPROGRAM GEVPROPMENU GEVPROPNAMES GEVPROPTYPE GEVPROPTYPE! GEVPUSH
GEVPUSHLISTOF GEVQUIT GEVREDOPROPS GEVREFILLWINDOW GEVSHORTATOMVAL GEVSHORTCONSVAL
GEVSHORTLISTVAL GEVSHORTSTRINGVAL GEVSHORTVALUE GEVXTRTYPE PICTURE-GEVDISPLAY
VECTOR-SHORTVALUE)
(VARS GEVTYPENAMES)
(GLOBALVARS GEVACTIVEFLG GEVCHARWIDTH GEVEDITCHAIN GEVEDITFLG GEVMENUWINDOW
GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY)
(SPECVARS GLNATOM RESULT Y)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML GEV)
(LAMA])
[GLISPGLOBALS
(GEVACTIVEFLG BOOLEAN )
(GEVCHARWIDTH INTEGER )
(GEVEDITCHAIN EDITCHAIN )
(GEVEDITFLG BOOLEAN )
(GEVMENUWINDOW WINDOW )
(GEVMENUWINDOWHEIGHT INTEGER )
(GEVMOUSEAREA MOUSESTATE )
(GEVSHORTCHARS INTEGER )
(GEVWINDOW WINDOW )
(GEVWINDOWY INTEGER )
]
[GLISPOBJECTS
(AREA
(LIST (START VECTOR)
(SIZE VECTOR))
PROP ((LEFT (START:X))
(BOTTOM (START:Y))
(RIGHT (LEFT+WIDTH))
(TOP (BOTTOM+HEIGHT))
(WIDTH (SIZE:X))
(HEIGHT (SIZE:Y))
(CENTER (START+SIZE/2))
(AREA (WIDTH*HEIGHT)))
ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO))
(ZERO (self IS EMPTY)))
MSG ((CONTAINS? REGION-CONTAINS OPEN T)) )
(EDITCHAIN
(LISTOF EDITFRAME)
PROP [(TOPFRAME ((CAR self)))
(TOPITEM ((CAR TOPFRAME:PREVS] )
(EDITFRAME
(LIST (PREVS (LISTOF GSEITEM))
(SUBITEMS (LISTOF GSEITEM))
(PROPS (LISTOF GSEITEM))) )
(GSEITEM
(LIST (NAME ATOM)
(VALUE ANYTHING)
(TYPE ANYTHING)
(SHORTVALUE ATOM)
(NODETYPE ATOM)
(SUBVALUES (LISTOF GSEITEM))
(NAMEPOS VECTOR)
(VALUEPOS VECTOR))
PROP [(NAMEAREA ((VIRTUAL REGION WITH START = NAMEPOS , WIDTH = 8* (NCHARS NAME)
, HEIGHT = 12))
VTYPE GLVTYPE4)
(VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS , WIDTH = 8* (NCHARS NAME)
, HEIGHT = 12] )
(MOUSESTATE
(LIST (AREA AREA)
(ITEM GSEITEM)
(FLAG BOOLEAN)
(GROUP INTEGER)) )
(DOLPHINREGION
(RECORD REGION (LEFT INTEGER)
(BOTTOM INTEGER)
(WIDTH INTEGER)
(HEIGHT INTEGER)) )
(MENU
(RECORD MENU (ITEMS (LISTOF ATOM)))
MSG ((SELECT MENU RESULT ATOM)) )
(VECTOR
(LIST (X INTEGER)
(Y INTEGER))
PROP [(MAGNITUDE ((SQRT X↑2 + Y↑2)))
(ANGLE ((ARCTAN2 Y X T))
RESULT RADIANS)
(UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE , Y = Y/MAGNITUDE]
ADJ ((ZERO (X IS ZERO AND Y IS ZERO))
(NORMALIZED (MAGNITUDE = 1.0)))
MSG [(PRIN1 ((PRIN1 "(")
(PRIN1 X)
(PRIN1 ",")
(PRIN1 Y)
(PRIN1 ")")))
(PRINT ((← self PRIN1)
(TERPRI] )
(WINDOW
ANYTHING
PROP ((REGION ((DSPCLIPPINGREGION NIL self))
RESULT DOLPHINREGION)
(XPOSITION ((DSPXPOSITION NIL self))
RESULT INTEGER)
(YPOSITION ((DSPYPOSITION NIL self))
RESULT INTEGER)
(HEIGHT (REGION:HEIGHT))
(WIDTH (REGION:WIDTH))
(LEFT ((DSPXOFFSET NIL self))
RESULT INTEGER)
(BOTTOM ((DSPYOFFSET NIL self))
RESULT INTEGER))
MSG ((CLEAR CLEARW)
(OPEN OPENW)
(CLOSE CLOSEW)) )
]
(DEFINEQ
(AREA-CONTAINS
(GLAMBDA (AREA P) (* edited: "26-OCT-82 11:45")
(* Test whether an area contains a point P.)
(P:X>=AREA:LEFT AND P:X<=AREA:RIGHT AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP)))
(GEV
[NLAMBDA (VAR STR) (* edited: "12-OCT-82 14:19")
(* GLISP Edit Value function.
Edit VAL according to structure description STR.)
(PROG (VAL)
(SETQ VAL (EVAL VAR))
(SETQ STR (EVAL STR))
(GEVA VAR VAL STR])
(GEVA
(GLAMBDA (VAR VAL STR) (* edited: "22-DEC-82 14:16")
(* GLISP Edit Value function.
Edit VAL according to structure description STR.)
(PROG (GLNATOM TMP HEADER)
(OR (AND (BOUNDP (QUOTE GEVWINDOW))
GEVWINDOW)
(GEVINITEDITWINDOW))
(OPENW GEVMENUWINDOW)
(GEVACTIVEFLG←T)
(GEVEDITFLG←NIL)
(GLNATOM←0)
(GEVSHORTCHARS←27)
(GEVCHARWIDTH←7)
(IF VAR IS A LIST AND (CAR VAR)='QUOTE
THEN VAR←(CONCAT "'" (CADR VAR)))
(IF ~STR
THEN (IF VAL IS ATOMIC AND (GETPROP VAL (QUOTE GLSTRUCTURE))
THEN STR←'GLTYPE
ELSEIF (GEVGLISPP)
THEN STR←(GLCLASS VAL)))
(HEADER←(A GSEITEM WITH NAME = VAR , VALUE = VAL , TYPE = STR))
(GEVEDITCHAIN←(LIST (LIST (LIST HEADER)
NIL NIL)))
(GEVREFILLWINDOW)
(GEVMOUSELOOP))))
(GEVBUTTONEVENTFN
[GLAMBDA NIL (* edited: "11-NOV-82 16:53")
(* Respond to a button event within the editing window.)
(PROG (POS SELECTION TMP TOP N)
(GETMOUSESTATE) (* Test the state of the left mouse button.)
(IF (ZEROP (LOGAND LASTMOUSEBUTTONS 4))
THEN (* Button is now up.)
(IF GEVMOUSEAREA
THEN (SELECTION←GEVMOUSEAREA)
(GEVMOUSEAREA←NIL)
(GEVINVERTENTRY SELECTION:AREA GEVWINDOW)
(* Execute action.)
(IF SELECTION:FLAG
THEN (IF SELECTION:GROUP=1
THEN (TMP←GEVEDITCHAIN:TOPFRAME:PREVS)
(N←0)
(WHILE TMP AND (TOP-←TMP)
<>SELECTION:ITEM
DO N←+1)
(GEVPOP NIL N)
ELSE (GEVPUSH SELECTION:ITEM))
ELSE (PRIN1 SELECTION:ITEM:NAME)
(PRIN1 " is ")
(PRINTDEF SELECTION:ITEM:TYPE (POSITION T))
(TERPRI))
(RETURN)
ELSE (* Button is now down.)
(POS ←(A VECTOR WITH X =(LASTMOUSEX GEVWINDOW)
Y =(LASTMOUSEY GEVWINDOW)))
(IF GEVMOUSEAREA
THEN (IF (← GEVMOUSEAREA:AREA CONTAINS? POS)
THEN (RETURN)
ELSE (* Mouse has moved out of area with button down.)
(SELECTION←GEVMOUSEAREA)
(GEVMOUSEAREA←NIL)
(GEVINVERTENTRY SELECTION:AREA GEVWINDOW)))
(* Try to find an item at current mouse position.)
(IF GEVMOUSEAREA ←(GEVFINDPOS POS GEVEDITCHAIN:TOPFRAME)
THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW])
(GEVCOMMANDFN
[GLAMBDA (COMMANDWORD:ATOM) (* edited: "11-NOV-82 16:20")
(PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM)
(CASE COMMANDWORD OF (EDIT (GEVEDIT))
(QUIT (IF GEVMOUSEAREA
THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW)
(GEVMOUSEAREA←NIL)
ELSE (GEVQUIT)))
(POP (GEVPOP T 1))
(PROGRAM (GEVPROGRAM))
((PROP ADJ ISA MSG)
(TOPITEM←GEVEDITCHAIN:TOPITEM)
(GEVCOMMANDPROP TOPITEM COMMANDWORD NIL))
ELSE
(ERROR])
(GEVCOMMANDPROP
[GLAMBDA (ITEM:GSEITEM COMMANDWORD:ATOM PROPNAME:ATOM) (* edited: "22-DEC-82 11:30")
(PROG (VAL PROPNAMES FLG)
(IF PROPNAME
THEN FLG←T)
(IF ITEM:TYPE IS ATOMIC
THEN (PROPNAMES←(GEVCOMMANDPROPNAMES ITEM:TYPE COMMANDWORD GEVEDITCHAIN:TOPFRAME)
))
(IF ITEM:TYPE IS ATOMIC OR COMMANDWORD='PROP
THEN (IF COMMANDWORD='PROP
THEN (IF (CDR PROPNAMES)
THEN PROPNAMES+←'All)
PROPNAMES+←'self)
(IF ~PROPNAMES (RETURN))
[IF ~PROPNAME (PROPNAME ←(MENU (create MENU
ITEMS ← PROPNAMES]
(IF ~PROPNAME (RETURN)
ELSEIF PROPNAME='self
THEN (PRIN1 PROPNAME)
(PRIN1 " = ")
(PRINT ITEM:VALUE)
ELSEIF COMMANDWORD='PROP AND PROPNAME='All
THEN (FOR X IN (OR (CDDR PROPNAMES)
(CDR PROPNAMES))
DO (GEVDOPROP ITEM X COMMANDWORD FLG))
ELSE (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG))
(IF COMMANDWORD='MSG
THEN (GEVREFILLWINDOW)
(GEVEDITFLG←T])
(GEVCOMMANDPROPNAMES
(GLAMBDA (OBJ:GLTYPE PROPTYPE:ATOM TOPFRAME:EDITFRAME) (* edited: "22-DEC-82 11:09")
(* Get all property names of properties of type PROPTYPE for OBJ. Properties are filtered to remove system
properties and those which are already displayed.)
(PROG (RESULT TYPE)
(RESULT ←(FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS)
(ADJ OBJ:ADJS)
(ISA OBJ:ISAS)
(MSG OBJ:MSGS))
WHEN ~(PROPTYPE~='MSG AND (THE PROP OF TOPFRAME WITH NAME =(CAR P)))
AND ~[PROPTYPE='PROP AND (MEMB (CAR P)
(QUOTE (SHORTVALUE DISPLAYPROPS]
AND ~(PROPTYPE='MSG AND (CADR P) IS ATOMIC
AND (~(GETD (CADR P))
OR [LENGTH (CADR (GETD (CADR P]
>1))
COLLECT P:NAME))
[FOR S IN OBJ:SUPERS DO (RESULT ←(NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE
TOPFRAME]
(RETURN RESULT))))
(GEVCOMPPROP
[GLAMBDA (STR:GLTYPE PROPNAME,PROPTYPE:ATOM) (* edited: "22-DEC-82 11:17")
(* Compile a property whose name is PROPNAME and whose
property type (ADJ, ISA, PROP, MSG) is PROPTYPE for the
object type STR.)
(PROG (PROPENT)
(IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG)))
(RETURN (QUOTE GEVERROR))) (* If the property is implemented by a named function,
return the function name.)
(IF (PROPENT←(GEVGETPROP STR PROPNAME PROPTYPE)) AND (CADR PROPENT) IS ATOMIC
THEN (RETURN (CADR PROPENT))) (* Compile code for this property and save it.
First be sure the GLISP compiler is loaded.)
(RETURN (COND
((GEVGLISPP)
(GLCOMPPROP STR PROPNAME PROPTYPE)
OR
(QUOTE GEVERROR))
(T (ERROR
"GLISP compiler must be loaded for PROPs which
are not specified with function name equivalents."
(LIST STR PROPTYPE PROPNAME])
(GEVDATANAMES
[GLAMBDA (OBJ:GLTYPE FILTER:ATOM) (* edited: " 4-NOV-82 16:08")
(* Get a flattened list of names and types from a given
structure description.)
(PROG (RESULT)
(GEVDATANAMESB OBJ:STRDES FILTER)
(RETURN (DREVERSE RESULT])
(GEVDATANAMESB
[GLAMBDA (STR:ANYTHING FILTER:ATOM) (* edited: " 4-NOV-82 16:07")
(* Get a flattened list of names and types from a given
structure description.)
(GLOBAL RESULT)
(PROG (TMP)
(IF STR IS ATOMIC
THEN (RETURN)
ELSE (CASE (CAR STR)
OF
(CONS (GEVDATANAMESB (CADR STR)
FILTER)
(GEVDATANAMESB (CADDR STR)
FILTER))
((ALIST PROPLIST LIST)
(FOR X IN (CDR STR) DO (GEVDATANAMESB X FILTER)))
(RECORD (FOR X IN (CDDR STR) DO (GEVDATANAMESB X FILTER)))
(ATOM (GEVDATANAMESB (CADR STR)
FILTER)
(GEVDATANAMESB (CADDR STR)
FILTER))
(BINDING (GEVDATANAMESB (CADR STR)
FILTER))
(LISTOF (RETURN))
ELSE
[IF (GEVFILTER (CADR STR)
FILTER)
THEN (RESULT +←(LIST (CAR STR)
(CADR STR]
((GEVDATANAMESB (CADR STR)
FILTER])
(GEVDISPLAYNEWPROP
(GLAMBDA NIL (* edited: "14-OCT-82 15:35")
(* Display a newly added property in the window.)
(PROG (Y NEWONE:GSEITEM)
(Y←GEVWINDOWY)
(NEWONE←(CAR (LAST GEVEDITCHAIN:TOPFRAME:PROPS)))
(GEVPPS NEWONE 1 GEVWINDOW Y)
(GEVWINDOWY←Y))))
(GEVDOPROP
[GLAMBDA (ITEM:GSEITEM PROPNAME,COMMANDWORD:ATOM FLG:BOOLEAN)
(* edited: "16-OCT-82 16:09")
(* Add the property PROPNAME of type COMMANDWORD to the
display for ITEM.)
(PROG (VAL)
(VAL←(GEVEXPROP ITEM:VALUE ITEM:TYPE PROPNAME COMMANDWORD NIL))
(GEVEDITCHAIN:TOPFRAME:PROPS←+(A GSEITEM WITH NAME = PROPNAME , TYPE =(GEVPROPTYPE
ITEM:TYPE PROPNAME COMMANDWORD)
, VALUE = VAL , NODETYPE = COMMANDWORD))
(IF ~FLG
THEN (GEVDISPLAYNEWPROP])
(GEVEDIT
(GLAMBDA NIL (* edited: "12-OCT-82 16:34")
(* Edit the currently displayed item.)
(PROG (CHANGEDFLG GEVTOPITEM)
(GEVTOPITEM←GEVEDITCHAIN:TOPITEM)
(IF GEVTOPITEM:TYPE IS ATOMIC AND (GEVEXPROP GEVTOPITEM:VALUE GEVTOPITEM:TYPE
(QUOTE EDIT)
(QUOTE MSG)
NIL)
~='GEVERROR
THEN CHANGEDFLG←T
ELSEIF GEVTOPITEM:VALUE IS A LIST
THEN (EDITV GEVTOPITEM:VALUE)
(CHANGEDFLG←T)
ELSE (RETURN))
(IF CHANGEDFLG
THEN (GEVREFILLWINDOW))
(GEVEDITFLG←CHANGEDFLG))))
(GEVEXPROP
[GLAMBDA (OBJ STR PROPNAME,PROPTYPE:ATOM ARGS) (* edited: " 4-NOV-82 15:10")
(* Execute a property whose name is PROPNAME and whose property type (ADJ, ISA, PROP, MSG) is PROPTYPE on the
object OBJ whose type is STR.)
(PROG (FN)
(IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG))) OR (ARGS AND PROPTYPE~='MSG)
(RETURN (QUOTE GEVERROR)))
(IF (FN←(GEVCOMPPROP STR PROPNAME PROPTYPE))='GEVERROR
THEN (RETURN FN)
ELSE (RETURN (APPLY FN (CONS OBJ ARGS])
(GEVFILLWINDOW
(GLAMBDA NIL (* edited: "14-OCT-82 15:23")
(* Fill the GEV editor window with the item which is at
the top of GEVEDITCHAIN.)
(PROG (Y TOP)
(← GEVWINDOW CLEAR) (* Compute an initial Y value for printing titles in the
window.)
(Y←GEVWINDOW:HEIGHT
- 20) (* Print the titles from the edit chain first.)
(TOP←GEVEDITCHAIN:TOPFRAME)
(FOR X IN (REVERSE TOP:PREVS) DO (GEVPPS X 1 GEVWINDOW Y))
(GEVHORIZLINE GEVWINDOW)
(FOR X IN TOP:SUBITEMS DO (GEVPPS X 1 GEVWINDOW Y))
(GEVHORIZLINE GEVWINDOW)
(FOR X IN TOP:PROPS DO (GEVPPS X 1 GEVWINDOW Y))
(GEVWINDOWY←Y))))
(GEVFILTER
(GLAMBDA (TYPE FILTER) (* edited: " 5-NOV-82 10:49")
(* Filter types according to a specified FILTER.)
(TYPE←(GEVXTRTYPE TYPE))
(CASE FILTER OF (NUMBER ~(MEMB TYPE (QUOTE (ATOM STRING BOOLEAN ANYTHING)))
AND ~(AND (LISTP TYPE) AND (CAR TYPE)='LISTOF))
(LIST (LISTP TYPE) AND (CAR TYPE)='LISTOF)
ELSE T)))
(GEVFINDITEMPOS
[GLAMBDA (POS:VECTOR ITEM:GSEITEM N:INTEGER) (* edited: "14-OCT-82 11:32")
(RESULT MOUSESTATE)
(* Test whether ITEM contains the mouse position POS. The result is NIL if not found, else a list of the sub-item
and a flag which is NIL if the NAME part is identified, T if the VALUE part is identified.)
(OR (GEVPOSTEST POS ITEM:NAMEPOS ITEM:NAME ITEM NIL N)
(GEVPOSTEST POS ITEM:VALUEPOS ITEM:SHORTVALUE ITEM T N)
((ITEM:NODETYPE='STRUCTURE OR ITEM:NODETYPE='SUBTREE OR ITEM:NODETYPE='LISTOF)
AND (GEVFINDLISTPOS POS ITEM:SUBVALUES N])
(GEVFINDLISTPOS
(GLAMBDA (POS:VECTOR ITEMS:(LISTOF GSEITEM)
N) (* edited: "13-OCT-82 12:03")
(RESULT MOUSESTATE) (* Find some ITEM corresponding to the mouse position
POS.)
(IF ITEMS
THEN (GEVFINDITEMPOS POS (CAR ITEMS)
N)
OR (GEVFINDLISTPOS POS (CDR ITEMS)
N))))
(GEVFINDPOS
(GLAMBDA (POS:VECTOR FRAME:EDITFRAME) (* edited: "13-OCT-82 12:06")
(RESULT MOUSESTATE)
(* Find the sub-item of FRAME corresponding to the mouse position POS. The result is NIL if not found, else a list
of the sub-item and a flag which is NIL if the NAME part is identified, T if the VALUE part is identified.)
(PROG (TMP N ITEMS:(LISTOF GSEITEM))
(N←0)
(WHILE FRAME AND ~TMP DO (N←+1)
ITEMS-←FRAME
(TMP←(GEVFINDLISTPOS POS ITEMS N)))
(RETURN TMP))))
(GEVGETNAMES
[GLAMBDA (OBJ:GLTYPE FILTER:ATOM) (* edited: "22-DEC-82 14:53")
(* Get all names of properties and stored data from a
GLISP object type.)
(PROG (DATANAMES PROPNAMES)
(SETQ DATANAMES (GEVDATANAMES OBJ FILTER))
(SETQ PROPNAMES (GEVPROPNAMES OBJ (QUOTE PROP)
FILTER))
(RETURN (NCONC DATANAMES PROPNAMES])
(GEVGETPROP
[GLAMBDA (STR PROPNAME,PROPTYPE:ATOM) (* edited: "14-OCT-82 12:50")
(* Retrieve a GLISP property whose name is PROPNAME and whose property type (ADJ, ISA, PROP, MSG) is PROPTYPE for
the object type STR.)
(PROG (PL SUBPL PROPENT)
(IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG)))
(ERROR))
(RETURN (AND (PL←(GETPROP STR (QUOTE GLSTRUCTURE)))
(SUBPL←(LISTGET (CDR PL)
PROPTYPE))
(PROPENT←(ASSOC PROPNAME SUBPL])
(GEVGLISPP
[LAMBDA NIL (* edited: "11-NOV-82 15:53")
(BOUNDP (QUOTE GLBASICTYPES])
(GEVHORIZLINE
(GLAMBDA (W:WINDOW) (* edited: "14-OCT-82 09:42")
(GLOBAL Y:INTEGER) (* Draw a horizontal line across window W at Y and
decrease Y.)
(DRAWLINE 1 Y+4 W:WIDTH Y+4 1 (QUOTE PAINT)
WINDOW)
(Y←-12)))
(GEVINIT
[LAMBDA NIL (* edited: "15-OCT-82 17:16")
(SETQ GLNATOM 0)
(SETQ GEVWINDOW NIL])
(GEVINITEDITWINDOW
[LAMBDA NIL (* edited: " 6-OCT-82 16:29")
(* Initialize an edit window for the GLISP structure
editor.)
(PROG (GEVMENU (LEFT 600)
(BOTTOM 200)
(WIDTH 300)
(HEIGHT 400))
(SETQ GEVWINDOW
(CREATEW (create REGION
LEFT ← LEFT
BOTTOM ← BOTTOM
WIDTH ← WIDTH
HEIGHT ← HEIGHT)
"GEV Structure Editor Window"))
(SETQ GEVMOUSEAREA NIL)
(WINDOWPROP GEVWINDOW (QUOTE BUTTONEVENTFN)
(QUOTE GEVBUTTONEVENTFN))
(WINDOWPROP GEVWINDOW (QUOTE MOVEFN)
(QUOTE GEVMOVEWINDOWFN))
(SETQ GEVMENUWINDOWHEIGHT 40)
(SETQ GEVMENUWINDOW (CREATEW (create REGION
LEFT ← LEFT
BOTTOM ←(IDIFFERENCE BOTTOM GEVMENUWINDOWHEIGHT)
WIDTH ← WIDTH
HEIGHT ← GEVMENUWINDOWHEIGHT)
NIL 0))
(SETQ GEVMENU (create MENU
ITEMS ←(QUOTE (QUIT POP EDIT PROGRAM PROP ADJ ISA MSG))
CENTERFLG ← T
MENUROWS ← 2
MENUFONT ←(FONTCREATE (QUOTE HELVETICA)
10
(QUOTE BOLD))
ITEMHEIGHT ← 15
ITEMWIDTH ←(IDIFFERENCE (IQUOTIENT WIDTH 4)
2)
WHENSELECTEDFN ←(QUOTE GEVCOMMANDFN)))
(ADDMENU GEVMENU GEVMENUWINDOW)
(RETURN GEVWINDOW])
(GEVINVERTENTRY
(GLAMBDA (AREA:AREA WINDOW) (* edited: " 5-OCT-82 14:43")
(* Invert the area of WINDOW which is covered by the
specified AREA.)
(BITBLT WINDOW AREA:LEFT AREA:BOTTOM WINDOW AREA:LEFT AREA:BOTTOM AREA:WIDTH AREA:HEIGHT
(QUOTE INVERT)
(QUOTE REPLACE)
NIL NIL)))
(GEVLENGTHBOUND
[LAMBDA (VAL NCHARS) (* edited: "12-OCT-82 12:12")
(* Bound the length of VAL to NCHARS.)
(COND
((IGREATERP (NCHARS VAL)
NCHARS)
(CONCAT (SUBSTRING VAL 1 (SUB1 NCHARS))
"-"))
(T VAL])
(GEVMAKENEWFN
[GLAMBDA
[OPERATION,INPUTTYPE:ATOM SET:(LIST (NAME ATOM)
(TYPE GLTYPE))
PATH:(LISTOF (LIST (NAME ATOM)
(TYPE GLTYPE]
(* edited: " 6-NOV-82 14:23")
(* Make a function to perform OPERATION on set SETNAME
from INPUTTYPE following PATH to get to the data.)
(PROG (LASTPATH)
(SETQ LASTPATH (CAR (LAST PATH)))
(RETURN
(LIST [LIST (QUOTE GLAMBDA)
(LIST (MKATOM (CONCAT (QUOTE GEVNEWFNTOP)
":" INPUTTYPE)))
(LIST (QUOTE PROG)
(CONS (QUOTE GEVNEWFNVALUE)
(CASE OPERATION OF (COLLECT (QUOTE (GEVNEWFNRESULT)))
((MAXIMUM MINIMUM)
(QUOTE (GEVNEWFNTESTVAL GEVNEWFNINSTANCE)))
[TOTAL (QUOTE ((GEVNEWFNSUM 0]
[AVERAGE (QUOTE ((GEVNEWFNSUM 0.0)
(GEVNEWFNCOUNT 0]
ELSE
(ERROR)))
[NCONC [LIST (QUOTE FOR)
(QUOTE GEVNEWFNLOOPVAR)
(QUOTE IN)
(MKATOM (CONCAT (QUOTE GEVNEWFNTOP)
":" SET:NAME))
(QUOTE DO)
(LIST (QUOTE GEVNEWFNVALUE)
(QUOTE ←)
(DREVERSE (CONS (QUOTE GEVNEWFNLOOPVAR)
(MAPCONC PATH
(FUNCTION (LAMBDA (X)
(LIST (QUOTE OF)
(CAR X)
(QUOTE THE]
(COPY (CASE OPERATION OF [COLLECT (QUOTE ((GEVNEWFNRESULT +←
GEVNEWFNVALUE]
[MAXIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE
OR GEVNEWFNVALUE >
GEVNEWFNTESTVAL
THEN (GEVNEWFNTESTVAL ←
GEVNEWFNVALUE)
(GEVNEWFNINSTANCE ←
GEVNEWFNLOOPVAR]
[MINIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE
OR GEVNEWFNVALUE
< GEVNEWFNTESTVAL
THEN (GEVNEWFNTESTVAL ←
GEVNEWFNVALUE)
(GEVNEWFNINSTANCE ←
GEVNEWFNLOOPVAR]
[AVERAGE (QUOTE ((GEVNEWFNSUM ←+
GEVNEWFNVALUE)
(GEVNEWFNCOUNT ←+
1]
(TOTAL (QUOTE ((GEVNEWFNSUM ←+
GEVNEWFNVALUE]
(LIST (QUOTE RETURN)
(CASE OPERATION OF (COLLECT (QUOTE (DREVERSE GEVNEWFNRESULT)))
((MAXIMUM MINIMUM)
(QUOTE (LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE)))
[AVERAGE (QUOTE (QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT]
(TOTAL (QUOTE GEVNEWFNSUM]
(CASE OPERATION OF (COLLECT (LIST (QUOTE LISTOF)
(CADR LASTPATH)))
[(MAXIMUM MINIMUM)
(LIST (QUOTE LIST)
(COPY LASTPATH)
(LIST (QUOTE WINNER)
(CADR SET:TYPE]
(AVERAGE (QUOTE REAL))
(TOTAL (CADR LASTPATH])
(GEVMATCH
[GLAMBDA (STR VAL FLG) (* edited: " 8-OCT-82 10:43")
(RESULT (LISTOF GSEITEM)) (* Match a structure description, STR, and a value VAL
which matches that description, to form a structure
editor tree structure.)
(PROG (RESULT)
(GEVMATCHB STR VAL NIL FLG)
(RETURN (DREVERSE RESULT])
(GEVMATCHA
[GLAMBDA (STR VAL FLG) (* edited: " 8-OCT-82 10:01")
(* Make a single item which matches structure STR and
value VAL.)
(PROG (RES)
(RES←(GEVMATCH STR VAL FLG))
(IF ~(CDR RES)
THEN (RETURN (CAR RES))
ELSE (RETURN (A GSEITEM WITH VALUE = VAL , TYPE = STR , SUBVALUES = RES , NODETYPE
=(QUOTE SUBTREE])
(GEVMATCHATOM
[GLAMBDA (STR VAL NAME) (* edited: " 7-OCT-82 16:38")
(* Match an ATOM structure to a given value.)
(PROG (L STRB TMP)
(IF VAL IS NOT ATOMIC OR VAL IS NULL
THEN (RETURN))
(STRB←(CADR STR))
(IF (CAR STRB)
~='PROPLIST
THEN (RETURN))
(L←(CDR STRB))
(FOR X IN L DO (IF TMP←(GETPROP VAL (CAR X))
THEN (GEVMATCHB X TMP NIL NIL])
(GEVMATCHALIST
[GLAMBDA (STR VAL NAME) (* edited: " 7-OCT-82 16:57")
(* Match an ALIST structure to a given value.)
(PROG (L TMP)
(L←(CDR STR))
(FOR X IN L DO (IF TMP←(ASSOC (CAR X)
VAL)
THEN (GEVMATCHB X (CDR TMP)
NIL NIL])
(GEVMATCHB
[GLAMBDA (STR:(LISTOF ANYTHING)
VAL NAME:ATOM FLG:BOOLEAN) (* edited: "22-DEC-82 15:26")
(* Match a structure description, STR, and a value VAL which matches that description, to form a structure editor
tree structure. If FLG is set, the match will descend inside an atomic type name. Results are added to the free
variable RESULT.)
(GLOBAL RESULT)
(PROG (X Y STRB XSTR TOP TMP)
(XSTR←(GEVXTRTYPE STR))
(IF STR IS ATOMIC
THEN (IF FLG AND [STRB ←(CAR (GETPROP STR (QUOTE GLSTRUCTURE]
THEN (RESULT +←(A GSEITEM WITH NAME = NAME , VALUE = VAL , SUBVALUES =(
GEVMATCH STRB VAL NIL)
, TYPE = STR , NODETYPE =(QUOTE STRUCTURE)))
ELSE (RESULT +←(A GSEITEM WITH NAME = NAME , VALUE = VAL , TYPE = STR)))
(RETURN)
ELSE (CASE (CAR STR)
OF
(CONS (GEVMATCHB (CADR STR)
(CAR VAL)
NIL NIL)
(GEVMATCHB (CADDR STR)
(CDR VAL)
NIL NIL))
[LIST (FOR X IN (CDR STR) DO (IF VAL (GEVMATCHB X (CAR VAL)
NIL NIL)
(VAL←(CDR VAL]
(ATOM (GEVMATCHATOM STR VAL NAME))
(ALIST (GEVMATCHALIST STR VAL NAME))
(PROPLIST (GEVMATCHPROPLIST STR VAL NAME))
(LISTOF (GEVMATCHLISTOF STR VAL NAME))
(RECORD (GEVMATCHRECORD STR VAL NAME))
((OBJECT ATOMOBJECT LISTOBJECT)
(GEVMATCHOBJECT STR VAL NAME))
ELSE
(IF NAME
THEN (TMP ←(GEVMATCH STR VAL NIL))
(TOP←(CAR TMP))
[RESULT +←(IF ~(CDR TMP) AND ~TOP:NAME
THEN (TOP:NAME←NAME)
TOP
ELSE (A GSEITEM WITH NAME = NAME , VALUE = VAL ,
SUBVALUES = TMP , TYPE = XSTR , NODETYPE =(
QUOTE SUBTREE]
ELSEIF (STRB ←(GEVXTRTYPE (CADR STR))) IS ATOMIC
THEN (GEVMATCHB STRB VAL (CAR STR)
NIL)
ELSEIF (TMP←(GEVMATCH (CADR STR)
VAL NIL))
THEN (TOP←(CAR TMP))
[RESULT +←(IF ~(CDR TMP) AND ~TOP:NAME
THEN (TOP:NAME←(CAR STR))
TOP
ELSE (A GSEITEM WITH NAME =(CAR STR)
, VALUE = VAL , SUBVALUES = TMP , TYPE =(
CADR STR)
, NODETYPE =(QUOTE SUBTREE]
ELSE (PRINT "GEVMATCHB Failed"])
(GEVMATCHLISTOF
(GLAMBDA (STR VAL NAME) (* edited: " 8-OCT-82 10:15")
(* Match a LISTOF structure.)
(GLOBAL RESULT)
(RESULT+←(A GSEITEM WITH NAME = NAME , VALUE = VAL , TYPE = STR))))
(GEVMATCHOBJECT
[GLAMBDA (STR VAL NAME) (* edited: "22-DEC-82 10:04")
(* Match the OBJECT structures.)
(GLOBAL RESULT)
(PROG ((OBJECTTYPE (CAR STR))
TMP)
(RESULT ←+(A GSEITEM WITH NAME =(QUOTE CLASS)
VALUE =[CASE OBJECTTYPE OF ((OBJECT LISTOBJECT)
(TMP-←VAL))
(ATOMOBJECT (GETPROP VAL (QUOTE CLASS]
TYPE =(QUOTE GLTYPE)))
(FOR X IN (CDR STR) DO (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT)
(IF VAL (GEVMATCHB X (TMP-←VAL)
NIL NIL)))
(ATOMOBJECT (IF TMP←(GETPROP VAL (CAR X))
THEN (GEVMATCHB X TMP NIL NIL])
(GEVMATCHPROPLIST
[GLAMBDA (STR VAL NAME) (* edited: "24-NOV-82 16:31")
(* Match an PROPLIST structure to a given value.)
(PROG (L TMP)
(L←(CDR STR))
(FOR X IN L DO (IF TMP←(LISTGET VAL (CAR X))
THEN (GEVMATCHB X TMP NIL NIL])
(GEVMATCHRECORD
[GLAMBDA (STR VAL NAME) (* edited: "21-DEC-82 17:32")
(* Match a RECORD structure.)
(PROG (STRNAME FIELDS)
(IF (CADR STR) IS ATOMIC
THEN STRNAME←(CADR STR)
FIELDS←(CDDR STR)
ELSE FIELDS←(CDR STR))
(FOR X IN FIELDS DO (GEVMATCHB X (RECORDACCESS (CAR X)
VAL NIL NIL STRNAME)
NIL NIL])
(GEVMOUSELOOP
(GLAMBDA NIL (* edited: "27-SEP-82 16:24")
(* Wait in a loop for mouse actions within the edit
window.)
(PROG NIL)))
(GEVMOVEWINDOWFN
[LAMBDA (W NEWPOS) (* edited: " 5-OCT-82 11:36")
(PROG NIL
(MOVEW GEVMENUWINDOW (CONS (CAR NEWPOS)
(IDIFFERENCE (CDR NEWPOS)
GEVMENUWINDOWHEIGHT])
(GEVPOP
(GLAMBDA (FLG:BOOLEAN N:INTEGER) (* edited: "11-NOV-82 17:13")
(* Pop up from the current item to the previous one.
If FLG is set, popping continues through extended LISTOF
elements.)
(PROG (TMP TOP:GSEITEM TMPITEM)
(IF N<1 (RETURN))
LP (TMP-←GEVEDITCHAIN)
(IF ~GEVEDITCHAIN
THEN (RETURN (GEVQUIT)))
(TOP←(CAAAR GEVEDITCHAIN)) (* Test for repeated LISTOF elements.)
(TMPITEM←(CAR TMP:PREVS))
(IF FLG AND TMPITEM:NODETYPE='FORWARD
THEN (GO LP))
(IF (N←-1)
>0
THEN (GO LP))
(IF GEVEDITFLG AND ~(MEMBER TMPITEM:SHORTVALUE (QUOTE ("(...)" "---")))
THEN (GEVREFILLWINDOW)
ELSE GEVEDITFLG←NIL
(GEVFILLWINDOW))
(GEVMOUSELOOP))))
(GEVPOSTEST
(GLAMBDA (POS,TPOS:VECTOR NAME ITEM:GSEITEM FLG N:INTEGER)
(* edited: "21-OCT-82 10:54")
(RESULT MOUSESTATE)
(* Test whether TPOS contains the mouse position POS. The result is NIL if not found, else a list of the sub-item
and a flag which is NIL if the NAME part is identified, T if the VALUE part is identified.)
(IF POS:Y>=TPOS:Y AND POS:Y<=TPOS:Y+12 AND POS:X>=TPOS:X AND POS:X<TPOS:X+100
THEN (A MOUSESTATE WITH AREA =(AN AREA WITH START =(A VECTOR WITH X = TPOS:X , Y =
TPOS:Y - 1)
, SIZE =(A VECTOR WITH X = GEVCHARWIDTH*(NCHARS
NAME)
, Y = 12))
, ITEM = ITEM , FLAG = FLG , GROUP = N))))
(GEVPPS
[GLAMBDA (ITEM:GSEITEM COL:INTEGER WINDOW:WINDOW) (* edited: "22-DEC-82 15:56")
(GLOBAL Y:INTEGER)
(* Pretty-print a structure defined by ITEM in the window WINDOW, beginning ar horizontal column COL and vertical
position Y. The positions in ITEM are modified to match the positions in the window.)
(PROG (NAMEX VALX TOP) (* Make sure there is room in window.)
(IF Y<0
THEN (RETURN)) (* Position in window for slot name.)
(NAMEX←COL*GEVCHARWIDTH)
(ITEM:NAMEPOS:X←NAMEX)
(ITEM:NAMEPOS:Y←Y)
(MOVETO NAMEX Y WINDOW)
(IF ITEM:NODETYPE='FULLVALUE
THEN (PRIN1 "(expanded)" WINDOW)
ELSEIF ITEM:NAME
THEN (IF ITEM:NAME IS NUMERIC
THEN (PRIN1 "#" WINDOW))
(PRIN1 (GEVLENGTHBOUND ITEM:NAME 11)
WINDOW)) (* See if there is a value to print for this name.)
(IF ~ITEM:NODETYPE OR (MEMB ITEM:NODETYPE (QUOTE (FORWARD BACKUP PROP ADJ MSG)))
THEN (VALX←NAMEX+100)
(ITEM:VALUEPOS:X←VALX)
(ITEM:VALUEPOS:Y←Y)
(MOVETO VALX Y WINDOW)
(PRIN1 [ITEM:SHORTVALUE OR (ITEM:SHORTVALUE ←(GEVSHORTVALUE ITEM:VALUE
ITEM:TYPE
(GEVSHORTCHARS
- COL]
WINDOW)
(IF ~(EQ ITEM:SHORTVALUE ITEM:VALUE)
THEN (MOVETO (VALX - 20)
Y WINDOW)
(PRIN1 "~" WINDOW))
(Y←-12)
ELSEIF ITEM:NODETYPE='FULLVALUE
THEN (Y←-12)
(MOVETO 0 Y WINDOW)
(RESETLST (RESETSAVE SYSPRETTYFLG T)
(SHOWPRINT ITEM:VALUE WINDOW))
(Y←WINDOW:YPOSITION
- 12)
ELSEIF ITEM:NODETYPE='DISPLAY
THEN (GEVEXPROP ITEM:VALUE ITEM:TYPE (QUOTE GEVDISPLAY)
(QUOTE MSG)
(LIST WINDOW Y))
ELSE (* This is a subtree)
Y←-12
(FOR VSUB IN ITEM:SUBVALUES DO (GEVPPS VSUB COL+2 WINDOW])
(GEVPROGRAM
(GLAMBDA NIL (* edited: " 8-NOV-82 09:42")
(* Write an interactive program involving the current
item.)
(PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST)
(TOPITEM←GEVEDITCHAIN:TOPITEM)
(IF [COMMAND←(MENU (create MENU
ITEMS ←(QUOTE (Quit COLLECT TOTAL AVERAGE MAXIMUM MINIMUM]
='Quit
OR ~ COMMAND
THEN (RETURN))
(IF (SET←(GEVPROPMENU TOPITEM:TYPE (QUOTE LIST)
NIL))='Quit OR SET='Pop OR ~SET
THEN (RETURN))
(PATH←(LIST SET (LIST TOPITEM:NAME TOPITEM:TYPE)))
(NEXT←SET)
(TYPE←(CADADR SET))
(WHILE ~DONE DO (NEXT←(GEVPROPMENU TYPE (COMMAND~='COLLECT AND (QUOTE NUMBER))
COMMAND='COLLECT))
[CASE NEXT OF ((NIL Quit)
(RETURN))
[Pop (IF ~(CDDR PATH)
THEN (RETURN)
ELSE (NEXT-←PATH)
(NEXT←(CAR PATH))
(TYPE←(CADR NEXT))
(LAST←(CAR NEXT]
(Done (DONE←T))
ELSE
(PROGN (PATH+←NEXT)
(TYPE←(CADR NEXT))
(LAST←(CAR NEXT]
(IF (MEMB TYPE (QUOTE (ATOM INTEGER STRING REAL BOOLEAN NIL)))
DONE←T))
(PATH←(DREVERSE PATH))
(NEWFN←(GEVMAKENEWFN COMMAND TOPITEM:TYPE SET (CDDR PATH)))
(PUTD (QUOTE GEVNEWFN)
(CAR NEWFN))
(RESULT←(GEVNEWFN TOPITEM:VALUE)) (* Print result as well as displaying it.)
(PRIN1 COMMAND)
(SPACES 1)
(FOR X IN (CDDR PATH) DO (PRIN1 (CAR X))
(SPACES 1))
(PRIN1 "OF ")
(PRIN1 (CAAR PATH))
(SPACES 1)
(PRIN1 (CAADR PATH))
(PRIN1 " = ")
(PRINT RESULT)
(GEVEDITCHAIN:TOPFRAME:PROPS←+(A GSEITEM WITH NAME =(CONCAT COMMAND " " LAST)
, TYPE =(CADR NEWFN)
, VALUE = RESULT , NODETYPE =(QUOTE MSG)))
(GEVDISPLAYNEWPROP))))
(GEVPROPMENU
[GLAMBDA (OBJ:GLTYPE FILTER:ATOM FLG:BOOLEAN) (* edited: "22-DEC-82 14:26")
(* Make a menu to get properties of object OBJ with
filter FILTER.)
(PROG (PROPS SEL PNAMES MENU)
(PROPS←(GEVGETNAMES OBJ FILTER))
(IF ~PROPS
THEN (RETURN)
ELSE (PNAMES←(MAPCAR PROPS (FUNCTION CAR)))
(SEL←(SEND [A MENU WITH ITEMS =(CONS (QUOTE Quit)
(CONS (QUOTE Pop)
(IF FLG
THEN (CONS (QUOTE Done)
PNAMES)
ELSE PNAMES]
SELECT))
(RETURN (CASE SEL OF ((Quit Pop Done NIL)
SEL)
ELSE
(ASSOC SEL PROPS])
(GEVPROPNAMES
(GLAMBDA (OBJ:GLTYPE PROPTYPE:ATOM FILTER:ATOM) (* edited: "22-DEC-82 14:52")
(* Get all property names and types of properties of
type PROPTYPE for OBJ when they satisfy FILTER.)
(PROG (RESULT TYPE)
(RESULT ←(FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS)
(ADJ OBJ:ADJS)
(ISA OBJ:ISAS)
(MSG OBJ:MSGS))
WHEN (TYPE←(GEVPROPTYPE! OBJ P:NAME (QUOTE PROP)))
AND (GEVFILTER TYPE FILTER)
COLLECT (LIST P:NAME TYPE)))
[FOR S IN OBJ:SUPERS DO (RESULT ←(NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER]
(RETURN RESULT))))
(GEVPROPTYPE
[GLAMBDA (STR,PROPNAME,PROPTYPE:ATOM) (* edited: "22-DEC-82 13:56")
(* Find the type of a computed property.)
(PROG (PL SUBPL PROPENT TMP)
(IF STR IS NOT ATOMIC
THEN (RETURN)
ELSEIF (PROPENT←(GEVGETPROP STR PROPNAME PROPTYPE))
AND (TMP←(LISTGET (CDDR PROPENT)
(QUOTE RESULT)))
THEN (RETURN TMP)
ELSEIF PROPENT AND (CADR PROPENT) IS ATOMIC AND (TMP←(GETPROP (CADR PROPENT)
(QUOTE GLRESULTTYPE))
)
THEN (RETURN TMP)
ELSEIF (AND (PL←(GETPROP STR (QUOTE GLPROPFNS)))
(SUBPL←(ASSOC PROPTYPE PL))
(PROPENT←(ASSOC PROPNAME (CDR SUBPL)))
(TMP←(CADDR PROPENT)))
THEN (RETURN TMP)
ELSEIF PROPTYPE='ADJ
THEN (RETURN (QUOTE BOOLEAN])
(GEVPROPTYPE!
[LAMBDA (OBJ NAME TYPE) (* edited: " 4-NOV-82 15:39")
(OR (GEVPROPTYPE OBJ NAME TYPE)
(AND (GEVCOMPPROP OBJ NAME TYPE)
(GEVPROPTYPE OBJ NAME TYPE])
(GEVPUSH
(GLAMBDA (ITEM:GSEITEM) (* edited: "11-NOV-82 16:23")
(* Push down to look at an item referenced from the
current item.)
(PROG (NEWITEMS TOPITEM)
(IF ITEM:NODETYPE='BACKUP
THEN (GEVPOP NIL 1)
(RETURN))
(TOPITEM←GEVEDITCHAIN:TOPITEM)
(IF ITEM:NODETYPE='FORWARD
THEN (NEWITEMS←(GEVPUSHLISTOF ITEM T))
ELSEIF ITEM:TYPE IS ATOMIC AND ~(GETPROP ITEM:TYPE (QUOTE GLSTRUCTURE))
THEN (CASE ITEM:TYPE OF
[(ATOM NUMBER REAL INTEGER STRING ANYTHING)
(IF ITEM:VALUE=ITEM:SHORTVALUE
THEN (RETURN)
ELSE (NEWITEMS←(LIST (A GSEITEM WITH NAME = ITEM:NAME , VALUE =
ITEM:VALUE , SHORTVALUE = ITEM:SHORTVALUE
, TYPE = ITEM:TYPE , NODETYPE =(QUOTE
FULLVALUE]
ELSE
(RETURN))
ELSEIF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE)='LISTOF
THEN (NEWITEMS←(GEVPUSHLISTOF ITEM NIL)))
(GEVEDITCHAIN+←(AN EDITFRAME WITH PREVS =(CONS ITEM GEVEDITCHAIN:TOPFRAME:PREVS)
, SUBITEMS = NEWITEMS))
(GEVREFILLWINDOW)
(GEVMOUSELOOP))))
(GEVPUSHLISTOF
[GLAMBDA (ITEM:GSEITEM FLG:BOOLEAN) (* edited: "16-OCT-82 15:15")
(* Push into a datum of type LISTOF, expanding it into the individual elements. If FLG is set, ITEM is a FORWARD
item to be continued.)
(PROG (ITEMTYPE TOPFRAME N:INTEGER NROOM LST VALS:(LISTOF ANYTHING)
TMP) (* Compute the vertical room available in the window.)
(IF ~ITEM:VALUE (RETURN))
(TOPFRAME←GEVEDITCHAIN:TOPFRAME)
(NROOM ←(GEVWINDOW:HEIGHT - 50)/12 -(LENGTH TOPFRAME:PREVS))
(* If there was a previous display of this list, insert
an ellipsis header.)
(IF FLG
THEN (LST+←(A GSEITEM WITH SHORTVALUE = "(..." , NODETYPE =(QUOTE BACKUP)))
(N←ITEM:NAME)
(ITEMTYPE←ITEM:TYPE)
(NROOM←-1)
(VALS←ITEM:SUBVALUES)
ELSE (N←1)
(ITEMTYPE←(CADR ITEM:TYPE))
(VALS←ITEM:VALUE)) (* Now make entries for each value on the list.)
(WHILE VALS AND (NROOM>1 OR (NROOM=1 AND ~(CDR VALS)))
DO (LST+←(A GSEITEM WITH VALUE =(TMP-←VALS)
, TYPE = ITEMTYPE , NAME = N))
(NROOM←-1)
(N←+1))
(IF VALS
THEN (LST+←(A GSEITEM WITH SHORTVALUE = "...)" , NODETYPE =(QUOTE FORWARD)
, TYPE = ITEMTYPE , NAME = N , SUBVALUES = VALS)))
(RETURN (LIST (A GSEITEM WITH NAME = "expanded" , TYPE = ITEMTYPE , NODETYPE =(QUOTE
LISTOF)
, SUBVALUES =(DREVERSE LST])
(GEVQUIT
(GLAMBDA NIL (* edited: "13-OCT-82 10:55")
(SETQ GEVACTIVEFLG NIL)
(← GEVWINDOW CLOSE)
(← GEVMENUWINDOW CLOSE)))
(GEVREDOPROPS
[GLAMBDA (TOP:EDITFRAME) (* edited: "19-OCT-82 10:23")
(* Recompute property values for the item.)
(PROG (ITEM L)
(ITEM←(CAR TOP:PREVS))
(IF ~TOP:PROPS AND (L←(GEVEXPROP ITEM:VALUE ITEM:TYPE (QUOTE DISPLAYPROPS)
(QUOTE PROP)
NIL))
~='GEVERROR
THEN (IF L IS ATOMIC
THEN (GEVCOMMANDPROP ITEM (QUOTE PROP)
(QUOTE All))
ELSEIF L IS A LIST
THEN (FOR X IN L (GEVCOMMANDPROP ITEM (QUOTE PROP)
X)))
ELSE (FOR X IN TOP:PROPS WHEN X:NODETYPE~='MSG
DO (X:VALUE ←(GEVEXPROP ITEM:VALUE ITEM:TYPE X:NAME X:NODETYPE NIL))
(X:SHORTVALUE ← NIL])
(GEVREFILLWINDOW
(GLAMBDA NIL (* edited: "14-OCT-82 12:46")
(* Re-expand the top item of GEVEDITCHAIN, which may
have been changed due to editing.)
(PROG (TOP TOPITEM SUBS TOPSUB)
(TOP←GEVEDITCHAIN:TOPFRAME)
(TOPITEM←GEVEDITCHAIN:TOPITEM)
(TOPSUB←(CAR TOP:SUBITEMS))
[IF ~TOPSUB OR (TOPSUB:NODETYPE~='FULLVALUE AND TOPSUB:NODETYPE~='LISTOF)
THEN (IF (GEVGETPROP TOPITEM:TYPE (QUOTE GEVDISPLAY)
(QUOTE MSG))
THEN [TOP:SUBITEMS←(LIST (A GSEITEM WITH VALUE = TOPITEM:VALUE , TYPE =
TOPITEM:TYPE , NODETYPE =(QUOTE DISPLAY]
ELSE (SUBS←(GEVMATCH TOPITEM:TYPE TOPITEM:VALUE T))
(TOPSUB←(CAR SUBS))
(TOP:SUBITEMS←(IF ~(CDR SUBS) AND TOPSUB:NODETYPE='STRUCTURE
AND TOPSUB:VALUE=TOPITEM:VALUE AND
TOPSUB:TYPE=TOPITEM:TYPE
THEN TOPSUB:SUBVALUES
ELSE SUBS]
(GEVREDOPROPS TOP)
(GEVFILLWINDOW))))
(GEVSHORTATOMVAL
[LAMBDA (ATM NCHARS) (* edited: " 8-OCT-82 15:41")
(COND
((NUMBERP ATM)
(COND
((IGREATERP (NCHARS ATM)
NCHARS)
(GEVSHORTSTRINGVAL (MKSTRING ATM)
NCHARS))
(T ATM)))
((IGREATERP (NCHARS ATM)
NCHARS)
(CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS))
"-"))
(T ATM])
(GEVSHORTCONSVAL
[GLAMBDA (VAL STR NCHARS:INTEGER) (* edited: " 8-OCT-82 15:19")
(* Compute a short value for printing a CONS of two
items.)
(PROG (NLEFT RES TMP NC)
(RES +← "(")
(NLEFT ← NCHARS - 5)
(TMP←(GEVSHORTVALUE (CAR VAL)
(CADR STR)
NLEFT - 3))
(NC←(NCHARS TMP))
(IF NC>NLEFT - 3
THEN TMP← "---" NC←3)
(RES+←TMP)
(RES +← " . ")
(NLEFT←-NC)
(TMP←(GEVSHORTVALUE (CDR VAL)
(CADDR STR)
NLEFT))
(NC←(NCHARS TMP))
(IF NC>NLEFT
THEN TMP← "---" NC←3)
(RES+←TMP)
(RES+← ")")
(RETURN (APPLY (FUNCTION CONCAT)
(DREVERSE RES])
(GEVSHORTLISTVAL
[GLAMBDA (VAL STR NCHARS:INTEGER) (* edited: " 6-NOV-82 15:01")
(* Compute a short value for printing a list of items.)
(PROG (NLEFT RES TMP QUIT NC NCI REST RSTR)
(RES +← "(")
(REST←4)
(NLEFT ← NCHARS - 2)
(RSTR←(CDR STR))
[WHILE VAL AND ~QUIT AND (NCI←(IF (CDR VAL)
THEN NLEFT - REST
ELSE NLEFT))
>2
DO (TMP←(GEVSHORTVALUE (CAR VAL)
(IF (CAR STR)='LISTOF
THEN (CADR STR)
ELSEIF (CAR STR)='LIST
THEN (CAR RSTR))
NCI))
[QUIT ←(MEMBER TMP (QUOTE (GEVERROR "(...)" "---" "???"]
(NC←(NCHARS TMP))
(IF NC>NCI AND (CDR RES)
THEN QUIT←T
ELSE (IF NC>NCI
THEN TMP← "---" NC←3
QUIT←T)
(RES+←TMP)
(NLEFT←-NC)
(VAL←(CDR VAL))
(RSTR←(CDR RSTR))
(IF VAL
THEN (RES+← " ")
(NLEFT←-1]
(IF VAL
THEN (RES+← "..."))
(RES+← ")")
(RETURN (APPLY (FUNCTION CONCAT)
(DREVERSE RES])
(GEVSHORTSTRINGVAL
[LAMBDA (VAL NCHARS) (* edited: "12-OCT-82 12:14")
(* Compute the short value of a string VAL.
The result is a string which can be printed within
NCHARS.)
(COND
((STRINGP VAL)
(GEVLENGTHBOUND VAL NCHARS))
(T "???"])
(GEVSHORTVALUE
[LAMBDA (VAL STR NCHARS) (* edited: " 6-NOV-82 14:37")
(* Compute the short value of a given value VAL whose type is STR. The result is an atom, string, or list
structure which can be printed within NCHARS.)
(PROG (TMP)
(SETQ STR (GEVXTRTYPE STR))
(RETURN (COND
([AND (ATOM STR)
(FMEMB STR (QUOTE (ATOM INTEGER REAL]
(GEVSHORTATOMVAL VAL NCHARS))
((EQ STR (QUOTE STRING))
(GEVSHORTSTRINGVAL VAL NCHARS))
((AND (ATOM STR)
(NEQ (SETQ TMP (GEVEXPROP VAL STR (QUOTE SHORTVALUE)
(QUOTE PROP)
NIL))
(QUOTE GEVERROR)))
(GEVLENGTHBOUND TMP NCHARS))
((OR (ATOM VAL)
(NUMBERP VAL))
(GEVSHORTATOMVAL VAL NCHARS))
((STRINGP VAL)
(GEVSHORTSTRINGVAL VAL NCHARS))
((LISTP STR)
(SELECTQ (CAR STR)
((LISTOF LIST)
(COND
((LISTP VAL)
(GEVSHORTLISTVAL VAL STR NCHARS))
(T "???")))
(CONS (COND
((LISTP VAL)
(GEVSHORTCONSVAL VAL STR NCHARS))
(T "???")))
"---"))
((LISTP VAL)
(GEVSHORTLISTVAL VAL STR NCHARS))
(T "---"])
(GEVXTRTYPE
[LAMBDA (TYPE) (* edited: "21-OCT-82 11:17")
(* Extract an atomic type name from a type spec which
may be either <type> or (A <type>).)
(COND
((ATOM TYPE)
TYPE)
((NLISTP TYPE)
NIL)
((AND (FMEMB (CAR TYPE)
(QUOTE (A AN a an An TRANSPARENT)))
(CDR TYPE)
(ATOM (CADR TYPE)))
(CADR TYPE))
((MEMB (CAR TYPE)
GEVTYPENAMES)
TYPE)
((AND (BOUNDP GLUSERSTRNAMES)
(ASSOC (CAR TYPE)
GLUSERSTRNAMES))
TYPE)
((AND (ATOM (CAR TYPE))
(CDR TYPE))
(GEVXTRTYPE (CADR TYPE)))
(T (ERROR (QUOTE GEVXTRTYPE)
(LIST TYPE "is an illegal type specification."))
NIL])
(PICTURE-GEVDISPLAY
(GLAMBDA (PICTURE,WINDOW:WINDOW YMAX) (* edited: "14-OCT-82 14:12")
(* Display PICTURE in (GLOBAL Y:INTEGER) WINDOW within
YMAX.)
(PROG (PWD PHT NEWX NEWY)
(PHT←(MIN (YMAX - 20)
PICTURE:HEIGHT))
(PWD ←(MIN (WINDOW:WIDTH - 20)
PICTURE:WIDTH))
(NEWX ←(WINDOW:WIDTH - PWD)/2)
(NEWY ← YMAX - PHT - 10)
(MOVEW PICTURE (CONS 0 0)) (* Also copy the picture onto the current window.)
(BITBLT PICTURE 1 1 WINDOW NEWX NEWY PWD PHT (QUOTE INPUT)
(QUOTE REPLACE)
NIL NIL)
(MOVEW PICTURE (CONS (WINDOW:LEFT+NEWX)
(WINDOW:BOTTOM+NEWY)))
(Y ← NEWY - 12))))
(VECTOR-SHORTVALUE
(GLAMBDA (V:VECTOR) (* edited: " 7-OCT-82 12:58")
(CONCAT "(" (MKSTRING V:X)
","
(MKSTRING V:Y)
")")))
)
(RPAQQ GEVTYPENAMES (CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS GEVACTIVEFLG GEVCHARWIDTH GEVEDITCHAIN GEVEDITFLG GEVMENUWINDOW
GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS GLNATOM RESULT Y)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML GEV)
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (4249 52038 (AREA-CONTAINS 4259 . 4572) (GEV 4574 . 4952) (GEVA 4954 . 6030) (
GEVBUTTONEVENTFN 6032 . 7969) (GEVCOMMANDFN 7971 . 8566) (GEVCOMMANDPROP 8568 . 9742) (
GEVCOMMANDPROPNAMES 9744 . 10728) (GEVCOMPPROP 10730 . 11853) (GEVDATANAMES 11855 . 12233) (
GEVDATANAMESB 12235 . 13375) (GEVDISPLAYNEWPROP 13377 . 13795) (GEVDOPROP 13797 . 14473) (GEVEDIT
14475 . 15224) (GEVEXPROP 15226 . 15796) (GEVFILLWINDOW 15798 . 16744) (GEVFILTER 16746 . 17199) (
GEVFINDITEMPOS 17201 . 17843) (GEVFINDLISTPOS 17845 . 18267) (GEVFINDPOS 18269 . 18854) (GEVGETNAMES
18856 . 19341) (GEVGETPROP 19343 . 19881) (GEVGLISPP 19883 . 20026) (GEVHORIZLINE 20028 . 20356) (
GEVINIT 20358 . 20512) (GEVINITEDITWINDOW 20514 . 21934) (GEVINVERTENTRY 21936 . 22352) (
GEVLENGTHBOUND 22354 . 22689) (GEVMAKENEWFN 22691 . 25409) (GEVMATCH 25411 . 25840) (GEVMATCHA 25842
. 26340) (GEVMATCHATOM 26342 . 26923) (GEVMATCHALIST 26925 . 27337) (GEVMATCHB 27339 . 29828) (
GEVMATCHLISTOF 29830 . 30131) (GEVMATCHOBJECT 30133 . 30890) (GEVMATCHPROPLIST 30892 . 31284) (
GEVMATCHRECORD 31286 . 31781) (GEVMOUSELOOP 31783 . 32055) (GEVMOVEWINDOWFN 32057 . 32301) (GEVPOP
32303 . 33284) (GEVPOSTEST 33286 . 34079) (GEVPPS 34081 . 36167) (GEVPROGRAM 36169 . 38297) (
GEVPROPMENU 38299 . 39064) (GEVPROPNAMES 39066 . 39812) (GEVPROPTYPE 39814 . 40749) (GEVPROPTYPE!
40751 . 40980) (GEVPUSH 40982 . 42271) (GEVPUSHLISTOF 42273 . 43884) (GEVQUIT 43886 . 44075) (
GEVREDOPROPS 44077 . 44931) (GEVREFILLWINDOW 44933 . 46070) (GEVSHORTATOMVAL 46072 . 46451) (
GEVSHORTCONSVAL 46453 . 47314) (GEVSHORTLISTVAL 47316 . 48568) (GEVSHORTSTRINGVAL 48570 . 48967) (
GEVSHORTVALUE 48969 . 50248) (GEVXTRTYPE 50250 . 51033) (PICTURE-GEVDISPLAY 51035 . 51845) (
VECTOR-SHORTVALUE 51847 . 52036)))))
STOP