perm filename CYCDRI.LSP[3,LMM] blob sn#037478 filedate 1973-04-21 generic text, type T, neo UTF8

(DEFPROP CYCDRIFNS
 (CYCDRIFNS SLOPE YINTCP CONCT CLCINTA GEQ OUTNDS SETSCALE POSLABEL POS SCALX SCALE SCALY LINE XDRAW LINE2)
VALUE)

(DEFPROP SLOPE
 (LAMBDA (X1 X2 Y1 Y2) (CONS (DIFFERENCE X1 X2) (DIFFERENCE Y1 Y2)))
EXPR)

(DEFPROP YINTCP
 (LAMBDA (X1 X2 Y1 Y2) (CONS (DIFFERENCE (TIMES Y1 X2) (TIMES X1 Y2)) (DIFFERENCE X2 X1)))
EXPR)

(DEFPROP CONCT
 (LAMBDA (X Y) (OR (EQ (CAAR Y) (CAAR X)) (EQ (CAAR Y) (CDAR X)) (EQ (CDAR Y) (CAAR X)) (EQ (CDAR Y) (CDAR X))))
EXPR)

(DEFPROP CLCINTA
 (LAMBDA(X X1 X2)
  (NOT (MINUSP (TIMES (DIFFERENCE (CAR X) (TIMES X1 (CDR X))) (DIFFERENCE (CAR X) (TIMES X2 (CDR X)))))))
EXPR)

(DEFPROP GEQ
 (LAMBDA (X Y) (NOT (LESSP X Y)))
EXPR)

(DEFPROP OUTNDS
 (LAMBDA NIL
  (PROG	(I)
	(SETSCALE 10. 20. 10. 20.)
	(INITDRAW)
	(POSLABEL 13. 13. TITLE)
	(FOR I
	     :=
	     (1. NMX)
	     WHEN
	     (NOT (ZEROP (NODE I)))
	     AS
	     NEW
	     LL
	     IS
	     (CDR (ASSOC2 I LABELL))
	     DO
	     (POSLABEL (NODE I) (NODE (PLUS I 20.)) (COND (LL LL) (T I))))
	(FOR NEW
	     LIN
	     IN
	     (CAR (LAST STACK))
	     DO
	     (LINE2 (CADR LIN)
		    (NODE (CAAR LIN))
		    (NODE (PLUS (CAAR LIN) 20.))
		    (NODE (CDAR LIN))
		    (NODE (PLUS (CDAR LIN) 20.))))
	(RETURN (ENDDRAW))))
EXPR)

(DEFPROP SETSCALE
 (LAMBDA(XMN XMX YMN YMX)
  (PROG	NIL
	(SETQ XBOT (MINUS XMN))
	(SETQ XSCL (QUOTIENT REALWIDTH (PLUS 1. (DIFFERENCE XMX XMN))))
	(SETQ YBOT (MINUS YMN))
	(SETQ YSCL (QUOTIENT REALHEIGHT (PLUS 1. (DIFFERENCE YMX YMN))))))
EXPR)

(DEFPROP POSLABEL
 (LAMBDA (X Y MS) (PROG2 (POS X Y) (LABELL MS)))
EXPR)

(DEFPROP POS
 (LAMBDA (X Y) (AIVECT (SCALX X) (SCALY Y)))
EXPR)

(DEFPROP SCALX
 (LAMBDA (X) (SCALE X XBOT XSCL REALEFT))
EXPR)

(DEFPROP SCALE
 (LAMBDA (X XMN XMP START) (PLUS START (FIX (PLUS (TIMES XMP (PLUS X XMN)) 0.5))))
EXPR)

(DEFPROP SCALY
 (LAMBDA (Y) (SCALE Y YBOT YSCL REALBOTTOM))
EXPR)

(DEFPROP LINE
 (LAMBDA (X1 Y1 X2 Y2) (PROG2 (POS X1 Y1) (XDRAW X2 Y2)))
EXPR)

(DEFPROP XDRAW
 (LAMBDA (X Y) (AVECT (SCALX X) (SCALY Y)))
EXPR)

(DEFPROP LINE2
 (LAMBDA(MULT X1 Y1 X2 Y2)
  (PROG2 (LINE X1 Y1 X2 Y2)
	 (COND ((NOT (GREATERP MULT 1.)) NIL)
	       (T
		(PROG (DELTX DELTY DX DENOM DY)
		      (SETQ DELTX (DIFFERENCE X1 X2))
		      (SETQ DELTY (DIFFERENCE Y2 Y1))
		      (SETQ DENOM (SQRT (PLUS (TIMES DELTX DELTX) (TIMES DELTY DELTY))))
		      (SETQ DX (TIMES EPSILON (QUOTIENT DELTY DENOM)))
		      (SETQ DY (TIMES EPSILON (QUOTIENT DELTX DENOM)))
		      (FOR NEW
			   I
			   :=
			   (2. MULT)
			   DO
			   (LINE (SETQ X1 (PLUS X1 DX))
				 (SETQ Y1 (PLUS Y1 DY))
				 (SETQ X2 (PLUS X2 DX))
				 (SETQ Y2 (PLUS Y2 DY)))))))))
EXPR)