(FILECREATED " 7-NOV-73  5:19:45" S-GROUP)


  (LISPXPRINT (QUOTE GROUPVARS)
              T)
  [RPAQQ GROUPVARS
         ((* group finding and fixing routines)
          (FNS FIXUPGROUP FINDNEWGROUP FINDNEWGROUP1 FINDPERMS 
               POSSIMS CONNECTIVITY GROUPCOUNT FOUND? FINDGROUPEDGES 
               IMAGE FINDGROUPNODES)
          (BLOCKS (NIL FINDPERMS POSSIMS CONNECTIVITY FOUND? IMAGE
                       (LINKFNS . T]

(* group finding and fixing routines)

(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)
          (SETQ NEWOBJ (FOR ORB IN NEWORBITS XLIST
                          FIRST (CAR (fetch GROUP of STRUC))
                                (REVERSE ORB)))
          (RETURN (CONS NEWOBJ (FOR P IN (FINDNEWGROUP1 STRUC 
                                                        NEWORBITS)
                                  WHEN (NOT (EQUAL NEWOBJ
                                                   (CDR P)))
                                       XLIST
                                       (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 (NOT (MEMB Y (CAR IMS)))
       WHEN (FOR ML IN MAPPED AS IL IN IMS FOR M IN ML AS I
               IN IL AND (EQ (CONNECTIVITY Y I STRUC)
                             (CONNECTIVITY X M STRUC)))
            XLIST Y])

(CONNECTIVITY
  [LAMBDA (X Y STRUC)
    (FOR Z IN (FETCH NBRS OF (FINDCTE X STRUC)) WHEN (EQ Z Y)
       SUM 1])

(GROUPCOUNT
  [LAMBDA (L)
    (PROG NIL
          (SETQ L (GROUPBY (QUOTE CDR)
                           (CLCREATE L)))
          (RETURN (FOR I TO (FOR X IN L MAXIMUM (CAR X))
                     COLLECT (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
                          AND (AND (FOUND? (FETCH NODE1 OF EDGE)
                                           (FETCH GROUP OF STRUC))
                                   (FOUND? (FETCH NODE2 OF EDGE)
                                           (FETCH GROUP OF STRUC]
              (FIXUPGROUP STRUC))
            (T NIL))
          (SETQ G (FETCH GROUP OF STRUC))
          (RETURN
            (CREATE NPL REMPERMS←(FOR
                      P
                                    IN
                                     (CDR G)
                                     XLIST
                                     (CREATE
                                       CHECKPERM OBJ← EDGES POBJ←(FOR
                                         EDGE IN EDGES
                                                                    
COLLECT (ORDPAIR (IMAGE (FETCH NODE1 OF EDGE)
                        (CAR G)
                        P)
                 (IMAGE (FETCH NODE2 OF EDGE)
                        (CAR G)
                        P)))
                                       ORIGPERM← P))
                    OKPERMS←(LIST (CAR G])

(IMAGE
  [LAMBDA (NODE MAPPED IMAGES)
    (FOR ML IN MAPPED AS IL IN IMAGES FOR M IN ML AS I IN IL
       WHEN (EQP NODE M)
       DO (RETURN I])

(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))
                               XLIST
                               (CREATE CHECKPERM OBJ←(CDR FOUND)
                                       POBJ←(CAR (NTH P (CAR FOUND)))
                                       ORIGPERM← P))
                        OKPERMS←(LIST (CAR (FETCH GROUP OF STRUC]
          (GO L1])
)
(DECLARE
  (BLOCK: NIL FINDPERMS POSSIMS CONNECTIVITY FOUND? IMAGE
          (LINKFNS . T))
)STOP