reduce-historical/psl-1983/glisp/gltest

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