(FILECREATED " 6-APR-74 02:35:39" GROUP

     changes to:  FOUND?, IMAGE

     previous date: "16-MAR-74  7:45:46")


  (LISPXPRINT (QUOTE GROUPVARS)
              T)
  (RPAQQ GROUPVARS
         ((FNS FIXUPGROUP FINDNEWGROUP FINDNEWGROUP1 FINDPERMS POSSIMS 
               CONNECTIVITY GROUPCOUNT FOUND? FINDGROUPEDGES IMAGE 
               FINDGROUPNODES FINDPAIR)))
(DEFINEQ

(FIXUPGROUP
  [LAMBDA (STRUC)
    (replace GROUP
       of STRUC
         with (FINDNEWGROUP STRUC
                            (CLASSIFYNODES
                              (for X in (fetch CTABLE of STRUC)
                                 when (for NL
                                         in (CAR (fetch GROUP of STRUC))
                                         always (NOT (MEMB (fetch NODENUM
                                                              of X)
                                                           NL)))
                                 collect (fetch NODENUM of X))
                              STRUC])

(FINDNEWGROUP
  [LAMBDA (STRUC NEWORBITS)
    (PROG [(NEWOBJ (CAR (fetch GROUP of STRUC]
          (for ORB in NEWORBITS do (SETQ NEWOBJ (CONS (REVERSE ORB)
                                                      NEWOBJ)))
          (RETURN (CONS NEWOBJ (for P in (FINDNEWGROUP1 STRUC NEWORBITS)
                                  when (NOT (EQUAL NEWOBJ (CDR P)))
                                  rcollect (CDR P])

(FINDNEWGROUP1
  [LAMBDA (STRUC NEWORBITS)
    (for P in (fetch GROUP of STRUC)
       join (FINDPERMS (CAR NEWORBITS)
                       NEWORBITS
                       (CONS NIL P)
                       (CONS NIL (CAR (fetch GROUP of STRUC)))
                       STRUC])

(FINDPERMS
  [LAMBDA (NODES CLASSES IMS MAPPED STRUC)
    (COND
      ((NULL CLASSES)
        (LIST IMS))
      ((NULL NODES)
        (FINDPERMS (CADR CLASSES)
                   (CDR CLASSES)
                   (CONS NIL IMS)
                   (CONS NIL MAPPED)
                   STRUC))
      (T (for Y in (POSSIMS (CAR NODES)
                            (CAR CLASSES)
                            IMS MAPPED STRUC)
            join (FINDPERMS (CDR NODES)
                            CLASSES
                            (CONS (CONS Y (CAR IMS))
                                  (CDR IMS))
                            (CONS (CONS (CAR NODES)
                                        (CAR MAPPED))
                                  (CDR MAPPED))
                            STRUC])

(POSSIMS
  [LAMBDA (X CLASS IMS MAPPED STRUC)
    (for Y in CLASS
       when [AND (NOT (MEMB Y (CAR IMS)))
                 (for ML in MAPPED as IL in IMS
                    always (for M in ML as I in IL
                              always (EQ (CONNECTIVITY Y I STRUC)
                                         (CONNECTIVITY X M STRUC]
       rcollect Y])

(CONNECTIVITY
  [LAMBDA (X Y STRUC)
    (for Z in (fetch NBRS of (FINDCTE X STRUC)) count (EQ Z Y])

(GROUPCOUNT
  [LAMBDA (L)
    (PROG NIL
          (SETQ L (GROUPBY (QUOTE CDR)
                           (CLCREATE L)))
          (RETURN (for I from (for X in L maximum (CAR X)) to 1 by -1
                     rcollect (CARLIST (LMASSOC I L NIL])

(FOUND?
  [LAMBDA (NODE GROUP)
    (for NL in (CAR GROUP) as N from 1 do (COND
                                            ((MEMB NODE NL)
                                              (RETURN (CONS N NL])

(FINDGROUPEDGES
  [LAMBDA (EDGES STRUC)
    (PROG (G)
          (COND
            ([NOT (for EDGE in EDGES
                     always (AND (FOUND? (fetch NODE1 of EDGE)
                                         (fetch GROUP of STRUC))
                                 (FOUND? (fetch NODE2 of EDGE)
                                         (fetch GROUP of STRUC]
              (FIXUPGROUP STRUC)))
          (SETQ G (fetch GROUP of STRUC))
          (RETURN (create NPL REMPERMS←(for P in (CDR G)
                                          rcollect
                                           (create
                                             CHECKPERM OBJ← EDGES POBJ←(for
                                               EDGE in EDGES
                                                                          
collect (FINDPAIR (IMAGE (fetch NODE1 of EDGE)
                         (CAR G)
                         P)
                  (IMAGE (fetch NODE2 of EDGE)
                         (CAR G)
                         P)
                  EDGES))
                                             ORIGPERM← P))
                          OKPERMS←(LIST (CAR G])

(IMAGE
  [LAMBDA (NODE MAPPED IMAGES)
    (for ML in MAPPED as IL in IMAGES
       any (find I in IL as M in ML suchthat (EQ NODE M])

(FINDGROUPNODES
  [LAMBDA (OBJECTS STRUC)
    (PROG (N FOUND)
      L1  (SETQ FOUND (FOUND? (CAR OBJECTS)
                              (FETCH GROUP OF STRUC)))
          [COND
            ((NOT FOUND)
              (FIXUPGROUP STRUC))
            (T (RETURN (CREATE NPL REMPERMS←(for P
                                               in (CDR (fetch GROUP
                                                          of STRUC))
                                               rcollect
                                                (create
                                                  CHECKPERM OBJ←(CDR FOUND)
                                                  POBJ←(CAR
                                                    (NTH P (CAR FOUND)))
                                                  ORIGPERM← P))
                               OKPERMS←(LIST (CAR (FETCH GROUP OF STRUC]
          (GO L1])

(FINDPAIR
  [LAMBDA (N1 N2 LST)
    (CAR (OR [SOME LST (FUNCTION (LAMBDA (X)
                       (OR (AND (EQ (CAR X)
                                    N1)
                                (EQ (CDR X)
                                    N2))
                           (AND (EQ (CDR X)
                                    N1)
                                (EQ (CAR X)
                                    N2]
             (HELP "INCONSISTANCY IN FIND-PAIR; FINDING GROUP ON EDGES"])
)
STOP