(FILECREATED "29-OCT-73  6:53:28" 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)))

(* 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])
)
STOP