perm filename CYCDRH.LSP[3,LMM] blob sn#037477 filedate 1973-04-22 generic text, type T, neo UTF8

(DEFPROP CYCDRHFNS
 (CYCDRHFNS (SPECIAL STACK LINE RA PATSELECT) FINDNDS SETND FINDNDS1 PUSH3 STKNDS)
VALUE)

(SPECIAL STACK LINE RA PATSELECT)

(DEFPROP FINDNDS
 (LAMBDA(RA RI)
  (PROG	(X1)
	(COND (PATSELECT (SETQ RI T)))
   F	(FOR NEW I := (1. NMX) DO (SETND I (QUOTE (0. . 0.))))
	(COND ((SETQ X1 (ASSOC2 (CAAAR LINE) PATSELECT)) (SETND (CAR X1) (CONS (CADR X1) (CADDR X1))))
	      (T (SETND (CAAAR LINE) (QUOTE (15. . 15.)))))
	(SETQ STACK (LIST 0. LINE LINE))
	(COND ((FINDNDS1 RA RI T) (RETURN NIL)))
	(COND (PATSELECT (SETQ RI (SETQ PATSELECT NIL)) (SETQ RA 1.))
	      ((LESSP 3. (SETQ RA (ADD1 RA))) (SETQ RI T)))
	(GO F)))
EXPR)

(DEFPROP SETND
 (LAMBDA (X Y) (PROG NIL (STORE (NODE X) (CAR Y)) (STORE (NODE (PLUS X 20.)) (CDR Y)) (RETURN Y)))
EXPR)

(DEFPROP FINDNDS1
 (LAMBDA(RA RI X3)
  (PROG	(X1 X2 USED)
   C	(COND ((ZEROP (NODE (SETQ X2 (CDAR (SETQ X1 (CAR LINE)))))) (COND (X3 (STKNDS X2 USED))))
	      ((RTLIN RI X1 USED) (PUSH3 USED LINE NIL) (GO NXT)))
   A	(COND ((ATOM (POP X3)) (GO D)))
	(SETND (CADR X3) (CAR X3))
	(COND ((RTLIN RI X1 USED) (PUSH USED) (PUSH LINE) (PUSH NIL))
	      (T (SETND (CADR X3) (QUOTE (0. . 0.))) (GO A)))
   NXT	(SETQ USED (CONS X1 USED))
	(SETQ X3 T)
	(COND ((SETQ LINE (CDR LINE)) (GO C)) (T (RETURN T)))
   D	(POP LINE)
	(POP USED)
	(COND ((NULL STACK) (RETURN NIL)) (X3 (SETND X3 (QUOTE (0. . 0.)))))
	(COND ((ATOM (CAR STACK)) (POP X3) (GO D)))
	(STORE (NODE (CADAR STACK)) 0.)
	(SETQ X3 NIL)
	(GO C)))
EXPR)

(DEFPROP PUSH3
 (LAMBDA(USED UNUSED NODE)
  (SETQ	STACK
	(CONS NODE
	      (COND (USED (CONS (CONS (CAR USED) UNUSED) (CONS (CDR USED) STACK)))
		    (T (CONS (CONS NIL UNUSED) (CONS NIL STACK)))))))
EXPR)

(DEFPROP STKNDS
 (LAMBDA(X L1)
  (PROG	(Y X1 XMN XMX YMN YMX N1 N2)
	(PUSH3 L1 LINE X)
	(COND
	 ((AND PATSELECT (SETQ X1 (ASSOC2 X PATSELECT)))
	  (PUSH (LIST (CONS (CADR X1) (CADDR X1)) X))
	  (RETURN T)))
   A	(SETQ XMN 0.)
	(SETQ XMX 100.)
	(SETQ YMN 0.)
	(SETQ YMX 100.)
	(COND ((LESSP (LENGTH STACK) 6.) (PROG2 (SETQ XMN 16.) (SETQ YMN 15.))))
	(FOR X1
	     IN
	     (CONN X)
	     AS
	     N1
	     IS
	     (NODE X1)
	     IF
	     (NOT (ZEROP N1))
	     AS
	     N2
	     IS
	     (NODE (PLUS X1 20.))
	     DO
	     (SETQ XMN (MAX XMN (DIFFERENCE N1 RA)))
	     (SETQ XMX (MIN XMX (PLUS N1 RA)))
	     (SETQ YMN (MAX YMN (DIFFERENCE N2 RA)))
	     (SETQ YMX (MIN YMX (PLUS N2 RA))))
	(COND ((OR (GREATERP XMN XMX) (GREATERP YMN YMX)) (RETURN NIL)))
	(SETQ Y (FOR NEW I := (1. NMX) LIST (CONS (NODE I) (NODE (PLUS I 20.)))))
	(SETQ X1 NIL)
	(FOR N1
	     :=
	     (XMN XMX)
	     FOR
	     N2
	     :=
	     (YMN YMX)
	     WHEN
	     (NOT (MEMBER (CONS N1 N2) Y))
	     DO
	     (SETQ X1 T)
	     (PUSH (LIST (CONS N1 N2) X)))
	(COND ((NULL X1) (RETURN NIL)))
	(RETURN T)))
EXPR)