(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