Artifact 4fa9ac1eb125ecbb698de8f1b5727e9bc0665c855f06c89d438b1cbc872f1dff:
- File
psl-1983/glisp/gev.old
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 48037) [annotate] [blame] [check-ins using] [more...]
% GEV Editor, PSL version. G. Novak 31 Jan. 1983 [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) % GSN "21-JAN-83 10:24" % Filter types according to a specified FILTER. (TYPE_(GEVXTRTYPE TYPE)) (CASE FILTER OF (NUMBER ~(MEMB TYPE (QUOTE (ATOM STRING BOOLEAN ANYTHING))) 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) % GSN "21-JAN-83 13:50" % 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 TOP:TYPE IS A LIST AND (CAR TOP:TYPE)='LISTOF AND ~(CDR TOP:VALUE) 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) % GSN "21-JAN-83 10:25" (GLOBAL Y:INTEGER) % Pretty-print a structure defined by ITEM in the window WINDOW, beginning % at 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 ISA))) 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 % GSN "21-JAN-83 10:56" % Write an interactive program involving the current item. (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (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 AND ~ABORTFLG DO (NEXT_(GEVPROPMENU TYPE (COMMAND~='COLLECT AND (QUOTE NUMBER)) COMMAND='COLLECT)) [CASE NEXT OF ((NIL Quit) (ABORTFLG_T)) [Pop (IF ~(CDDR PATH) THEN (ABORTFLG_T) ELSE (NEXT-_PATH) (NEXT_(CAR PATH)) (TYPE_(CADR NEXT)) (IF TYPE IS A LIST THEN TYPE_(CADR TYPE)) (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)) (IF ABORTFLG (RETURN)) (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) % GSN "21-JAN-83 10:32" % Make a menu to get properties of object OBJ with filter FILTER. FLG % is T if it is okay to stop before reaching a basic type. (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) % GSN "24-JAN-83 14:14" % Push down to look at an item referenced from the current item. (PROG (NEWITEMS TOPITEM LSTITEM:GSEITEM) (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)) % Do another PUSH automatically for a list of only one item. (GEVREFILLWINDOW) (IF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE)='LISTOF AND ~(CDR ITEM:VALUE) THEN (LSTITEM_(CAADAR GEVEDITCHAIN)) (GEVPUSH (CAR LSTITEM:SUBVALUES)) (RETURN)) (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))