perm filename CYCOMB.PRT[4,LMM] blob sn#037533 filedate 1973-04-23 generic text, type T, neo UTF8
  (DEFPROP CYCOMBFNS
           (CYCOMBFNS MOLECULES SUPERATOMPARTITIONS MAXUNSATL 
                      SUPERATOMS COMPUTEFV CLBYVALENCE RINGS 
                      FVPARTITIONS RINGSKELETONS NOFV-RINGS DAISIES 
                      NOLOOPEDRINGS ROWS BIVALENTPARTITIONS 
                      FREEVALENCESIZE NODES COLLECTFV TRIMZEROS CATALOG 
                      STRUCWITH2NODES CATALOG3 DAISY SINGLERING 
                      BIVCHAIN CONNECT COPYSTRUC DISCONNECT FINDCTE 
                      FIRSTOFNODES LASTOFNODES LISTBYVALENCE PUTFVN 
                      PUTFVS PUTNEWNODE PUTNEWNODEINCT NODEVALENCE 
                      VALENCETYPE SINGLERINGS INSERTMARKERS DELETE)
           VALUE)
  (DEFPROP MOLECULES
           (LAMBDA
             (CL U)
             (IF (ZEROP U)
                 THEN
                 (GENMOL CL)
                 ELSE
                 (FOR NEW SAP IN (SUPERATOMPARTITIONS CL U)
                      FOR NEW S IN (SUPERATOMS (SUPERATOMPARTS SAP))
                      NCONC FIRST NIL (GENMOL (APPEND (CLCREATE S)
                                                      (REMAININGATOMS
                                                        SAP))))))
           EXPR)
  (DEFPROP
    SUPERATOMPARTITIONS
    (LAMBDA
      (CL U)
      (PROG
        (CL1)
        (SETQ CL1 (FOR NEW PR IN CL WHEN (EQUAL (VALENCE (CAR PR))
                                                1.0)
                       LIST PR))
        (SETQ CL (CLDIFF CL CL1))
        (RETURN
          (FOR NEW PARTSIZE := (2.0 (CLCOUNT CL))
               FOR NEW VHAT IN (CLPARTS CL PARTSIZE)
               AS NEW REMATS IS (APPEND CL1 (CLDIFF CL VHAT))
               FOR NEW #PARTS := (1.0 (QUOTIENT PARTSIZE 2.0))
               FOR NEW PARTITION IN (CLPARTITIONSN VHAT #PARTS 2.0 
                                                   9999.0)
               AS NEW VI IS (CLCREATE PARTITION)
               AS NEW MXUI IS (MAXUNSATL VI)
               WHEN MXUI FOR NEW UI IN (NUMPARTITIONS*
                 U 1.0 MXUI (MAPCAR (QUOTE CDR)
                                    VI))
               XLIST
               (SUPERATOMPARTITION
                 REMAININGATOMS = REMATS SUPERATOMPARTS =
                 (PROG (CVI CVN M VI2 CUI VI3)
                       (SETQ VI3 VI)
                       VILOOP
                       (IF (NULL VI3)
                           THEN
                           (RETURN VI2))
                       (SETQ CVI (CAAR VI3))
                       (SETQ CVN (CDAR VI3))
                       (SETQ VI3 (CDR VI3))
                       LOOPM
                       (SETQ M 0.0)
                       LOOPCVN
                       (SETQ M (ADD1 M))
                       (SETQ CVN (SUB1 CVN))
                       (SETQ CUI (CAR UI))
                       (SETQ UI (CDR UI))
                       (IF (AND (NOT (ZEROP CVN))
                                (EQUAL CUI (CAR UI)))
                           THEN
                           (GO LOOPCVN))
                       (SETQ VI2 (CONS (CONS (CONS CUI CVI)
                                             M)
                                       VI2))
                       (IF (ZEROP CVN)
                           THEN
                           (GO VILOOP)
                           ELSE
                           (GO LOOPM))))))))
    EXPR)
  (DEFPROP
    MAXUNSATL
    (LAMBDA
      (PC)
      (FOR
        NEW PART-NUM IN PC LIST
        (PROG (N TD M)
              (SETQ N (SETQ TD (SETQ M 0.0)))
              (FOR NEW PR IN (CAR PART-NUM)
                   DO
                   (SETQ N (PLUS N (CDR PR)))
                   (SETQ TD (PLUS TD (TIMES (CDR PR)
                                            (VALENCE (CAR PR)))))
                   (SETQ M (MAX M (VALENCE (CAR PR)))))
              (RETURN (FIX (TIMES .5 (PLUS 2.0 TD (TIMES -2.0 N)
                                           (MIN -1.0
                                                (DIFFERENCE
                                                  TD
                                                  (TWICE M))))))))))
    EXPR)
  (DEFPROP SUPERATOMS (LAMBDA
             (UCL-COMP)
             (GROUPRADS (FOR NEW UCLN IN UCL-COMP LIST
                             (CONS (RINGS (CAAR UCLN)
                                          (CDAR UCLN))
                                   (CDR UCLN)))))
           EXPR)
  (DEFPROP COMPUTEFV
           (LAMBDA
             (U CL)
             (PROG (TD N)
                   (SETQ TD (SETQ N 0.0))
                   (FOR NEW PR IN CL DO
                        (SETQ TD (PLUS (TIMES (VALENCE (CAR PR))
                                              (CDR PR))
                                       TD))
                        (SETQ N (PLUS (CDR PR)
                                      N)))
                   (RETURN (PLUS 2.0 TD (TIMES -2.0 (PLUS N U))))))
           EXPR)
  (DEFPROP CLBYVALENCE
           (LAMBDA
             (CL)
             (PROG2 (SETQ CL (GROUPBY (FUNCTION (LAMBDA
                                                  (PR)
                                                  (VALENCE
                                                    (CAR PR))))
                                      CL))
                    (FOR NEW I := (2.0 (MAXLIST (MAPCAR (QUOTE CAR)
                                                        CL)))
                         LIST
                         (LMASSOC I CL NIL))))
           EXPR)
  (DEFPROP RINGS
           (LAMBDA
             (U CL)
             (PROG (FV)
                   (SETQ FV (COMPUTEFV U CL))
                   (SETQ CL (CLBYVALENCE CL))
                   (RETURN (FOR NEW SKELETON IN
                                (RINGSKELETONS FV (MAPCAR (QUOTE 
                                                            CLCOUNT)
                                                          CL))
                                NCONC FIRST NIL (STRUCTURESWITHATOMS
                                  CL SKELETON)))))
           EXPR)
  (DEFPROP
    FVPARTITIONS
    (LAMBDA
      (FV VL)
      (FOR NEW FVP IN (FVPARTITION1 FV (CDR VL)
                                    1.0)
           AS NEW FVR IS (ROWS FVP)
           XLIST
           (FVPARTITION FVR = FVR NEWVL =
                        (FOR NEW ROW IN FVR AS NEW COL IN (CONS NIL FVP)
                             AS NEW V IN VL LIST
                             (PLUS V (PLUSLIST ROW)
                                   (MINUS (PLUSLIST COL)))))))
    EXPR)
  (DEFPROP RINGSKELETONS (LAMBDA (FV VL)
                                 (FOR NEW FVPART IN (FVPARTITIONS
                                        FV VL)
                                      FOR NEW STRUC IN
                                      (NOFV-RINGS (NEWVL FVPART))
                                      NCONC FIRST NIL
                                      (ATTACHFVS (FVR FVPART)
                                                 STRUC)))
           EXPR)
  (DEFPROP NOFV-RINGS (LAMBDA
             (VL)
             (PROG (MNLPS MXLPS SUMREST)
                   (SETQ SUMREST (PLUSLIST (CDR VL)))
                   (IF (ZEROP SUMREST)
                       THEN
                       (RETURN (SINGLERINGS (CAR VL)))
                       ELSEIF
                       (EQUAL SUMREST 1.0)
                       THEN
                       (RETURN (DAISIES VL)))
                   (SETQ MNLPS (MINLOOPS VL))
                   (SETQ MXLPS (MAXLOOPS VL))
                   (RETURN (FOR NEW P := (MNLPS MXLPS)
                                NCONC FIRST NIL (KLOOPEDRINGS P VL)))))
           EXPR)
  (DEFPROP
    DAISIES
    (LAMBDA
      (VL)
      (FOR NEW P IN (NUMPARTITIONS
             (CAR VL)
             (QUOTIENT (FOR NEW X IN (CDR VL)
                            AS NEW I := (3.0 INFINITY)
                            UNTIL
                            (NOT (ZEROP X))
                            PROG2 I)
                       2.0)
             1.0 0.999999E8)
           NCONC FIRST NIL (DAISY (CLCREATE P))))
    EXPR)
  (DEFPROP
    NOLOOPEDRINGS
    (LAMBDA
      (VL)
      (IF (ZEROP (CAR VL))
          THEN
          (CATALOG (CDR VL))
          ELSE
          (PROG (BP)
                (SETQ BP (BIVALENTPARTITIONS VL))
                (RETURN (FOR NEW S IN (CATALOG (CDR VL))
                             FOR NEW P IN BP NCONC FIRST NIL
                             (ATTACHBIVALENTS (CLCREATE P)
                                              S))))))
    EXPR)
  (DEFPROP ROWS (LAMBDA (LL)
                        (IF (NOT LL)
                            THEN
                            (QUOTE (NIL))
                            ELSE
                            (CONS (CARLIST LL)
                                  (ROWS (CDRLIST (CDR LL))))))
           EXPR)
  (DEFPROP BIVALENTPARTITIONS
           (LAMBDA (VL)
                   (NUMPARTITIONS (CAR VL)
                                  (QUOTIENT (FOR NEW I := (3.0 INFINITY)
                                                 AS NEW X IN
                                                 (CDR VL)
                                                 PLUS
                                                 (TIMES I X))
                                            2.0)
                                  0.0
                                  (CAR VL)))
           EXPR)
  (DEFPROP
    FREEVALENCESIZE
    (LAMBDA (S)
            (IF (STRUCTURE? S)
                THEN
                (FOR NEW X IN (CTABLE S)
                     FOR NEW Y IN (NBRS X)
                     WHEN
                     (EQ Y (QUOTE FV))
                     PLUS 1.0)
                ELSEIF
                (STRUCFORM? S)
                THEN
                (IF (EQ (CAR (FORM S))
                        (QUOTE ATTACHFVS))
                    THEN
                    (FOR NEW FVL IN (CADR (FORM S))
                         FOR NEW X IN FVL AS NEW I := (1.0 INFINITY)
                         PLUS
                         (TIMES I X))
                    ELSE
                    (FREEVALENCESIZE (CADDR (FORM S))))
                ELSE
                (HELP "WHAT'S THE FREE VALNECE OF" S)))
    EXPR)
  (DEFPROP NODES (LAMBDA (STRUC)
                         (FOR NEW CT IN (CTABLE STRUC)
                              LIST
                              (NODENUM CT)))
           EXPR)
  (DEFPROP COLLECTFV (LAMBDA (S)
                             (FOR NEW CT IN (CTABLE S)
                                  FOR NEW X IN (NBRS CT)
                                  WHEN
                                  (EQ X (QUOTE FV))
                                  XLIST
                                  (NODENUM CT)))
           EXPR)
  (DEFPROP TRIMZEROS
           (LAMBDA
             (L)
             (PROG NIL (RETURN (IF (NULL L)
                                   THEN NIL ELSEIF (ZEROP (PLUSLIST
                                                            L))
                                   THEN NIL ELSE
                                   (CONS (CAR L)
                                         (TRIMZEROS (CDR L)))))))
           EXPR)
  (DEFPROP CATALOG (LAMBDA
             (L)
             (IF (AND (EQUAL (PLUSLIST (SETQ L (TRIMZEROS L)))
                             2.0)
                      (EQUAL (CAR (LAST L))
                             2.0))
                 THEN
                 (LIST (STRUCWITH2NODES (PLUS 2.0 (LENGTH L))))
                 ELSE
                 (CATALOG3 L)))
           EXPR)
  (DEFPROP STRUCWITH2NODES
           (LAMBDA (N)
                   (STRUCTURE UGRAPH = (CONS (QUOTE MBONDS)
                                             N)
                              CTABLE =
                              (LIST (CTENTRY NODENUM = 1.0 NBRS =
                                             (FOR NEW I :=
                                                  (1.0 N)
                                                  XLIST 2.0))
                                    (CTENTRY NODENUM = 2.0 NBRS =
                                             (FOR NEW I :=
                                                  (1.0 N)
                                                  XLIST 1.0)))
                              LASTNODE# = 2.0))
           EXPR)
  (DEFPROP
    CATALOG3
    (LAMBDA
      (TVL)
      (PROG (C)
            (COND ((NOT (ZEROP (PLUSLIST (CDR TVL))))
                   NIL)
                  (T (SETQ C (NTH CATALOG-LIST (QUOTIENT (CAR TVL)
                                                         2.0)))))
            (RETURN (IF (AND C (CAR C))
                        THEN
                        (CAR C)
                        ELSE
                        (LIST (STRUCFORM FORM = (CONS (QUOTE CATALOG)
                                                      TVL)))))))
    EXPR)
  (DEFPROP DAISY
           (LAMBDA (PART)
                   (PROG (S C)
                         (SETQ LASTNODE 1.0)
                         (SETQ S (STRUCTURE UGRAPH =
                                            (CONS (QUOTE DAISY)
                                                  PART)
                                            CTABLE =
                                            (LIST (CTENTRY NODENUM = 
                                                           LASTNODE))
                                            LASTNODE# = LASTNODE))
                         (SETQ C LASTNODE)
                         (FOR NEW PAIR IN PART FOR NEW I :=
                              (1.0 (CDR PAIR))
                              DO
                              (SETQ S (PUTBIVN S C (CAR PAIR))))
                         (RETURN (LIST S))))
           EXPR)
  (DEFPROP SINGLERING (LAMBDA (N)
                              (PROG (S)
                                    (SETQ LASTNODE 0.0)
                                    (SETQ S (BIVCHAIN N))
                                    (CONNECT
                                      (CAR (CTABLE S))
                                      (CAR (LAST (CTABLE S))))
                                    (RETURN (STRUCTURE
                                              FROM S UGRAPH =
                                              (CONS (QUOTE SINGLERING)
                                                    N)))))
           EXPR)
  (DEFPROP BIVCHAIN (LAMBDA (N)
                            (PROG (X)
                                  (FOR NEW I := (1.0 N)
                                       DO
                                       (SETQ X (PUTNEWNODE X)))
                                  (RETURN X)))
           EXPR)
  (DEFPROP CONNECT (LAMBDA (X Y)
                           (PROG NIL (REPLACE (NBRS X)
                                              (CONS (NODENUM Y)
                                                    (NBRS X)))
                                 (COND ((NOT (EQ X Y))
                                        (REPLACE (NBRS Y)
                                                 (CONS (NODENUM X)
                                                       (NBRS Y)))))))
           EXPR)
  (DEFPROP COPYSTRUC (LAMBDA (S)
                             (PROG2 (SETQ LASTNODE (LASTNODE# S))
                                    (COPY S)))
           EXPR)
  (DEFPROP DISCONNECT (LAMBDA (X Y)
                              (PROG NIL (REPLACE (NBRS X)
                                                 (DELETE (NODENUM
                                                           Y)
                                                         (NBRS X)))
                                    (REPLACE (NBRS Y)
                                             (DELETE (NODENUM X)
                                                     (NBRS Y)))))
           EXPR)
  (DEFPROP FINDCTE (LAMBDA (N LST)
                           (COND ((NUMBERP N)
                                  (COND ((STRUCTURE? LST)
                                         (SETQ LST (CTABLE LST)))
                                        (T NIL))
                                  (FOR NEW L IN LST WHEN
                                       (EQUAL (NODENUM L)
                                              N)
                                       DO
                                       (RETURN L)))
                                 ((NUMBERP LST)
                                  (FINDCTE LST N))
                                 (T (ERROR (QUOTE (BAD ARGUMENTS TO 
                                                       FINDCTE))))))
           EXPR)
  (DEFPROP FIRSTOFNODES (LAMBDA (X)
                                (NODENUM (CAR (CTABLE X))))
           EXPR)
  (DEFPROP LASTOFNODES (LAMBDA (X)
                               (NODENUM (CAR (LAST (CTABLE X)))))
           EXPR)
  (DEFPROP LISTBYVALENCE
           (LAMBDA (S)
                   (PROG (M V)
                         (SETQ M (LENGTH (CTABLE S)))
                         (RETURN (FOR NEW I := (2.0 INFINITY)
                                      WHILE
                                      (GREATERP M 0.0)
                                      LIST
                                      (SETQ V (VALENCETYPE S I))
                                      (SETQ M (DIFFERENCE M
                                                          (LENGTH
                                                            V)))
                                      V))))
           EXPR)
  (DEFPROP PUTFVN (LAMBDA
             (S N J)
             (PROG NIL (SETQ N (FINDCTE N (CTABLE S)))
                   (REPLACE (NBRS N)
                            (NCONC (NBRS N)
                                   (FOR NEW I := (1.0 J)
                                        XLIST
                                        (QUOTE FV))))
                   (RETURN S)))
           EXPR)
  (DEFPROP PUTFVS
           (LAMBDA (S FVP)
                   (PROG2 (FOR NEW NI IN FVP FOR NEW NIJ IN NI AS NEW J 
                               := (1.0 10.0)
                               FOR NEW NODE IN NIJ DO
                               (SETQ S (PUTFVN S NODE J)))
                          S))
           EXPR)
  (DEFPROP PUTNEWNODE
           (LAMBDA (STRUC)
                   (COND (STRUC (PROG2 (SETQ LASTNODE
                                             (ADD1 (LASTNODE# STRUC)))
                                       (STRUCTURE FROM STRUC CTABLE =
                                                  (PUTNEWNODEINCT
                                                    (CTENTRY NODENUM = 
                                                           LASTNODE)
                                                    (CTABLE OF STRUC))
                                                  LASTNODE# = LASTNODE))
                                )
                         (T (PROG2 (SETQ LASTNODE (ADD1 LASTNODE))
                                   (STRUCTURE CTABLE =
                                              (LIST (CTENTRY NODENUM = 
                                                           LASTNODE))
                                              LASTNODE# = LASTNODE)))))
           EXPR)
  (DEFPROP PUTNEWNODEINCT (LAMBDA (X Y)
                                  (PROG (Z)
                                        (SETQ Z (CAR Y))
                                        (REPLACE (NBRS OF Z)
                                                 (CONS (NODENUM X)
                                                       (NBRS Z)))
                                        (REPLACE (NBRS OF X)
                                                 (CONS (NODENUM Z)
                                                       (NBRS X)))
                                        (RETURN (CONS X Y))))
           EXPR)
  (DEFPROP NODEVALENCE (LAMBDA (NODE)
                               (COND ((NULL NODE)
                                      (ERROR (QUOTE (NULL NODE GIVEN TO 
                                                        NODEVALENCE))))
                                     ((CTENTRY? NODE)
                                      (LENGTH (NBRS NODE)))
                                     (T (NODEVALENCE
                                          (FINDCTE (CAR NODE)
                                                   (CDR NODE))))))
           EXPR)
  (DEFPROP VALENCETYPE (LAMBDA (S I)
                               (FOR NEW NODE IN (CTABLE S)
                                    WHEN
                                    (EQUAL I (NODEVALENCE NODE))
                                    XLIST
                                    (NODENUM NODE)))
           EXPR)
  (DEFPROP SINGLERINGS (LAMBDA (N)
                               (LIST (SINGLERING N)))
           EXPR)
  (DEFPROP INSERTMARKERS
           (LAMBDA
             (STRUC CLL L)
             (PROG NIL
                   (FOR NEW CL IN CLL AS NEW NLL IN L FOR NEW PAIR IN 
                        CL AS NEW NL IN NLL FOR NEW N IN NL DO
                        (REPLACE (ATOMTYPE (MARKERS (FINDCTE N STRUC)))
                                 (CAR PAIR)))
                   (RETURN STRUC)))
           EXPR)
  (DEFPROP DELETE (LAMBDA (I L)
                          (COND ((NULL L)
                                 NIL)
                                ((EQUAL (CAR L)
                                        I)
                                 (CDR L))
                                (T (CONS (CAR L)
                                         (DELETE I (CDR L))))))
           EXPR)
STOP