reduce-historical/psl-1983/glisp/gev.old

%     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))