perm filename CYCDRA.PRT[4,LMM] blob sn#037519 filedate 1973-04-23 generic text, type T, neo UTF8
  (DEFPROP CYCDRAFNS
           (CYCDRAFNS (SPECIAL XBOT XSCL YBOT YSCL REALWIDTH REALHEIGHT 
                               CTAB PATS CURPAT PATSELECT TITLE LINE 
                               LABELL NLN NMX LLN FIXE FACENUM 
                               REALBOTTOM REALEFT EPSILON)
                      PATS PATSELECT (ARRAY TMP T 20.0)
                      (ARRAY CONN T 20.0)
                      (ARRAY NODE T 40.0)
                      PUSH ! POP STORENODEY STORENODE NODEY DRAWS 
                      PRINRAD PRINENTRY NUMNODES LAYOUT ANALIN PRINRAD1 
                      PRINCTAB PRINRADOFF)
           VALUE)
  (SPECIAL XBOT XSCL YBOT YSCL REALWIDTH REALHEIGHT CTAB PATS CURPAT 
           PATSELECT TITLE LINE LABELL NLN NMX LLN FIXE FACENUM 
           REALBOTTOM REALEFT EPSILON)
  (DEFPROP PATS
           (PATS (TRAP ((1.0 4.0 3.0 2.0)
                        (2.0 4.0 3.0 1.0)
                        (3.0 4.0 2.0 1.0)
                        (4.0 3.0 2.0 1.0))
                       (5.0 (4.0 3.0 3.0 3.0 3.0)
                            ((1.0 4.0 (1.0 2.0 3.0 4.0))
                             (2.0 3.0 (1.0 3.0 4.0))
                             (3.0 3.0 (1.0 2.0 4.0))
                             (4.0 3.0 (1.0 2.0 3.0))
                             (5.0 3.0 (2.0 3.0 4.0))))
                       ((4.0 5.0 3.0 2.0 1.0)
                        (3.0 5.0 4.0 2.0 1.0)
                        (2.0 5.0 4.0 3.0 1.0)
                        (1.0 4.0 3.0 2.0 1.0))
                       (((3.0 . 4.0)
                         1.0)
                        ((2.0 . 4.0)
                         1.0)
                        ((2.0 . 3.0)
                         1.0)
                        ((1.0 . 4.0)
                         1.0)
                        ((1.0 . 3.0)
                         1.0)
                        ((1.0 . 2.0)
                         1.0))
                       ((1.0 0.0 0.0)
                        (2.0 1.0 2.0)
                        (3.0 2.0 0.0)
                        (4.0 1.0 1.0)))
                 (HEX ((1.0 2.0 6.0)
                       (2.0 3.0 1.0)
                       (3.0 4.0 2.0)
                       (4.0 5.0 3.0)
                       (5.0 6.0 4.0)
                       (6.0 5.0 1.0))
                      (1.0 (6.0)
                           ((1.0 6.0 (1.0 6.0 5.0 4.0 3.0 2.0))))
                      ((6.0 1.0)
                       (5.0 1.0)
                       (4.0 1.0)
                       (3.0 1.0)
                       (2.0 1.0)
                       (1.0 1.0))
                      (((5.0 . 6.0)
                        1.0)
                       ((4.0 . 5.0)
                        1.0)
                       ((3.0 . 4.0)
                        1.0)
                       ((2.0 . 3.0)
                        1.0)
                       ((1.0 . 2.0)
                        1.0)
                       ((1.0 . 6.0)
                        1.0))
                      ((1.0 1.0 3.0)
                       (2.0 2.0 2.0)
                       (3.0 2.0 1.0)
                       (4.0 1.0 0.0)
                       (5.0 0.0 1.0)
                       (6.0 0.0 2.0)))
                 (PENT ((1.0 5.0 2.0)
                        (2.0 3.0 1.0)
                        (3.0 4.0 2.0)
                        (4.0 5.0 3.0)
                        (5.0 1.0 4.0))
                       (1.0 (5.0)
                            ((1.0 5.0 (1.0 2.0 3.0 4.0 5.0))))
                       ((5.0 1.0)
                        (4.0 1.0)
                        (3.0 1.0)
                        (2.0 1.0)
                        (1.0 1.0))
                       (((4.0 . 5.0)
                         1.0)
                        ((3.0 . 4.0)
                         1.0)
                        ((2.0 . 3.0)
                         1.0)
                        ((1.0 . 5.0)
                         1.0)
                        ((1.0 . 2.0)
                         1.0))
                       ((1.0 0.0 1.0)
                        (2.0 1.0 2.0)
                        (3.0 2.0 1.0)
                        (4.0 2.0 0.0)
                        (5.0 0.0 0.0)))
                 (OCT ((1.0 2.0 8.0)
                       (2.0 3.0 1.0)
                       (3.0 4.0 2.0)
                       (4.0 5.0 3.0)
                       (5.0 6.0 4.0)
                       (6.0 7.0 5.0)
                       (7.0 8.0 6.0)
                       (8.0 1.0 7.0))
                      (1.0 (8.0)
                           ((1.0 8.0
                                 (1.0 8.0 7.0 6.0 5.0 4.0 3.0 2.0))))
                      ((8.0 1.0)
                       (7.0 1.0)
                       (6.0 1.0)
                       (5.0 1.0)
                       (4.0 1.0)
                       (3.0 1.0)
                       (2.0 1.0)
                       (1.0 1.0))
                      (((7.0 . 8.0)
                        1.0)
                       ((6.0 . 7.0)
                        1.0)
                       ((5.0 . 6.0)
                        1.0)
                       ((4.0 . 5.0)
                        1.0)
                       ((3.0 . 4.0)
                        1.0)
                       ((2.0 . 3.0)
                        1.0)
                       ((1.0 . 2.0)
                        1.0)
                       ((1.0 . 8.0)
                        1.0))
                      ((1.0 0.0 2.0)
                       (2.0 1.0 3.0)
                       (3.0 2.0 3.0)
                       (4.0 3.0 2.0)
                       (5.0 3.0 1.0)
                       (6.0 2.0 0.0)
                       (7.0 1.0 0.0)
                       (8.0 0.0 1.0))))
           VALUE)
  (DEFPROP PATSELECT (PATSELECT (4.0 15.0 15.0)
                                (3.0 16.0 17.0)
                                (1.0 17.0 15.0)
                                (2.0 16.0 16.0))
           VALUE)
  (ARRAY TMP T 20.0)
  (ARRAY CONN T 20.0)
  (ARRAY NODE T 40.0)
  (DEFPROP PUSH (LAMBDA (X)
                        (LIST (QUOTE SETQ)
                              (QUOTE STACK)
                              (APPEND (QUOTE (! CONS))
                                      (CDR X)
                                      (QUOTE (STACK)))))
           MACRO)
  (DEFPROP ! (LAMBDA
             (L)
             ((LABEL FOO (LAMBDA
                       (LL)
                       (COND ((NULL (CDR LL))
                              NIL)
                             ((NULL (CDDR LL))
                              (CADR LL))
                             ((NULL (CDDDR LL))
                              LL)
                             (T (LIST (CAR LL)
                                      (CADR LL)
                                      (FOO (CONS (CAR LL)
                                                 (CDDR LL))))))))
              (CDR L)))
           MACRO)
  (DEFPROP POP (LAMBDA (X)
                       (LIST (QUOTE PROG1)
                             (LIST (QUOTE SETQ)
                                   (CADR X)
                                   (QUOTE (CAR STACK)))
                             (QUOTE (SETQ STACK (CDR STACK)))))
           MACRO)
  (DEFPROP STORENODEY (LAMBDA (EXPR)
                              (LIST (QUOTE STORE)
                                    (LIST (QUOTE NODE)
                                          (LIST (QUOTE PLUS)
                                                20.0
                                                (CADR EXPR)))
                                    (CADDR EXPR)))
           MACRO)
  (DEFPROP STORENODE (LAMBDA (L)
                             (LIST (QUOTE STORE)
                                   (LIST (QUOTE NODE)
                                         (CADR L))
                                   (CADDR L)))
           MACRO)
  (DEFPROP NODEY (LAMBDA (L)
                         (LIST (QUOTE NODE)
                               (LIST (QUOTE PLUS)
                                     20.0
                                     (CADR L))))
           MACRO)
  (DEFPROP
    DRAWS
    (LAMBDA
      (STRUC ID)
      (PROG
        (CTAB)
        (SETQ CTAB (CTABLE STRUC))
        (LAYOUT
          (CONS (COND (ID ID)
                      (T (UGRAPH STRUC)))
                (FOR NEW CTE IN CTAB LIST
                     (CONS (NODENUM CTE)
                           (CONS (ATOMTYPE (MARKERS CTE))
                                 (FOR NEW X IN (NBRS CTE)
                                      WHEN
                                      (NUMBERP X)
                                      LIST X))))))))
    EXPR)
  (DEFPROP PRINRAD (LAMBDA (L)
                           (PROG (CTAB)
                                 (PRINRAD1 NIL
                                           (FOR NEW I := ((NUMNODES
                                                   L)
                                                 1.0 -1.0)
                                                XLIST I)
                                           L)
                                 (LAYOUT (CONS TITLE CTAB))))
           EXPR)
  (DEFPROP PRINENTRY (LAMBDA (N AT CON)
                             (SETQ CTAB (CONS (CONS N (CONS AT CON))
                                              CTAB)))
           EXPR)
  (DEFPROP
    NUMNODES
    (LAMBDA
      (RAD)
      (FOR NEW R IN (ATTACHEDRADS RAD)
           PLUS FIRST (IF (NULL (CENTER RAD))
                          THEN 0.0 ELSEIF (ATOM (CENTER RAD))
                          THEN 1.0 ELSEIF
                          (NOT (STRUCTURE? (RADSTRUC (CENTER RAD))))
                          THEN 1.0 ELSE
                          (LENGTH (NODES (RADSTRUC (CENTER RAD)))))
           (TIMES (CDR R)
                  (NUMNODES (CAR R)))))
    EXPR)
  (DEFPROP LAYOUT (LAMBDA (X)
                          (PROG NIL (ANALIN X)
                                (PATMATCH)
                                (SORTLN)
                                (FINDNDS 1.0 NIL)
                                (RETURN (OUTNDS))))
           EXPR)
  (DEFPROP
    ANALIN
    (LAMBDA
      (X)
      (PROG (X1 X2 X3 X4)
            (FOR NEW I := (1.0 19.0)
                 DO
                 (STORE (CONN I)
                        NIL))
            (SETQ TITLE (CAR X))
            (SETQ LINE NIL)
            (SETQ LABELL NIL)
            (SETQ NLN (LENGTH (CDR X)))
            (SETQ NMX 0.0)
            (FOR X1 IN (CDR X)
                 AS NMX IS (MAX (CAR X1)
                                NMX)
                 AS X2 IS (CAR X1)
                 AS LABELL IS (CONS (CONS X2 (CADR X1))
                                    LABELL)
                 FOR X3 IN (CDDR X1)
                 DO
                 (SETQ X4 (ASSOC2 (CONS X2 X3)
                                  LINE))
                 (COND ((NULL X4)
                        (COND ((ASSOC2 (CONS X3 X2)
                                       LINE)
                               NIL)
                              (T (SETQ LINE (CONS (LIST (CONS X2 X3)
                                                        1.0)
                                                  LINE)))))
                       (T (RPLACA (CDR X4)
                                  (ADD1 (CADR X4)))))
                 (COND ((MEMBER X3 (CONN X2))
                        NIL)
                       (T (STORE (CONN X2)
                                 (CONS X3 (CONN X2))))))
            (SETQ LLN (LENGTH LINE))
            (RETURN LINE)))
    EXPR)
  (DEFPROP
    PRINRAD1
    (LAMBDA
      (EFF AA RAD)
      (PROG
        (CENT ATTACHED J X TTABLE)
        (SETQ CENT (CENTER RAD))
        (SETQ ATTACHED (CLEXPAND (ATTACHEDRADS RAD)))
        (RETURN
          (IF (NOT CENT)
              THEN
              (PRINRAD1 (CADR AA)
                        (CONS (CAR AA)
                              (PRINRAD1 (CAR AA)
                                        (CDR AA)
                                        (CAR ATTACHED)))
                        (CADR ATTACHED))
              ELSEIF
              (OR (ATOM CENT)
                  (NOT (EQ (ID (RADSTRUC CENT))
                           (QUOTE STRUC))))
              THEN
              (SETQ X (CDR AA))
              (FOR NEW R IN ATTACHED DO (SETQ J (CONS (CAR X)
                                                      J))
                   (SETQ X (PRINRAD1 (CAR AA)
                                     X R)))
              (PRINENTRY (CAR AA)
                         CENT
                         (IF EFF THEN (CONS EFF J)
                             ELSE J))
              X ELSE (SETQ X (IF (NOT EFF)
                                 THEN AA ELSE
                                 (SETQ TTABLE
                                       (LIST (LIST (AFFLINK CENT)
                                                   (CAR AA)
                                                   EFF)))
                                 (CDR AA)))
              (FOR NEW N IN (NODES (RADSTRUC CENT))
                   WHEN
                   (NOT (EQUAL N (AFFLINK CENT)))
                   DO
                   (SETQ TTABLE (CONS (LIST N (CAR X))
                                      TTABLE))
                   (SETQ X (CDR X)))
              (FOR NEW NLIST IN (CUFFLINKS CENT)
                   FOR NEW C IN NLIST AS NEW CT IS
                   (LMASSOC C TTABLE NIL)
                   DO
                   (NCONC CT (LIST (CAR X)))
                   (SETQ X (PRINRAD1 (CAR CT)
                                     X
                                     (CAR ATTACHED)))
                   (SETQ ATTACHED (CDR ATTACHED)))
              (PRINCTAB (CTABLE (RADSTRUC CENT))
                        TTABLE)
              X))))
    EXPR)
  (DEFPROP
    PRINCTAB
    (LAMBDA
      (CTAB TTABLE)
      (FOR NEW CT IN CTAB AS NEW CPRIME IS (LMASSOC (NODENUM CT)
                                                    TTABLE NIL)
           DO
           (PRINENTRY (CAR CPRIME)
                      (ATOMTYPE MARKERS CT)
                      (APPEND (CDR CPRIME)
                              (FOR NEW Y IN (NBRS CT)
                                   IF
                                   (NOT (EQ Y (QUOTE FV)))
                                   XLIST
                                   (CAR (LMASSOC Y TTABLE NIL)))))))
    EXPR)
  (DEFPROP PRINRADOFF (LAMBDA (L)
                              (PROG NIL (QUOTE (TTAB 1.0))
                                    (PRIN1 (QUOTE STRUCTURE=))
                                    (PRINT L)
                                    (FOR NEW X IN XLATETABLE DO
                                         (PRIN1 (QUOTE X))
                                         (PRIN1 (CAR X))
                                         (PRIN1 (QUOTE =))
                                         (PRINT (CDR X)))
                                    (QUOTE (TTAB 1.0))
                                    (PRINT (QUOTE END*))
                                    (QUOTE (OTLL 133.0))
                                    (SETQ XLATETABLE NIL)))
           EXPR)
STOP