perm filename CYCOMG.PRT[4,LMM] blob sn#037537 filedate 1973-04-23 generic text, type T, neo UTF8
  (DEFPROP CYCOMGFNS
           (CYCOMGFNS LLUNCLASS PERMRADS LABEEDGES LABELFV 
                      STRUCTURESWITHATOMS ATTACHFVS ATTACHBIVALENTS 
                      LLABELNODES MAKEUNCLASSED)
           VALUE)
  (DEFPROP LLUNCLASS (LAMBDA (LLOBJ)
                             (MAPCAR (QUOTE LUNCLASS)
                                     LLOBJ))
           EXPR)
  (DEFPROP
    PERMRADS
    (LAMBDA
      (CENT CLRADS FLAG)
      (PROG2
        (SETQ CLRADS (CLCREATE CLRADS))
        (IF
          (ATOM CENT)
          THEN
          (LIST (RADICAL CENTER = CENT ATTACHEDRADS = CLRADS))
          ELSEIF
          (STRUCFORM? CENT)
          THEN
          (LIST (RADICAL CENTER = (MAKECENTER RADSTRUC = CENT)
                         ATTACHEDRADS = CLRADS))
          ELSE
          (FOR NEW L IN (LABELFV CENT ((LAMBDA
                                    (X)
                                    (IF FLAG THEN (CONS 1.0 X)
                                        ELSE X))
                                  (CDRLIST CLRADS)))
               XLIST
               (RADICAL CENTER =
                        (MAKECENTER AFFLINK =
                                    (IF FLAG THEN (CAAR (LABELED L))
                                        ELSE NIL)
                                    RADSTRUC = (LSTRUC L)
                                    CUFFLINKS =
                                    (IF FLAG THEN (CDR (LABELED L))
                                        ELSE
                                        (LABELED L)))
                        ATTACHEDRADS = CLRADS)))))
    EXPR)
  (DEFPROP
    LABEEDGES
    (LAMBDA
      (STRUC LABELS)
      (FOR NEW L IN (LABELM (UNCLASSED
                              OBJECTS =
                              (FOR NEW CT IN (CTABLE STRUC)
                                   FOR NEW N IN (NBRS CT)
                                   WHEN
                                   (LEQ (NODENUM CT)
                                        N)
                                   XLIST
                                   (CONS (NODENUM CT)
                                         N)))
                            LABELS STRUC)
           XLIST
           (LABELING FROM L LABELED = (LUNCLASS **))))
    EXPR)
  (DEFPROP LABELFV (LAMBDA (STRUC LABELS)
                           (FOR NEW L IN (LABELM (UNCLASSED
                                                   OBJECTS =
                                                   (COLLECTFV STRUC))
                                                 LABELS STRUC)
                                XLIST
                                (LABELING FROM L LABELED =
                                          (LUNCLASS **))))
           EXPR)
  (DEFPROP STRUCTURESWITHATOMS
           (LAMBDA (CLL STRUC)
                   (FOR NEW L IN (LLABELNODES STRUC (LCDRLIST CLL))
                        XLIST
                        (INSERTMARKERS (COPYSTRUC (LSTRUC L))
                                       CLL
                                       (LABELED L))))
           EXPR)
  (DEFPROP ATTACHFVS (LAMBDA (FVP STRUC)
                             (FOR NEW L IN (LLABELNODES STRUC FVP)
                                  XLIST
                                  (PUTFVS (COPYSTRUC (LSTRUC L))
                                          (LABELED L))))
           EXPR)
  (DEFPROP ATTACHBIVALENTS (LAMBDA
             (PART STRUC)
             (FOR NEW L IN (LABELEDGES STRUC (CDRLIST PART))
                  XLIST
                  (PUTBIVS (COPYSTRUC (LSTRUC L))
                           (CARLIST PART)
                           (LABELED L))))
           EXPR)
  (DEFPROP LLABELNODES (LAMBDA (STRUC LLABELS)
                               (FOR NEW L IN
                                    (LLABEL (MAPCAR (QUOTE 
                                                      MAKEUNCLASSED)
                                                    (LISTBYVALENCE
                                                      STRUC))
                                            LLABELS STRUC)
                                    XLIST
                                    (LABELING FROM L LABELED =
                                              (LLUNCLASS **))))
           EXPR)
  (DEFPROP MAKEUNCLASSED (LAMBDA (X)
                                 (IF (NOT X)
                                     THEN NIL ELSE
                                     (UNCLASSED OBJECTS = X)))
           EXPR)
STOP