% GLTEST.PSL.2 22 OCTOBER 82
% GLISP TEST FUNCTIONS, PSL VERSION. GSN 22 OCTOBER 82
(DE GIVE-RAISE
(:COMPANY)
(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) ))
(DE CURRENTDATE ()
(A DATE WITH YEAR = 1981 !, MONTH = 11 !, DAY = 30))
(PUTPROP 'CURRENTDATE 'GLRESULTTYPE 'DATE)
(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)))
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)
(YEAR INTEGER))
PROP ((MONTHNAME ((NTH
' (JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER
OCTOBER NOVEMBER DECEMBER)
MONTH)))
(PRETTYFORM ((LIST DAY MONTHNAME YEAR)))
(SHORTYEAR (YEAR - 1900))) )
(COMPANY
(ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE))
(EMPLOYEES (LISTOF EMPLOYEE) )))
PROP ((ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN)))) )
)
(PUTPROP 'COMPANY1 'PRESIDENT
'("OSCAR THE GROUCH" (3 15 1907) 88.0 PRESIDENT NIL) )
(PUTPROP 'COMPANY1 'EMPLOYEES
'(("COOKIE MONSTER" (7 21 1947) 12.5 ELECTRICIAN NIL)
("BETTY LOU" (5 14 1980) 9.0 ELECTRICIAN NIL)
("GROVER" (6 13 1978) 3.0 ELECTRICIAN T)) )
(GLISPOBJECTS
(VECTOR
(LIST (X INTEGER)
(Y INTEGER))
PROP ((MAGNITUDE ((SQRT X^2 + Y^2))))
ADJ ((ZERO (X IS ZERO AND Y IS ZERO))
(NORMALIZED (MAGNITUDE = 1.0)))
MSG ((+ VECTORPLUS OPEN T)
(- VECTORDIFF OPEN T)
(* VECTORTIMES OPEN T)
(/ VECTORQUOTIENT OPEN T)
(_+ VECTORMOVE OPEN T)
(PRIN1 ((PRIN1 "(")
(PRIN1 X)
(PRIN1 ",")
(PRIN1 Y)
(PRIN1 ")")))
(PRINT ((_ SELF PRIN1)
(TERPRI))) ) )
(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 (GET SHAPE 'DRAWFN)
(LIST SELF
(QUOTE PAINT)))))
(ERASE ((APPLY (GET SHAPE 'DRAWFN)
(LIST SELF
(QUOTE ERASE)))))
(MOVE GRAPHICSOBJECTMOVE OPEN T)) )
(MOVINGGRAPHICSOBJECT
(LIST (TRANSPARENT GRAPHICSOBJECT)
(VELOCITY VECTOR))
MSG ((ACCELERATE MGO-ACCELERATE OPEN T)
(STEP ((_ SELF MOVE VELOCITY)))) )
)
(DE VECTORPLUS
(V1!,V2:VECTOR)
(A VECTOR WITH X = V1:X + V2:X !, Y = V1:Y + V2:Y))
(DE VECTORDIFF
(V1!,V2:VECTOR)
(A VECTOR WITH X = V1:X - V2:X !, Y = V1:Y - V2:Y))
(DE VECTORTIMES
(V:VECTOR N:NUMBER)
(A VECTOR WITH X = X*N !, Y = Y*N))
(DE VECTORQUOTIENT
(V:VECTOR N:NUMBER)
(A VECTOR WITH X = X/N !, Y = Y/N))
(DE VECTORMOVE
(V!,DELTA:VECTOR)
(V:X _+
DELTA:X)
(V:Y _+
DELTA:Y))
(DE GRAPHICSOBJECTMOVE
(SELF:GRAPHICSOBJECT DELTA:VECTOR)
(_ SELF ERASE)
(START _+
DELTA)
(_ SELF DRAW))
(DE MGO-ACCELERATE
(SELF: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR)
VELOCITY _+
ACCELERATION)
(DE TESTFN1 ()
(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 (_ MGO STEP))
(_(THE START OF MGO)
PRINT)))
(DE TESTFN2
(:GRAPHICSOBJECT)
(LIST SHAPE
START
SIZE
LEFT
BOTTOM
RIGHT
TOP
WIDTH
HEIGHT
CENTER
AREA
))
(DE DRAWRECT
(SELF:GRAPHICSOBJECT DSPOP:ATOM)
(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))) )
(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))))) )
)
(DE TP
(:LISPTREE)
(PROG (PSR)
(PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE)))
(WHILE NODE (IF NODE IS ATOMIC (PRINT NODE))
(_ PSR NEXT))))
(GLISPOBJECTS
(ARITHMETICOPERATOR
(SELF ATOM)
PROP ((PRECEDENCE OPERATORPRECEDENCEFN RESULT INTEGER)
(PRINTFORM ((GET SELF (QUOTE PRINTFORM))
OR SELF)))
MSG ((PRIN1 ((PRIN1 THE PRINTFORM)))) )
(INTEGERMOD7
(SELF INTEGER)
PROP ((MODULUS (7))
(INVERSE ((IF SELF IS ZERO THEN 0 ELSE (MODULUS - SELF)))))
ADJ ((EVEN ((ZEROP (LOGAND SELF 1))))
(ODD (NOT EVEN)))
ISA ((PRIME PRIMETESTFN))
MSG ((+ IMOD7PLUS OPEN T RESULT INTEGERMOD7)
(_ IMOD7STORE OPEN T RESULT INTEGERMOD7)) )
)
(DE IMOD7STORE
(LHS:INTEGERMOD7 RHS:INTEGER)
(LHS:SELF __(IREMAINDER RHS MODULUS)))
(DE IMOD7PLUS
(X!,Y:INTEGERMOD7)
(IREMAINDER (X:SELF + Y:SELF)
X:MODULUS))
(DE SA
(:ARITHMETICOPERATOR)
(IF PRECEDENCE>5 (_ (THE ARITHMETICOPERATOR)
PRIN1)))
(DE SB
(X:INTEGERMOD7)
(PROG (Y)
(LIST MODULUS INVERSE)
(IF X IS ODD OR X IS EVEN OR X IS A PRIME THEN (Y _ 5)
(X _ 12)
(X _+5))))
(GLISPOBJECTS
(CIRCLE (LIST (START VECTOR) (RADIUS REAL))
PROP ((PI (3.1415926))
(DIAMETER (RADIUS*2))
(CIRCUMFERENCE (PI*DIAMETER))
(AREA (PI*RADIUS^2)) ) ))
% EXAMPLE OF ASSIGNMENT TO COMPUTED PROPERTY
(DE GROWCIRCLE (C:CIRCLE)
(C:AREA_+100)
(PRINT RADIUS) )
(SETQ MYCIRCLE '((0 0) 0.0))
% EXAMPLE OF ELIMINATION OF COMPILE-TIME CONSTANTS
(DE SQUASH ()
(IF 1>3 THEN 'AMAZING
ELSEIF 6<2 THEN 'INCREDIBLE
ELSEIF 2 + 2 = 4 THEN 'OKAY
ELSE 'JEEZ))