(FILECREATED "16-Dec-83 13:41:21" <CS.NOVAK>GLTEST.LSP.10 30204  


     changes to:  GLTESTCOMS STUDENT CLASS

     previous date: "15-Dec-83 13:41:52" <CS.NOVAK>GLTEST.LSP.9)


(PRETTYCOMPRINT GLTESTCOMS)

(RPAQQ GLTESTCOMS ((* Test file for GLISP compiler)
	(* Copyright (c)
	   1983 by Gordon S. Novak Jr.)
	(* Note: much of the data in this file is pure fiction, 
	   especially the personnel data.)
	(GLISPOBJECTS EMPLOYEE DATE COMPANY PROJECT CONTRACT AGENCY 
		      PERSON BUDGET ADDRESS PHONE-NUMBER PICTURE 
		      CAMPUS-ADDRESS BUILDING)
	(FNS GIVE-RAISE CURRENTDATE TODAYS-DATE TOTAL-BUDGET 
	     INIT-COMPANY GEVDEMO-INIT)
	(GLISPOBJECTS VECTOR FVECTOR RVECTOR VOFV RADIANS DEGREES 
		      REGION)
	(FNS VECTORPLUS VECTORDIFF VECTORTIMES VECTORTIMESSCALAR 
	     VECTORDOTPRODUCT VECTORQUOTIENTSCALAR VECTORMOVE 
	     VECTOR-SHORTVALUE REGION-CONTAINS)
	(PROP DRAWFN RECTANGLE)
	(* Now we define some test functions which use the above 
	   definitions. First there are some simple functions which 
	   test vector operations.)
	(FNS TVPLUS TFVPLUS TVOFVPLUS TVMOVE TVTIMESV TVTIMESN)
	(* Next we define some graphics objects that use VECTOR 
	   operations in their definitions.)
	(GLISPOBJECTS GRAPHICSOBJECT MOVINGGRAPHICSOBJECT)
	(FNS GRAPHICSOBJECTMOVE MGO-ACCELERATE MGO-TEST TESTFN2 
	     DRAWRECT)
	(GLISPOBJECTS LISPTREE PREORDERSEARCHRECORD)
	(FNS PRINTLEAVES)
	(GLISPOBJECTS CIRCLE DCIRCLE)
	(FNS INIT-CIRCLES GROWCIRCLE)
	(FNS SQRTB SQUASH)
	(* The following object definitions describe a student records 
	   database.)
	(GLISPOBJECTS STUDENT STUDENT-GROUP CLASS)
	(FNS STUDENT-AVERAGE STUDENT-GRADE-AVERAGE 
	     STUDENT-GROUP-AVERAGE TEST1 TEST1B TEST2 TEST3 TEST4 
	     TEST4B EASY-PROFS EASY-PROFS-B INIT-CLASS)
	(* The following object definitions illustrate inheritance of 
	   properties from multiple parent classes. The three "bottom" 
	   classes Planet, Brick, and Bowling-Ball all inherit the same 
	   definition of the property Density, although they are 
	   represented in very different ways.)
	(GLISPOBJECTS PHYSICAL-OBJECT ORDINARY-OBJECT SPHERE 
		      PARALLELEPIPED PLANET BRICK BOWLING-BALL)
	(* Three test functions to demonstrate inheritance of the 
	   Density property.)
	(FNS DPLANET DBRICK DBB INIT-OBJECTS)
	(P (INIT-COMPANY)
	   (INIT-CIRCLES)
	   (INIT-CLASS)
	   (INIT-OBJECTS)
	   (GEVDEMO-INIT))))
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Test file for GLISP compiler)  ]

[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Copyright (c)
     1983 by Gordon S. Novak Jr.)  ]

[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Note: much of the data in this file is pure fiction, especially 
     the personnel data.)  ]



[GLISPOBJECTS


(EMPLOYEE

   (LIST (NAME STRING)
	 (DATE-HIRED (A DATE))
	 (SALARY REAL)
	 (JOBTITLE ATOM)
	 (TRAINEE BOOLEAN))

   PROP   ((SENIORITY ((THE YEAR OF (CURRENTDATE))
		       -
		       (THE YEAR OF DATE-HIRED)))
	   (MONTHLY-SALARY (SALARY * 174))
	   (SHORTVALUE (NAME))
	   (DISPLAYPROPS (T)))

   ADJ    ((HIGH-PAID (MONTHLY-SALARY > 2000)))

   ISA    ((TRAINEE (TRAINEE))
	   (GREENHORN (TRAINEE AND SENIORITY < 2)))

   MSG    ((YOURE-FIRED (SALARY _ 0)))  )

(DATE

   (LIST (MONTH INTEGER)
	 (DAY INTEGER)
	 (SHORTYEAR INTEGER))

   PROP   ([MONTHNAME ((CAR (NTH (QUOTE (January February March April 
						 May June July August 
						 September October 
						 November December))
				 MONTH]
	   (YEAR (SHORTYEAR + 1900))
	   [SHORTVALUE ((CONCAT MONTHNAME:PNAME " " (GEVSTRINGIFY
				   DAY)
				 ", "
				 (GEVSTRINGIFY YEAR]
	   (PRETTYFORM (SHORTVALUE)))  )

(COMPANY

   [ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE))
		   (EMPLOYEES (LISTOF EMPLOYEE]

   PROP   [(ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN]
  )

(PROJECT

   [ATOM (PROPLIST (TITLE STRING)
		   (ABBREVIATION ATOM)
		   (ADMINISTRATOR PERSON)
		   (CONTRACTS (LISTOF CONTRACT))
		   (EXECUTIVES (LISTOF PERSON]

   PROP   ((SHORTVALUE (ABBREVIATION))
	   (DISPLAYPROPS (T))
	   (BUDGET TOTAL-BUDGET))  )

(CONTRACT

   (ATOM (PROPLIST (TITLE STRING)
		   (LEADER PERSON)
		   (SPONSOR AGENCY)
		   (BUDGET BUDGET)))

   PROP   ((SHORTVALUE (TITLE)))  )

(AGENCY

   (ATOM (PROPLIST (NAME STRING)
		   (ABBREVIATION ATOM)
		   (ADDRESS ADDRESS)
		   (PHONE PHONE-NUMBER)))

   PROP   ((SHORTVALUE (ABBREVIATION)))  )

(PERSON

   (ATOM (PROPLIST (NAME STRING)
		   (INITIALS ATOM)
		   (TITLE ATOM)
		   (PROJECT PROJECT)
		   (SALARY REAL)
		   (SSNO INTEGER)
		   (BIRTHDATE DATE)
		   (PHONE PHONE-NUMBER)
		   (OFFICE CAMPUS-ADDRESS)
		   (HOME-ADDRESS ADDRESS)
		   (HOME-PHONE PHONE-NUMBER)
		   (PICTURE PICTURE)))

   PROP   ((SHORTVALUE (INITIALS))
	   (CONTRACTS ((THOSE CONTRACTS OF PROJECT WITH LEADER=self)))
	   (AGE ((THE YEAR OF (TODAYS-DATE))
		 - BIRTHDATE:YEAR))
	   (MONTHLY-SALARY (SALARY / 12))
	   (DISPLAYPROPS (T)))

   ADJ    [(FACULTY (TITLE <= (QUOTE (PROF ASSOC-PROF ASST-PROF]  )

(BUDGET

   (LIST (LABOR REAL)
	 (COMPUTER REAL))

   PROP   ((OVERHEAD (LABOR * .59))
	   (TOTAL (LABOR+OVERHEAD+COMPUTER))
	   (SHORTVALUE (TOTAL))
	   (DISPLAYPROPS (T)))  )

(ADDRESS

   (LIST (STREET STRING)
	 (CITY STRING)
	 (STATE ATOM)
	 (ZIP INTEGER))

   PROP   [(SHORTVALUE ((CONCAT CITY ", " STATE:PNAME]  )

(PHONE-NUMBER

   (LIST (AREA INTEGER)
	 (NUMBER INTEGER))

   PROP   [(SHORTVALUE ((CONCAT "(" (GEVSTRINGIFY AREA)
				 ") "
				 (SUBSTRING (GEVSTRINGIFY NUMBER)
					    1 3)
				 "-"
				 (SUBSTRING (GEVSTRINGIFY NUMBER)
					    4 7]

   ADJ    ((LOCAL (AREA=415 OR AREA=408)))  )

(PICTURE

   ANYTHING

   MSG    ((EDIT PAINTW)
	   (GEVDISPLAY PICTURE-GEVDISPLAY))  )

(CAMPUS-ADDRESS

   (LIST (BUILDING BUILDING)
	 (ROOM ATOM))

   PROP   [(SHORTVALUE ((CONCAT BUILDING:ABBREVIATION:PNAME " "
				 (GEVSTRINGIFY ROOM]  )

(BUILDING

   (ATOM (PROPLIST (ABBREVIATION ATOM)
		   (NAME STRING)
		   (NUMBER INTEGER)))

   PROP   ((SHORTVALUE (NAME)))  )
]

(DEFINEQ

(GIVE-RAISE
  (GLAMBDA (:COMPANY)                           (* Program to give 
						raises to the 
						electricians.)
    (FOR EACH ELECTRICIAN WHO IS NOT A TRAINEE
       DO (SALARY _+(IF SENIORITY > 1
			THEN 2.5
		      ELSE 1.5))
	  (PRINT (THE NAME OF THE ELECTRICIAN))
	  (PRINT (THE PRETTYFORM OF DATE-HIRED))
	  (PRINT MONTHLY-SALARY))))

(CURRENTDATE
  (GLAMBDA NIL                                  (* GSN " 7-AUG-83 15:57"
)
    (RESULT DATE)
    (A DATE WITH SHORTYEAR = 83 MONTH = 12 DAY = 15)))

(TODAYS-DATE
  (GLAMBDA NIL                                  (* GSN " 7-AUG-83 15:20"
)
    (RESULT DATE)                               (* edited: 
						"22-OCT-82 16:54")
    (A DATE WITH MONTH = 12 , DAY = 15 , SHORTYEAR = 83)))

(TOTAL-BUDGET
  (GLAMBDA (P:PROJECT)                          (* edited: 
						"22-OCT-82 17:13")
    (PROG (SUM)
          (SUM_0.0)
          (FOR EACH CONTRACT SUM _+ BUDGET:TOTAL)
          (RETURN SUM))))

(INIT-COMPANY
  [GLAMBDA NIL                                  (* GSN " 7-AUG-83 15:58"
)                                               (* Some test data for 
						the above functions.)
    (SETQ COMPANY1
      (A COMPANY WITH PRESIDENT =(AN EMPLOYEE WITH NAME = 
				     "OSCAR THE GROUCH"
				     SALARY = 88.0 JOBTITLE = 
				     'PRESIDENT DATE-HIRED =(A DATE 
							       WITH 
							      MONTH = 3 
							       DAY = 15 
							  SHORTYEAR = 7)
				     )
	 EMPLOYEES =(LIST (AN EMPLOYEE WITH NAME = "COOKIE MONSTER" 
			      SALARY = 12.5 JOBTITLE = 'ELECTRICIAN 
			      DATE-HIRED =(A DATE WITH MONTH = 7 DAY = 
					     21 SHORTYEAR = 47))
			  (AN EMPLOYEE WITH NAME = "BETTY LOU" SALARY = 
			      9.0 JOBTITLE = 'ELECTRICIAN DATE-HIRED =(
				A DATE WITH MONTH = 5 DAY = 15 
				  SHORTYEAR = 80))
			  (AN EMPLOYEE WITH NAME = "GROVER" SALARY = 
			      3.0 JOBTITLE = 'ELECTRICIAN TRAINEE = T 
			      DATE-HIRED =(A DATE WITH MONTH = 6 DAY = 
					     13 SHORTYEAR = 78])

(GEVDEMO-INIT
  [GLAMBDA NIL                                  (* GSN " 9-FEB-83 11:24"
)                                               (* Initialize data 
						structures for GEV 
						demo.)
    (PROG NIL
          (HPP _(A PROJECT WITH TITLE = "Heuristic Programming Project" 
		   , ABBREVIATION =(QUOTE HPP)))
          (MJH _(A BUILDING WITH ABBREVIATION =(QUOTE MJH)
		   , NAME = "Margaret Jacks Hall" , NUMBER = 460))
          (ARPA _(AN AGENCY WITH NAME = 
		     "Defense Advanced Research Projects Agency"
		     , ABBREVIATION =(QUOTE ARPA)
		     , ADDRESS =(AN ADDRESS WITH STREET = 
				    "1400 Wilson Blvd."
				    , CITY = "Arlington" , STATE =(
				      QUOTE VA)
				    , ZIP = 22209)
		     , PHONE =(A PHONE-NUMBER WITH AREA = 202 , NUMBER 
				 = 6944349)))
          (NSF _(AN AGENCY WITH NAME = "National Science Foundation" , 
		    ABBREVIATION =(QUOTE NSF)
		    , ADDRESS =(AN ADDRESS WITH STREET = 
				   "1800 G STREET N.W."
				   , CITY = "Washington" , STATE =(
				     QUOTE DC)
				   , ZIP = 20550)
		    , PHONE =(A PHONE-NUMBER WITH AREA = 202 , NUMBER = 
				6327346)))
          (NIH _(AN AGENCY WITH NAME = "National Institutes of Health" 
		    , ABBREVIATION =(QUOTE NIH)
		    , ADDRESS =(AN ADDRESS WITH STREET = 
				   "9000 Rockville Pike"
				   , CITY = "Bethesda" , STATE =(QUOTE
				     MD)
				   , ZIP = 20001)
		    , PHONE =(A PHONE-NUMBER WITH AREA = 301 , NUMBER = 
				4964000)))
          (GSN _(A PERSON WITH NAME = "Gordon S. Novak Jr." , INITIALS 
		   =(QUOTE GSN)
		   , TITLE =(QUOTE VISITOR)
		   , PROJECT = HPP , SALARY = 30000.0 , SSNO = 
		   455827977 , BIRTHDATE =(A DATE WITH DAY = 21 , MONTH 
					     = 7 , SHORTYEAR = 47)
		   , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 
			       4974532)
		   , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , 
				ROOM = 244)
		   , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , 
				    NUMBER = 4935807)
		   , HOME-ADDRESS =(AN ADDRESS WITH STREET = 
				       "3857 Ross Road"
				       , CITY = "Palo Alto" , STATE =(
					 QUOTE CA)
				       , ZIP = 94303)))
          (TCR _(A PERSON WITH NAME = "Tom C. Rindfleisch" , INITIALS =(
		     QUOTE TCR)
		   , TITLE =(QUOTE ADMINISTRATOR)
		   , PROJECT = HPP , SALARY = 30000.0 , SSNO = 
		   452123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH 
					     = 1 , SHORTYEAR = 47)
		   , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 
			       4972780)
		   , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , 
				    NUMBER = 4324321)
		   , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , 
				ROOM = 236)
		   , HOME-ADDRESS =(AN ADDRESS)))
          (EAF _(A PERSON WITH NAME = "Edward A. Feigenbaum" , INITIALS 
		   =(QUOTE EAF)
		   , TITLE =(QUOTE PROF)
		   , PROJECT = HPP , SALARY = 99999.0 , SSNO = 
		   123123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH 
					     = 1 , SHORTYEAR = 37)
		   , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 
			       4974878)
		   , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , 
				ROOM = 226)
		   , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , 
				    NUMBER = 4931234)
		   , HOME-ADDRESS =(AN ADDRESS WITH STREET = " " , CITY 
				       = "Stanford" , STATE =(QUOTE
					 CA)
				       , ZIP = 94305)))
          (MRG _(A PERSON WITH NAME = "Michael R. Genesereth" , 
		   INITIALS =(QUOTE MRG)
		   , TITLE =(QUOTE ASST-PROF)
		   , PROJECT = HPP , SALARY = 31234.0 , SSNO = 
		   123123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH 
					     = 1 , SHORTYEAR = 50)
		   , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 
			       4970324)
		   , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , 
				ROOM = 234)
		   , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , 
				    NUMBER = 4324321)
		   , HOME-ADDRESS =(AN ADDRESS)))
          (J5 _(A CONTRACT WITH TITLE = "Advanced A.I. Architectures" , 
		  LEADER = EAF , SPONSOR = ARPA , BUDGET =(A BUDGET 
							     WITH LABOR 
							     = 50000.0 
							     , COMPUTER 
							     = 10000.0))
	      )
          (IA _(A CONTRACT WITH TITLE = "Intelligent Agents" , LEADER = 
		  MRG , SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 
						    70000.0 , COMPUTER 
						    = 50000.0)))
          (DART _(A CONTRACT WITH TITLE = 
		    "Diagnosis and Repair Techniques"
		    , LEADER = MRG , SPONSOR = ARPA , BUDGET =(A BUDGET 
							       WITH 
							      LABOR = 
							   100000.0 , 
							   COMPUTER = 
							   150000.0)))
          (GLISP _(A CONTRACT WITH TITLE = "GLISP" , LEADER = GSN , 
		     SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 
						 50000.0 , COMPUTER = 
						 20000.0)))
          (CM _(A PERSON WITH NAME = "Cookie Monster" , INITIALS =(
		    QUOTE CM)
		  , TITLE =(QUOTE MONSTER)
		  , PROJECT = HPP , SALARY = 1.0 , SSNO = 123456789 , 
		  BIRTHDATE =(A DATE WITH MONTH = 4 , DAY = 1 , 
				SHORTYEAR = 65)
		  , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 
			      4971234)
		  , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , 
			       ROOM = 252)
		  , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , 
				   NUMBER = 4561234)
		  , HOME-ADDRESS =(AN ADDRESS WITH STREET = 
				      "123 Sesame Street"
				      , CITY = "Palo Alto" , STATE =(
					QUOTE CA)
				      , ZIP = 94303)))
          (CARBM _(A CONTRACT WITH TITLE = 
		     "Carbohydrate Metabolism in Atypical Hominids"
		     , LEADER = CM , SPONSOR = NIH , BUDGET =(A BUDGET 
							       WITH 
							      LABOR = 
							       1.39 , 
							   COMPUTER = 
								5.0)))
          (HPP:ADMINISTRATOR _ TCR)
          (HPP:CONTRACTS _(LIST J5 IA DART GLISP CARBM))
          (HPP:EXECUTIVES _(LIST EAF MRG GSN TCR))
          (C _(A CIRCLE WITH START =(A VECTOR WITH X = 1 , Y = 1)
		 , RADIUS = 5.0])
)


[GLISPOBJECTS


(VECTOR

   (LIST (X INTEGER)
	 (Y INTEGER))

   PROP   [(MAGNITUDE ((SQRT X^2 + Y^2)))
	   (IMAGNITUDE ((FIX MAGNITUDE + .9999)))
	   (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    [(+ VECTORPLUS OPEN T ARGTYPES (VECTOR))
	   (- VECTORDIFF OPEN T ARGTYPES (VECTOR))
	   (* VECTORTIMESSCALAR OPEN T ARGTYPES (NUMBER))
	   (* VECTORDOTPRODUCT OPEN T ARGTYPES (VECTOR))
	   (/ VECTORQUOTIENTSCALAR OPEN T ARGTYPES (NUMBER))
	   (_+ VECTORMOVE OPEN T ARGTYPES (VECTOR))
	   (PRIN1 ((PRIN1 "(")
		   (PRIN1 X)
		   (PRIN1 ",")
		   (PRIN1 Y)
		   (PRIN1 ")")))
	   (PRINT ((GLSEND self PRIN1)
		   (TERPRI]  )

(FVECTOR

   (CONS (Y STRING)
	 (X BOOLEAN))

   SUPERS (VECTOR)

   DOC    (* "A FVECTOR is a very different kind of VECTOR: it has a" 
	 "different storage structure and different element types."
	     "However, it can still inherit some vector properties," 
	     "e.g., addition.")  )

(RVECTOR

   (LIST (X REAL)
	 (Y REAL))

   SUPERS (VECTOR)  )

(VOFV

   (LIST (X VECTOR)
	 (Y VECTOR))

   SUPERS (VECTOR)

   DOC    (* "A VOFV is a vector of vectors, that is, a vector whose" 
	     "components are VECTORs")  )

(RADIANS

   REAL

   PROP   ((DEGREES (self* (180.0 / 3.141593))
		    RESULT DEGREES)
	   (DISPLAYPROPS (T)))  )

(DEGREES

   REAL

   PROP   ((RADIANS (self* (3.141593 / 180.0))
		    RESULT RADIANS)
	   (DISPLAYPROPS (T)))  )

(REGION

   (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))
	   (TOPCENTER ((A VECTOR WITH X = LEFT+WIDTH / 2 Y = TOP)))
	   (BOTTOMCENTER ((A VECTOR WITH X = LEFT+WIDTH / 2 Y = BOTTOM))
			 )
	   (AREA (WIDTH*HEIGHT)))

   ADJ    ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO))
	   (ZERO (self IS EMPTY)))

   MSG    ((CONTAINS? REGION-CONTAINS OPEN T))  )
]

(DEFINEQ

(VECTORPLUS
  (GLAMBDA (V1:VECTOR V2:VECTOR)                (* GSN "10-FEB-83 13:41"
)
    (A (TYPEOF V1)
       WITH X = V1:X + V2:X Y = V1:Y + V2:Y)))

(VECTORDIFF
  (GLAMBDA (V1:VECTOR V2:VECTOR)                (* GSN "10-FEB-83 13:41"
)
    (A (TYPEOF V1)
       WITH X = V1:X - V2:X Y = V1:Y - V2:Y)))

(VECTORTIMES
  (GLAMBDA (V:VECTOR N:NUMBER)                  (* GSN "10-FEB-83 13:41"
)
    (A (TYPEOF V)
       WITH X = X*N Y = Y*N)))

(VECTORTIMESSCALAR
  (GLAMBDA (V:VECTOR N:NUMBER)
    (A (TYPEOF V)
       WITH X = X*N Y = Y*N)))

(VECTORDOTPRODUCT
  (GLAMBDA (V1:VECTOR V2:VECTOR)                (* GSN "10-FEB-83 13:42"
)
    (A (TYPEOF V1)
       WITH X = V1:X * V2:X Y = V1:Y * V2:Y)))

(VECTORQUOTIENTSCALAR
  (GLAMBDA (V:VECTOR N:NUMBER)
    (A (TYPEOF V)
       WITH X = X / N Y = Y / N)))

(VECTORMOVE
  (GLAMBDA (V:VECTOR DELTA:VECTOR)              (* GSN "10-FEB-83 13:43"
)
    (V:X _+
	 DELTA:X)
    (V:Y _+
	 DELTA:Y)
    V))

(VECTOR-SHORTVALUE
  (GLAMBDA (V:VECTOR)                           (* edited: 
						" 7-OCT-82 12:58")
    (CONCAT "(" (MKSTRING V:X)
	    ","
	    (MKSTRING V:Y)
	    ")")))

(REGION-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)))
)

(PUTPROPS RECTANGLE DRAWFN DRAWRECT)
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Now we define some test functions which use the above definitions. 
     First there are some simple functions which test vector 
     operations.)  ]

(DEFINEQ

(TVPLUS
  (GLAMBDA (U:VECTOR V:VECTOR)
    U+V))

(TFVPLUS
  (GLAMBDA (U:FVECTOR V:FVECTOR)
    U+V))

(TVOFVPLUS
  (GLAMBDA (U:VOFV V:VOFV)
    U+V))

(TVMOVE
  (GLAMBDA (U:VECTOR V:VECTOR)
    U _+ V))

(TVTIMESV
  (GLAMBDA (U:VECTOR V:VECTOR)
    U*V))

(TVTIMESN
  (GLAMBDA (U:VECTOR V:NUMBER)
    U*V))
)
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Next we define some graphics objects that use VECTOR operations in 
     their definitions.)  ]



[GLISPOBJECTS


(GRAPHICSOBJECT

   (LIST (SHAPE ATOM)
	 (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)))

   MSG    ([DRAW ((APPLY* (GETPROP SHAPE 'DRAWFN)
			  self
			  (QUOTE PAINT]
	   [ERASE ((APPLY* (GETPROP SHAPE 'DRAWFN)
			   self
			   (QUOTE ERASE]
	   (MOVE GRAPHICSOBJECTMOVE OPEN T))  )

(MOVINGGRAPHICSOBJECT

   (LIST (TRANSPARENT GRAPHICSOBJECT)
	 (VELOCITY VECTOR))

   MSG    [(ACCELERATE MGO-ACCELERATE OPEN T)
	   (STEP ((GLSEND self MOVE VELOCITY]  )
]

(DEFINEQ

(GRAPHICSOBJECTMOVE
  (GLAMBDA (self:GRAPHICSOBJECT DELTA:VECTOR)   (* edited: 
						"11-JAN-82 16:07")
    (GLSEND self ERASE)
    (START _+
	   DELTA)
    (GLSEND self DRAW)))

(MGO-ACCELERATE
  (GLAMBDA (self: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR)
    VELOCITY _+
    ACCELERATION))

(MGO-TEST
  (GLAMBDA NIL

          (* This test function creates a MovingGraphicsObject
	  and then moves it across the screen by sending it 
	  MOVE messages. Everything in this example is 
	  compiled open; the STEP message involves a great 
	  deal of message inheritance.)


    (PROG (MGO N)
          (MGO _(A MOVINGGRAPHICSOBJECT WITH SHAPE =(QUOTE RECTANGLE)
		   SIZE =(A VECTOR WITH X = 4 Y = 3)
		   VELOCITY =(A VECTOR WITH X = 3 Y = 4)))
          (N _ 0)
          (WHILE (N_+1)
		 <100 (GLSEND MGO STEP))
          (GLSEND (THE START OF MGO)
		PRINT))))

(TESTFN2
  (GLAMBDA (:GRAPHICSOBJECT)                    (* This function tests 
						the properties of a 
						graphicsobject.)
    (LIST SHAPE START SIZE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT CENTER 
	  AREA)))

(DRAWRECT
  (GLAMBDA ((A GRAPHICSOBJECT)
     DSPOP:ATOM)                                (* edited: 
						"11-JAN-82 12:40")
    (PROG (OLDDS)
          (OLDDS _(CURRENTDISPLAYSTREAM DSPS))
          (DSPOPERATION DSPOP)
          (MOVETO LEFT BOTTOM)
          (DRAWTO LEFT TOP)
          (DRAWTO RIGHT TOP)
          (DRAWTO RIGHT BOTTOM)
          (DRAWTO LEFT BOTTOM)
          (CURRENTDISPLAYSTREAM OLDDS))))
)


[GLISPOBJECTS


(LISPTREE

   (CONS (CAR LISPTREE)
	 (CDR LISPTREE))

   PROP   [(LEFTSON ((IF self IS ATOMIC THEN NIL ELSE CAR)))
	   (RIGHTSON ((IF self IS ATOMIC THEN NIL ELSE CDR]

   ADJ    ((EMPTY (~self)))

   DOC    (* "The LispTree and PreorderSearchRecord objects illustrate" 
	   "how generators can be written. In defining a LispTree,"
	     "which can actually be of multiple types" 
	     "(atom or dotted pair)"
	     ", we define it as the more complex dotted-pair type and" 
       "take care of the simpler case in the PROPerty definitions.")  )

(PREORDERSEARCHRECORD

   (CONS (NODE LISPTREE)
	 (PREVIOUSNODES (LISTOF LISPTREE)))

   MSG    [(NEXT ((PROG (TMP)
			(IF TMP_NODE:LEFTSON THEN
			    (IF NODE:RIGHTSON THEN PREVIOUSNODES+_NODE)
			    NODE_TMP ELSE TMP-_PREVIOUSNODES 
			    NODE_TMP:RIGHTSON]

   DOC    (* "PreorderSearchRecord is defined to be a generator. Its" 
	     "data structure holds the current node and a stack of"
	     
       "previous nodes, and its NEXT message is defined as code to"
	     "step through the preorder search.")  )
]

(DEFINEQ

(PRINTLEAVES
  [GLAMBDA (:LISPTREE)

          (* PRINTLEAVES prints the leaves of the tree, using 
	  a PreorderSearchRecord as the generator for 
	  searching the tree.)


    (PROG (PSR)
          (PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE)))
          (WHILE NODE (IF NODE IS ATOMIC (PRINT NODE))
		 (SEND PSR NEXT])
)


[GLISPOBJECTS


(CIRCLE

   (LIST (START VECTOR)
	 (RADIUS REAL))

   PROP   [(PI (3.141593))
	   (DIAMETER (RADIUS*2))
	   (CIRCUMFERENCE (PI*DIAMETER))
	   (AREA (PI*RADIUS^2))
	   (SQUARESIDE ((SQRT AREA)))
	   (DISPLAYPROPS ((QUOTE (DIAMETER CIRCUMFERENCE AREA]

   MSG    ((GROW (AREA _+ 100))
	   (SHRINK (AREA_AREA / 2))
	   (STANDARD (AREA _ 100.0)))

   ADJ    ((BIG (AREA>100))
	   (SMALL (AREA<80)))  )

(DCIRCLE

   (LISTOBJECT (START VECTOR)
	       (DIAMETER REAL))

   PROP   ((RADIUS (DIAMETER / 2)))

   SUPERS (CIRCLE)

   DOC    (* "A DCIRCLE is implemented differently from a circle. The" 
	     "data structure is different, and DIAMETER is stored"
	     "instead of RADIUS. By defining RADIUS as a PROPerty, all" 
       "of the CIRCLE properties defined in terms of radius can be"
	     "inherited.")  )
]

(DEFINEQ

(INIT-CIRCLES
  (GLAMBDA NIL                                  (* Make some CIRCLE 
						objets for testing)

          (* Since DCIRCLE is an Object type, it can be used 
	  with interpreted messages, e.g., 
	  (send dc area) to get the area property, 
	  (send dc standard) to set the area to the standard 
	  value, (send dc diameter) to get the stored diameter
	  value.)


    (SETQ MYCIRCLE (A CIRCLE))
    (SETQ DC (A DCIRCLE WITH DIAMETER = 10.0))))

(GROWCIRCLE
  (GLAMBDA (C:CIRCLE)
    (C:AREA _+ 100)
    C))
)
(DEFINEQ

(SQRTB
  (GLAMBDA (X)                                  (* A simple version of 
						SQRT)
    (PROG (S)
          (S := X)
          (IF X < 0 THEN (ERROR)
		  ELSE
		  (WHILE (ABS S*S - X) > 1.0E-6 DO (S := (S + X / S)* .5)))
          (RETURN S))))

(SQUASH
  (GLAMBDA NIL

          (* Function SQUASH illustrates elimination of 
	  compile-time constants. Of course, nobody would 
	  write such a function directly.
	  However, such forms can arise when inherited 
	  properties are compiled. Conditional compilation 
	  occurs automatically when appropriate variables are 
	  defined to the GLISP compiler as compile-time 
	  constants because the post-optimization phase of the
	  compiler makes the unwanted code disappear.)


    (IF 1>3
	THEN 'AMAZING
      ELSEIF (SQRT 7.2)
	     <2
	THEN 'INCREDIBLE
      ELSEIF 2 + 2 = 4
	THEN 'OKAY
      ELSE 'JEEZ)))
)
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* The following object definitions describe a student records 
     database.)  ]



[GLISPOBJECTS


(STUDENT

   (ATOMOBJECT (NAME STRING)					       |
	       (SEX ATOM)					       |
	       (MAJOR ATOM)					       |
	       (GRADES (LISTOF INTEGER)))

   PROP   ((AVERAGE STUDENT-AVERAGE)
	   (GRADE-AVERAGE STUDENT-GRADE-AVERAGE)
	   (SHORTVALUE (NAME))
	   (DISPLAYPROPS (T)))

   ADJ    ((MALE (SEX='MALE))
	   (FEMALE (SEX='FEMALE))
	   (WINNING (AVERAGE>=95))
	   (LOSING (AVERAGE<60)))

   ISA    ((WINNER (self IS WINNING)))  )

(STUDENT-GROUP

   (LISTOF STUDENT)

   PROP   [(N-STUDENTS LENGTH)
	   (AVERAGE STUDENT-GROUP-AVERAGE)
	   (SHORTVALUE ((FOR X IN self COLLECT X:SHORTVALUE]  )

(CLASS

   (ATOMOBJECT (DEPARTMENT ATOM)				       |
	       (NUMBER INTEGER)					       |
	       (INSTRUCTOR STRING)				       |
	       (STUDENTS STUDENT-GROUP))

   PROP   ((N-STUDENTS (STUDENTS:N-STUDENTS))
	   (MEN ((THOSE STUDENTS WHO ARE MALE)))
	   (WOMEN ((THOSE STUDENTS WHO ARE FEMALE)))
	   (WINNERS ((THOSE STUDENTS WHO ARE WINNING)))
	   (LOSERS ((THOSE STUDENTS WHO ARE LOSING)))
	   (CLASS-AVERAGE (STUDENTS:AVERAGE)))  )
]

(DEFINEQ

(STUDENT-AVERAGE
  (GLAMBDA (S:STUDENT)
    (PROG ((SUM 0.0)
	   (N 0.0))
          (FOR G IN GRADES DO N _+
			      1.0 SUM _+ G)
          (RETURN SUM / N))))

(STUDENT-GRADE-AVERAGE
  [GLAMBDA (S:STUDENT)
    (PROG ((AV S:AVERAGE))
          (RETURN (IF AV >= 90.0
		      THEN 'A
		    ELSEIF AV >= 80.0
		      THEN 'B
		    ELSEIF AV >= 70.0
		      THEN 'C
		    ELSEIF AV >= 60.0
		      THEN 'D
		    ELSE 'F])

(STUDENT-GROUP-AVERAGE
  (GLAMBDA (SG:STUDENT-GROUP)
    (PROG ((SUM 0.0))
          (FOR S IN SG DO SUM _+ S:AVERAGE)
          (RETURN SUM / SG:N-STUDENTS))))

(TEST1
  (GLAMBDA (C:CLASS)                            (* Print name and grade 
						average for each 
						student)
    (FOR S IN C:STUDENTS (PRIN1 S:NAME)
	      (SPACES 1)
	      (PRINT S:GRADE-AVERAGE))))

(TEST1B
  (GLAMBDA (:CLASS)                             (* Another version of 
						the above function)
    (FOR EACH STUDENT (PRIN1 NAME)
	 (SPACES 1)
	 (PRINT GRADE-AVERAGE))))

(TEST2
  (GLAMBDA (C:CLASS)                            (* Print name and 
						average of the winners 
						in the class)
    (FOR S IN C:WINNERS (PRIN1 S:NAME)
	      (SPACES 1)
	      (PRINT S:AVERAGE))))

(TEST3
  (GLAMBDA (C:CLASS)                            (* The average of all 
						the male students' 
						grades)
    C:MEN:AVERAGE))

(TEST4
  (GLAMBDA (C:CLASS)                            (* The name and average 
						of the winning women)
    (FOR S IN C:WOMEN WHEN S IS WINNING (PRIN1 S:NAME)
			   (SPACES 1)
			   (PRINT S:AVERAGE))))

(TEST4B
  (GLAMBDA (C:CLASS)

          (* Another version of the above function.
	  The * operator in this case denotes the intersection
	  of the sets of women and winners.
	  The GLISP compiler optimizes the code so that these 
	  intermediate sets are not actually constructed.)


    (FOR S IN C:WOMEN*C:WINNERS (PRIN1 S:NAME)
	      (SPACES 1)
	      (PRINT S:AVERAGE))))

(EASY-PROFS
  (GLAMBDA (CLASSES:(LISTOF CLASS))             (* Make a list of the 
						easy professors.)
    (FOR EACH CLASS WITH CLASS-AVERAGE > 90.0 COLLECT (THE INSTRUCTOR)))
)

(EASY-PROFS-B
  (GLAMBDA (CLASSES:(LISTOF CLASS))             (* A more Pascal-like 
						version of EASY-PROFS.)
    (FOR C IN CLASSES WHEN C:CLASS-AVERAGE > 90.0 COLLECT C:INSTRUCTOR))
)

(INIT-CLASS
  [GLAMBDA NIL                                  (* Some test data for 
						testing the above 
						functions.)
    (SETQ CLASS1
      (A CLASS WITH INSTRUCTOR = "A. PROF" DEPARTMENT = 'CS NUMBER = 
	 102 STUDENTS =(LIST (A STUDENT WITH NAME = "JOHN DOE" SEX = 
				'MALE MAJOR = 'CS GRADES = '(99 98 97 
								93))
			     (A STUDENT WITH NAME = "FRED FAILURE" SEX 
				= 'MALE MAJOR = 'CS GRADES = '(52
				  54 43 27))
			     (A STUDENT WITH NAME = "MARY STAR" SEX = 
				'FEMALE MAJOR = 'CS GRADES = '(100
				  100 99 98))
			     (A STUDENT WITH NAME = "DORIS DUMMY" SEX = 
				'FEMALE MAJOR = 'CS GRADES = '(73
				  52 46 28))
			     (A STUDENT WITH NAME = "JANE AVERAGE" SEX 
				= 'FEMALE MAJOR = 'CS GRADES = '(75
				  82 87 78))
			     (A STUDENT WITH NAME = "LOIS LANE" SEX = 
				'FEMALE MAJOR = 'CS GRADES = '(98
				  95 97 96])
)
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* The following object definitions illustrate inheritance of 
     properties from multiple parent classes. The three "bottom" 
     classes Planet, Brick, and Bowling-Ball all inherit the same 
     definition of the property Density, although they are represented 
     in very different ways.)  ]



[GLISPOBJECTS


(PHYSICAL-OBJECT

   ANYTHING

   PROP   ((DENSITY (MASS / VOLUME)))  )

(ORDINARY-OBJECT

   ANYTHING

   PROP   ((MASS (WEIGHT / 9.88)))

   SUPERS (PHYSICAL-OBJECT)  )

(SPHERE

   ANYTHING

   PROP   ((VOLUME ((4.0 / 3.0)
		    * 3.141593 * RADIUS ^ 3)))  )

(PARALLELEPIPED

   ANYTHING

   PROP   ((VOLUME (LENGTH*WIDTH*HEIGHT)))  )

(PLANET

   (LISTOBJECT (MASS REAL)
	       (RADIUS REAL))

   SUPERS (PHYSICAL-OBJECT SPHERE)  )

(BRICK

   (OBJECT (LENGTH REAL)
	   (WIDTH REAL)
	   (HEIGHT REAL)
	   (WEIGHT REAL))

   SUPERS (ORDINARY-OBJECT PARALLELEPIPED)  )

(BOWLING-BALL

   (ATOMOBJECT (TYPE ATOM)
	       (WEIGHT REAL))

   PROP   [(RADIUS ((IF TYPE='ADULT THEN .1 ELSE .07]

   SUPERS (ORDINARY-OBJECT SPHERE)  )
]

[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Three test functions to demonstrate inheritance of the Density 
     property.)  ]

(DEFINEQ

(DPLANET
  (GLAMBDA (P:PLANET)
    DENSITY))

(DBRICK
  (GLAMBDA (B:BRICK)
    DENSITY))

(DBB
  (GLAMBDA (B:BOWLING-BALL)
    DENSITY))

(INIT-OBJECTS
  (GLAMBDA NIL                                  (* Some objects to test 
						the functions on.)

          (* Since the object types Planet, Brick, and 
	  Bowling-Ball are defined as Object types 
	  (i.e., they contain the Class name as part of their 
	  stored data), messages can be sent to them directly 
	  from the keyboard for interactive examination of the
	  objects. For example, the following messages could 
	  be used: (SEND EARTH DENSITY) 
	  (SEND BRICK1 WEIGHT: 25.0) (SEND BRICK1 MASS: 2.0) 
	  (SEND BB1 RADIUS) (SEND BB1 TYPE: 'CHILD))


    (SETQ EARTH (A PLANET WITH MASS = 5.98E24 RADIUS = 6.37E6))
    (SETQ BRICK1
      (A BRICK WITH WEIGHT = 20.0 WIDTH = .1 HEIGHT = .05 LENGTH = .2))
    (SETQ BB1 (A BOWLING-BALL WITH TYPE = 'ADULT WEIGHT = 60.0))))
)
(INIT-COMPANY)
(INIT-CIRCLES)
(INIT-CLASS)
(INIT-OBJECTS)
(GEVDEMO-INIT)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (5867 13587 (GIVE-RAISE 5877 . 6226) (CURRENTDATE 6228 . 6388) (TODAYS-DATE 6390 . 6621)
 (TOTAL-BUDGET 6623 . 6833) (INIT-COMPANY 6835 . 7838) (GEVDEMO-INIT 7840 . 13585)) (15657 17085 (
VECTORPLUS 15667 . 15819) (VECTORDIFF 15821 . 15973) (VECTORTIMES 15975 . 16111) (VECTORTIMESSCALAR 
16113 . 16211) (VECTORDOTPRODUCT 16213 . 16371) (VECTORQUOTIENTSCALAR 16373 . 16478) (VECTORMOVE 16480
 . 16620) (VECTOR-SHORTVALUE 16622 . 16797) (REGION-CONTAINS 16799 . 17083)) (17313 17632 (TVPLUS 
17323 . 17371) (TFVPLUS 17373 . 17424) (TVOFVPLUS 17426 . 17473) (TVMOVE 17475 . 17526) (TVTIMESV 
17528 . 17578) (TVTIMESN 17580 . 17630)) (18432 19935 (GRAPHICSOBJECTMOVE 18442 . 18620) (
MGO-ACCELERATE 18622 . 18733) (MGO-TEST 18735 . 19304) (TESTFN2 19306 . 19517) (DRAWRECT 19519 . 19933
)) (21023 21367 (PRINTLEAVES 21033 . 21365)) (22200 22732 (INIT-CIRCLES 22210 . 22667) (GROWCIRCLE 
22669 . 22730)) (22733 23612 (SQRTB 22743 . 22994) (SQUASH 22996 . 23610)) (24791 27954 (
STUDENT-AVERAGE 24801 . 24962) (STUDENT-GRADE-AVERAGE 24964 . 25221) (STUDENT-GROUP-AVERAGE 25223 . 
25383) (TEST1 25385 . 25595) (TEST1B 25597 . 25776) (TEST2 25778 . 25986) (TEST3 25988 . 26125) (TEST4
 26127 . 26333) (TEST4B 26335 . 26712) (EASY-PROFS 26714 . 26895) (EASY-PROFS-B 26897 . 27086) (
INIT-CLASS 27088 . 27952)) (29166 30109 (DPLANET 29176 . 29220) (DBRICK 29222 . 29264) (DBB 29266 . 
29312) (INIT-OBJECTS 29314 . 30107)))))
STOP
OP
TOP