perm filename GROUP[PAT,LMM] blob sn#097628 filedate 1974-04-15 generic text, type T, neo UTF8

(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