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

(FILECREATED "15-APR-74 07:16:54" BITLABELER) (LISPXPRINT (QUOTE BITLABELERVARS) T) [RPAQQ BITLABELERVARS ((COMPROP MACRO 2TO LOG2 CONTAINED ELTLESSP TWICE NEXTSMALLESTELT DISJOINTDIFF ALLLARGERELTS LARGESTELT MAKESET DIFF1 ELEMENTOF ADDELT SETDIFF EMPTY UNIONSET INTERSECT DISJOINT NULLSET EQSET SETSIZE FIRST REST) (FNS LLABELNODES BITLABEL BITGROUP FIXBITGROUP LISTCYCLES ELTTIMES PERMTIMES TAKEN GCD RELATIVELYPRIME LCM PERMCYCLEINDEX1 BINARY.LSTG LST.BINARYG BINARY.LST LST.BINARY LOG2 CONTAINED LISTELT DM SETDIFF SETSIZE FIRST REST LABELGRAPH INSERTCL DIFFCL SUBSETS PCYCLEINDEX CYCLEINDEX LFROMCL POLYA INSERT SLTPSANDPINVS) (FNS MLG ORBIT1 REDUCEGROUP ALLSUBSETS MANYLABELGRAPHTOP MANYLABELGRAPH LABELCLASS LABELGENCLASS LABELORBITS LO1 LOADD ORBITS CANONICAL SLTPS) (VARS (INPUTMODE (QUOTE FUNCTION] (DEFLIST(QUOTE( [2TO ((N) (LLSH 1 (SUB1 N] (LOG2 NIL) [CONTAINED ((A B) (ZEROP (LOC (ASSEMBLE NIL (CQ (VAG A)) (PUSHN) (CQ (VAG B)) (POP NP , 10) (XOR 1 , 10) (AND 1 , 10] (ELTLESSP ((X Y) (IGREATERP X Y))) (TWICE ((X) (LLSH X 1))) (NEXTSMALLESTELT ((X) (TWICE X))) (DISJOINTDIFF ((X Y) (LOGXOR X Y))) (ALLLARGERELTS ((X) (SUB1 X))) (LARGESTELT (NIL 1)) (MAKESET (X (CONS (QUOTE LOGOR) X))) (DIFF1 ((A B) (SETDIFF A B))) (ELEMENTOF ((X A) (CONTAINED X A))) (ADDELT ((X A) (UNION X A))) [SETDIFF ((A B) (LOC (ASSEMBLE NIL (CQ (VAG A)) (PUSHN) (CQ (VAG B)) (POP NP , 2) (XOR 1 , 2) (AND 1 , 2] (EMPTY ((X) (ZEROP X))) (UNIONSET ((A B) (LOGOR A B))) (INTERSECT ((A B) (LOGAND A B))) [DISJOINT ((A B) (EMPTY (INTERSECT A B] (NULLSET (NIL 0)) (EQSET ((X Y) (EQP X Y))) [SETSIZE ((A) (LOC (ASSEMBLE NIL (CQ (VAG A)) (MOVE 2 , 1) (HRRZI 1 , 0) (JUMPE 2 , RET) LP (ADDI 1 , 1) (MOVE 3 , 2) (SUBI 3 , 1) (AND 2 , 3) (JUMPN 2 , LP) RET] [FIRST ((X) (LOC (ASSEMBLE NIL (CQ (VAG X)) (HRREI 2 , -1) (ADD 2 , 1) (XOR 2 , 1) (AND 1 , 2] [REST ((X) (LOC (ASSEMBLE NIL (CQ (VAG X)) (HRREI 2 , -1) (ADD 2 , 1) (AND 1 , 2] ))(QUOTE MACRO)(QUOTE EVALUATE©)) (DEFINEQ (LLABELNODES [LAMBDA (STRUC LLABELS) (PROG ((NEWNODES (LISTBYVALENCE STRUC))) (COND ([for X in LLABELS as Y in NEWNODES always (for ZZ in X always (OR (ZEROP ZZ) (EQLENGTH Y ZZ] (* FOR EACH TYPE OF VALENCE, THERE IS ONLY ONE LABEL TYPE) (LIST (create LABELING LABELED ←[for X in LLABELS as Y in NEWNODES collect (for ZZ in X collect (COND ((NOT (ZEROP ZZ)) Y] LSTRUC ← STRUC))) (T (for L in (BITLABEL (for X in NEWNODES collect (OR (LST.BINARY X) 0)) LLABELS (BITGROUP STRUC)) collect (create LABELING reusing L LABELED ←(BINARY.LST (fetch LABELED of L)) LSTRUC ←(FIXBITGROUP STRUC (fetch LSTRUC of L]) (BITLABEL [LAMBDA (NODESLIST LABELSLIST GROUP) (COND ((OR (NULL LABELSLIST) (NULL NODESLIST)) (AND LABELSLIST (NOT (EVERY NODESLIST (QUOTE ZEROP))) (HELP "INCONSISTANT CONDITION IN BITLABEL")) (LIST (create LABELING LSTRUC ← GROUP))) (T (for L1 in (MANYLABELGRAPH (CAR NODESLIST) (CAR LABELSLIST) GROUP) join (for L2 in (BITLABEL (CDR NODESLIST) (CDR LABELSLIST) (fetch LSTRUC of L1)) rcollect (create LABELING reusing L2 LABELED ←(CONS (fetch LABELED of L1) (fetch LABELED of L2]) (BITGROUP [LAMBDA (STRUC) [COND ([EVERY (fetch GROUP of STRUC) (FUNCTION (LAMBDA (X Y) (AND (OR (NULL (CDR Y)) (LISTP (CDR Y))) (EVERY X (FUNCTION (LAMBDA (X1 Y1) (AND (OR (NULL (CDR Y1)) (LISTP (CDR Y1))) (EVERY X1 (FUNCTION (LAMBDA (Z ZT) (AND (OR (NULL (CDR ZT)) (LISTP (CDR ZT))) (NUMBERP Z] (FIXUPGROUP STRUC) (replace GROUP of STRUC with (CONS (fetch LASTNODE# of STRUC) (LST.BINARYG (MAPCAR (fetch GROUP of STRUC) (FUNCTION (LAMBDA (PERM) (MAPCONC PERM (FUNCTION (LAMBDA (X) (APPEND X] (COND ((NEQ (CAR (fetch GROUP of STRUC)) (fetch LASTNODE# of STRUC)) (HELP "NEED TO FIXUPBITGROUP "))) (CDR (fetch GROUP of STRUC]) (FIXBITGROUP [LAMBDA (STRUC GROUP) (replace GROUP of STRUC with (CONS (fetch LASTNODE# of STRUC) GROUP]) (LISTCYCLES [LAMBDA (PERM) (* Returns the list of cycles of perm, where a cycle is a list of elements) (PROG (LS X PX) (SETQ X (CAR PERM)) (SETQ PX X) L1 (SETQ LS (CONS [PROG ((RSLT)) LP (SETQ PX (ELTTIMES PX PERM)) (SETQ RSLT (CONS PX RSLT)) (COND ((EQ PX X) (RETURN RSLT)) (T (GO LP] LS)) [COND ((for old X in PERM always (thereis CYCLE in LS suchthat (MEMB X CYCLE))) (RETURN (for X in LS when (CDR X) collect X] (SETQ PX X) (GO L1]) (ELTTIMES [LAMBDA (X P) (CAR (FNTH P X]) (PERMTIMES [LAMBDA (P1 P2) (for X in P1 collect (ELTTIMES X P2]) (TAKEN [LAMBDA (N I) (bind RESULT←1 for J from 1 to I do (SETQ RESULT (IQUOTIENT (ITIMES RESULT N) J)) (SETQ N (SUB1 N)) finally (RETURN RESULT]) (GCD [LAMBDA (N1 N2) (COND ((EQ 0 (SETQ N1 (IREMAINDER N1 N2))) N2) (T (GCD N2 N1]) (RELATIVELYPRIME [LAMBDA (N1 N2) (EQ 1 (GCD N1 N2]) (LCM [LAMBDA (N1 N2) (IQUOTIENT (ITIMES N1 N2) (GCD N1 N2]) (PERMCYCLEINDEX1 [LAMBDA (PERM) (for CYCLE in (fetch CYCLES of PERM) collect (SETSIZE CYCLE]) (BINARY.LSTG [LAMBDA (GROUP) (for PERM in GROUP collect (for X in (CAR (fetch POWERS of PERM)) collect (LOG2 X]) (LST.BINARYG [LAMBDA (GROUP) (PROG (RESULTS CYCLES ORDERS P2 ORDER) [for PERM in GROUP do (COND ((SETQ CYCLES (LISTCYCLES PERM)) (SETQ ORDER 1) [for CYCLE in CYCLES do (SETQ ORDER (LCM ORDER (LENGTH CYCLE] (SETQ ORDERS (CONS 1 (for I from 2 to (LLSH ORDER -1) when (RELATIVELYPRIME I ORDER) collect I))) (SETQ P2 PERM) (SETQ RESULTS (CONS [create PERMUTATION ORDER ←(COND ((EQ ORDER 2) NIL) (T ORDERS)) CYCLES ←[SORT (for CYCLE in CYCLES collect (LST.BINARY CYCLE)) (FUNCTION (LAMBDA (X Y) (ILESSP (SETSIZE X) (SETSIZE Y] POWERS ←(CONS (for X in PERM collect (LST.BINARY X)) (for I from 2 to (for I in ORDERS maximum I) join (PROGN (SETQ P2 (PERMTIMES PERM P2)) (COND ((MEMB I ORDERS) (LIST (for X in P2 collect (LST.BINARY X] RESULTS] (RETURN RESULTS]) (BINARY.LST [LAMBDA (L) (COND ((NULL L) NIL) ((NLISTP L) (for X in (LISTELT L) collect (LOG2 X))) (T (MAPCAR L (QUOTE BINARY.LST]) (LST.BINARY [LAMBDA (L) (COND ((NULL L) NIL) ((NLISTP L) (2TO L)) ((NLISTP (CAR L)) (bind RSLT←0 for X in L do (SETQ RSLT (UNIONSET RSLT (LST.BINARY X))) finally (RETURN RSLT))) (T (MAPCAR L (QUOTE LST.BINARY]) (LOG2 [LAMBDA (X) (PROG ((I 0)) LP [COND ((ZEROP X) (RETURN I)) (T (SETQ X (LLSH X -1] (SETQ I (ADD1 I)) (GO LP]) (CONTAINED [LAMBDA (A B) (ZEROP (LOGAND A (LOGXOR A B]) (LISTELT [LAMBDA (NODES) (PROG (FN RSLT) LP [COND ((EMPTY NODES) (RETURN (DREVERSE RSLT] (SETQ RSLT (CONS (FIRST NODES) RSLT)) (SETQ NODES (REST NODES)) (GO LP]) (DM [NLAMBDA L [COND ((LISTP (CAR L)) (ERROR (CAR L) (QUOTE "NOT ATOM"] [RPLACA (QUOTE CHANGEDPROPLST) (CONS (CAR L) (CAR (QUOTE CHANGEDPROPLST] (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA) CHANGEDPROPLST))) (/PUT (CAR L) (QUOTE MACRO) (CDR L)) (ADDSPELL (CAR L)) (CAR L]) (SETDIFF [LAMBDA (A B) (LOGAND A (LOGXOR B A]) (SETSIZE [LAMBDA (X) (ADD1 (WHILE [NOT (EMPTY (SETQ X (REST X] SUM 1]) (FIRST [LAMBDA (X) (LOGAND X (LOGXOR X (SUB1 X]) (REST [LAMBDA (X) (LOGAND X (SUB1 X]) (LABELGRAPH [LAMBDA (NODES NUMBER GROUP) (* NODES: set to be labeled - GROUP permutation group on NODES - NUMBER number of labels to be attached - returns list of all nonequivalent labelings of NODES with <number> identical labels) (COND ((NLISTP GROUP) (for X in (ALLSUBSETS NODES NUMBER) collect (create LABELING LABELED ← X))) [(IGREATERP (TWICE NUMBER) (SETSIZE NODES)) (for X in (LABELGRAPH NODES (IDIFFERENCE (SETSIZE NODES) NUMBER) GROUP) rcollect (CREATE LABELING REUSING X LABELED ←(SETDIFF NODES @@] ((ZEROP NUMBER) (LIST (CREATE LABELING LABELED ← 0 LSTRUC ← GROUP))) (T (PROG (FC RESULT) [COND ((EQSET NODES (SETQ FC (ORBIT1 NODES GROUP))) (RETURN (LABELCLASS NODES NUMBER GROUP] (SETQ NODES (SETDIFF NODES FC)) (RETURN (for X from (IMAX 0 (IDIFFERENCE NUMBER (SETSIZE NODES))) to MAXI bind [(MAXI←(IMIN NUMBER (SETSIZE FC] join (for LBL1 in (LABELCLASS FC X GROUP) join (for LBL2 in (LABELGRAPH NODES (CDR LBL1) (IDIFFERENCE NUMBER X)) rcollect (CREATE LABELING REUSING LBL2 LABELED ←(UNIONSET (fetch LABELED of LBL1)@@]) (INSERTCL [LAMBDA (NUMBER ELEMENT OLDCL ORDERF) (* NUMBER: the number of this type of element to insert - ELEMENT: the element to insert - OLDCL the composition list that NUMBER elements are to be inserted into - ORDERF a comparison function which returns NIL if the two arguments are equal or if the first should come after the second in the composition list - Val OLDCL, with NUMBER elements added OLDCL is assumed to be previously sorted by ORDERF) (COND ((OR (NULL OLDCL) (APPLY* ORDERF ELEMENT (CAAR OLDCL))) (CONS (CONS ELEMENT NUMBER) OLDCL)) ((EQUAL (CAAR OLDCL) ELEMENT) (RPLACD (CAR OLDCL) (IPLUS (CDAR OLDCL) NUMBER)) OLDCL) (T (RPLACD OLDCL (INSERTCL NUMBER ELEMENT (CDR OLDCL) ORDERF]) (DIFFCL [LAMBDA (L1 L2) (* L1, L2 are two composition lists - Val the (set) difference (L1-L2)) (for X in L1 bind N when (IGREATERP (SETQ N (IDIFFERENCE (CDR X) (OR (CDR (SASSOC (CAR X) L2)) 0))) 0) collect (CONS (CAR X) N]) (SUBSETS [LAMBDA (C N) (* C is a composition list of numbers. - N a number - Value a list of dotted pairs ;the CAR of each is a subcollection of C such that the elements of that subcollection add up to N ;the CDR is the number of ways that subcollection can be formed from the l's if the l's were all different - E,g, SUBSETS (((5 . 1) (4 . 2) (1 . 1)) 5) yields (((5 . 1)) . 1) (((4 . 1) (1 . 1)) . 2) since 5 can be obtained by taking one 5 in one way ;or by taking a four and a one in two different ways;) (COND [(EQ 0 N) (QUOTE ((NIL . 1] ((on old C always (IGREATERP (CAAR C) N)) NIL) (T (* get rid of numbers at head that are too big; return NIL when they are all to big; the first of the list is all subsets without using the first of C) (* the first element of the new subset is the first of the old; try up to how many on the old; I is the number of times it occurs and II is the amount taken; IT is upper-bounded by N. Try every subset of the reset adding up to N-II.) (* X must not be NIL; the factor is the number of ways of taking I elements out of the (CDAR C) element available) (for I from 1 to (CDAR C) as II from (CAAR C) to N by (CAAR C) bind X FACTOR join (AND (SETQ X (SUBSETS (CDR C) (IDIFFERENCE N II))) (SETQ FACTOR (TAKEN (CDAR C) I)) (NCONC [on old X rcollect (CONS (CONS (CONS (CAAR C) I) (CAAR X)) (ITIMES FACTOR (CDAR X] (SUBSETS (CDR C) N]) (PCYCLEINDEX [LAMBDA (CYCLES NODES) (PROG (INDEX) [for CYCLE in CYCLES do (SETQ INDEX (INSERTCL 1 (SETSIZE (INTERSECT CYCLE NODES)) INDEX (QUOTE ILESSP] (RETURN (COND ([NOT (EQP 0 (SETQ CYCLES (IDIFFERENCE (SETSIZE NODES) (for X in INDEX sum (ITIMES (CAR X) (CDR X] (CONS (CONS 1 CYCLES) INDEX)) (T INDEX]) (CYCLEINDEX [LAMBDA (GROUP NODES) (PROG (INDEX) [for PERM in GROUP do (SETQ INDEX (INSERTCL 1 (PCYCLEINDEX (fetch CYCLES of PERM) NODES) INDEX (FUNCTION (LAMBDA (X Y) (AND (NOT (EQUAL X Y)) (ORDERED X Y] (RETURN (CONS (CONS (LIST (CONS 1 (SETSIZE NODES))) 1) INDEX]) (LFROMCL [LAMBDA (CL N) (SETQ CL (SORT (MAPCAR CL (QUOTE CDR)) (QUOTE ILESSP))) (COND ([NOT (ZEROP (SETQ N (IDIFFERENCE N (sum X for X in CL] (INSERT N CL (QUOTE ILESSP))) (T CL]) (POLYA [LAMBDA (NODES GROUP SUBLIST) (* Args are the same as to MANYLABELGRAPH ; however POLYA returns the number of labellings rather than the actual labellings. Evaluates G. POLYA's function for the number of double cosets of two groups under SN - METHOD: reset GROUP to a composition list of cycle indices; th identity needs to be filled in; the function PERMCYCLEINDEX1 given a PERMUTATION returns a list of the sizes of the CYCLES of the perm, but CYCLES of SIZE one are not included; note also that each PERMUTATION in the original GROUP stands for 2*{LENGTH PERM:ORDER} permutations unless ORDER is NIL, in which case it stands for only one PERMUTATION. To compute the coeficient of x1↑n1* x2↑n2*...Xk↑nk in the polynomial - (sum for P in GROUP (product for C a cycle of P (x1↑|c|+x2↑|c|...+xk↑|c|)) SUBLIST is (n1 n2 ,,, nk) and NEWGROUP is the polynomial with redundancies in the sum and product eliminated by using composition lists)) (PROG [D C NEWGROUP (SUBLIST (LFROMCL SUBLIST (SETSIZE NODES] (SETQ C (for PERM in (SETQ NEWGROUP (CYCLEINDEX GROUP NODES)) sum (CDR PERM))) L1 [COND ((NULL (CDR SUBLIST)) (RETURN (IQUOTIENT (for X in NEWGROUP sum (CDR X)) C] (SETQ GROUP NEWGROUP) (SETQ NEWGROUP NIL) [for X in GROUP do (for S in (SUBSETS (CAR X) (CAR SUBLIST)) do (SETQ NEWGROUP (INSERTCL (ITIMES (CDR X) (CDR S)) (DIFFCL (CAR X) (CAR S)) NEWGROUP (FUNCTION (LAMBDA (X Y) (AND (NOT (EQUAL X Y)) (ORDERED X Y] (SETQ SUBLIST (CDR SUBLIST)) (GO L1]) (INSERT [LAMBDA (ITEM LST CMPR) (COND ((OR (NULL LST) (APPLY* CMPR ITEM (CAR LST))) (CONS ITEM LST)) (T (FRPLACD LST (INSERT ITEM (CDR LST) CMPR]) (SLTPSANDPINVS [LAMBDA (S P) (* S is a set of nodes; P is a permutation in the same same notation as in SLTPS. Checks if S is lexicographically less than P{S} at the same time it checks P↑-1 %. - METHOD: as in SLTPS, I starts at the largest element possible and goes down until S and P{S} disagree. Meanwhile, P↑-1{S} is accumulated in R; The complement of P↑-1{S} is accumulated in NR; a running check is made on the frst location where S and R disagree if that element is contained in R, then it is known that P↑-1{S} >> S; then it is only necessary to check S<<PS from then on; otherwise, if XI is the largest element for which S and R disagree, and XI is in S, then if all larger elements not in S are in NR, then we know that S>>P↑-1{S} and can return) (PROG (I R NR XI LARGERTHANXI) (SETQ R (SETQ NR 0)) [SETQ LARGERTHANXI (ALLLARGERELTS (SETQ XI (FIRST S] (SETQ I (LARGESTELT)) LOOP(COND [(CONTAINED I S) (COND [(CONTAINED (CAR P) S) (* S and PS agree, check P↑-1 S. I is in S so we can add (CAR P) to R) (SETQ R (UNIONSET (CAR P) S)) (COND ((CONTAINED (SETQ XI (FIRST (DISJOINTDIFF S R))) R) (RETURN (SLTPS I S P))) ((AND (CONTAINED (SETQ LARGERTHANXI (SETDIFF (ALLLARGERELTS XI) S)) NR) (CONTAINED XI NR)) (RETURN] (T (RETURN] ((CONTAINED (CAR P) S) (GO INVERSEONLY)) ((AND (CONTAINED XI (SETQ NR (UNIONSET (CAR P) NR))) (CONTAINED LARGERTHANXI NR)) (RETURN))) [COND ([OR (ELTLESSP (SETQ I (NEXTSMALLESTELT I)) S) (NULL (SETQ P (CDR P] (RETURN (QUOTE EQL] (GO LOOP) INVERSEONLY (SETQ NR (UNIONSET I NR)) LOOP2 (COND ((AND (CONTAINED XI NR) (CONTAINED LARGERTHANXI NR)) (RETURN))) [COND ((EQ NIL (SETQ P (CDR P))) (RETURN (QUOTE EQL] (SETQ I (NEXTSMALLESTELT I)) [COND ((CONTAINED I S) (SETQ R (UNION I R)) (COND ((CONTAINED (SETQ X1 (FIRST (DISJOINTDIFF S R))) R) (RETURN T))) (SETQ LARGERTHANXI (SETDIFF (ALLLARGERELTS XI) S] (GO LOOP2]) ) (DEFINEQ (MLG [LAMBDA (NODES GROUP LABELS) (FOR X IN (MANYLABELGRAPHTOP (LST.BINARY NODES) (LST.BINARYG GROUP) LABELS) DO (for Y in (CDR X) do (PRIN1 (CAR Y)) (PRIN1 (BINARY.LST (CDR Y))) (SPACES 2)) [COND ((LISTP (CAR (QUOTE PICTURE))) (for I from 1 to MAXI bind [(MAXI←(for II in PICTURE maximum (CADR II] do (TERPRI) (for P in PICTURE when (EQ I (CADR P)) bind ELT Y do (SETQ ELT (LST.BINARY (CAR P))) (SETQ Y X) (PROG NIL (COND ((NOT (NUMBERP (CAR P))) (GO L2))) (TAB (CDDR P)) L1 [COND ((NULL (SETQ Y (CDR Y))) (PRIN1 (QUOTE ?))) ((DISJOINT ELT (CDAR Y)) (GO L1)) (T (PRIN1 (CAAR Y] (GO L3) L2 (PRIN1 (CAR P)) L3] (TERPRI) (PRIN1 (QUOTE "REMAINING GROUP =")) (TAB 2) (PRINT (BINARY.LSTG (CAR X]) (ORBIT1 [LAMBDA (NODES GROUP) (* NODES is a set - GROUP is a GROUP of permutations on NODES - returns the subset of NODES which is the orbit of (FIRST NODES) under the permutations of GROUP) (PROG (CLASS) (SETQ CLASS (FIRST NODES)) [on old GROUP do (for PERM on (fetch CYCLES of (CAR GROUP)) bind CYCLE when (NOT (DISJOINT (SETQ CYCLE (CAR PERM)) CLASS)) do (SETQ CLASS (UNIONSET CYCLE CLASS] (RETURN (INTERSECT CLASS NODES]) (REDUCEGROUP [LAMBDA (GROUP NODES) (* returns the subgroup of GROUP which stableizes NODES as a set i.e. P s.t. P{NODES}=NODES) (ON OLD GROUP WHEN (for PERM on (fetch CYCLES of (CAR GROUP)) bind CYCLE X always (OR [EMPTY (SETQ X (INTERSECT NODES (SETQ CYCLE (CAR PERM] (EQSET X CYCLE))) COLLECT (CAR GROUP]) (ALLSUBSETS [LAMBDA (NODES NUMBER) (COND ((EQ 0 NUMBER) (LIST 0)) ((EMPTY NODES) NIL) ((EQ NUMBER 1) (LISTELT NODES)) (T (for NN from (SETSIZE NODES) to NUMBER by -1 join (for X in (ALLSUBSETS (PROGN (SETQ FN (FIRST NODES)) (SETQ NODES (REST NODES))) (SUB1 NUMBER)) rcollect (UNIONSET FN X]) (MANYLABELGRAPHTOP [LAMBDA (NODES GROUP LABELS) (* This is a special top level function which calls first POLYA and then MANYLABELGRAPH if the result of the POLYA function show that there are too many structures to calculate in a reasonable length of time, MANYLABELGRAPH is not called) (PROG (X SZNODES) (SETQ SZNODES (SETSIZE NODES)) [SORT LABELS (FUNCTION (LAMBDA (X Y) (ILESSP (CDR X) (CDR Y] (SETQ X (POLYA NODES GROUP LABELS)) [PRINT (CONS X (QUOTE (POSSIBLE SUBSTITUTION (S] [COND ((IGREATERP X 1000) (RETURN (PROGN (PRINT (QUOTE (THIS IS TOO MANY TO COMPUTE))) NIL] (SETQ X (MANYLABELGRAPH NODES GROUP LABELS)) [PRINT (CONS (LENGTH X) (QUOTE (ACTUAL SUBSTITUTIONS MADE] (RETURN X]) (MANYLABELGRAPH [LAMBDA (NODES LABELS GROUP) (* NODES: set to be LABELED - GROUP: permutation group on NODES - LABELS a list of dotted pairs of label,number - VAL: list of all nonequivalent labelings of NODES) (COND ((NULL LABELS) (LIST (create LABELING LABELED ← NIL))) [(NULL (CDR LABELS)) (for X in (LABELGRAPH NODES (CAR LABELS) GROUP) rcollect (create LABELING reusing X LABELED ←(LIST @@] (T (for L1 in (LABELGRAPH NODES (CAR LABELS) GROUP) join (for L2 in (MANYLABELGRAPH (SETDIFF NODES (fetch LABELED of L1)) (CDR LABELS) (fetch LSTRUC of L1)) rcollect (create LABELING reusing L2 LABELED ←(CONS (fetch LABELED of L1)@@]) (LABELCLASS [LAMBDA (CLASS NUMBER GROUP) (* CLASS a set - GROUP permutation GROUP on CLASS, such that all the elements of CLASS are equivalent under GROUP - NUMBER number of labels to attach to CLASS - VAL a list of labelings, as in LABELGRAPH) (COND [(IGREATERP (TWICE NUMBER) (SETSIZE CLASS)) (for X in (LABELCLASS CLASS (IDIFFERENCE (SETSIZE CLASS) NUMBER) GROUP) rcollect (CREATE LABELING REUSING X LABELED←(SETDIFF CLASS @@] ((ZEROP NUMBER) (CREATE LABELING LABELED← 0 LSTRUC←GROUP)) [(EQ NUMBER 1) (LIST (CREATE LABELING LABELED ←(SETQ CLASS (FIRST CLASS)) LSTRUC ←(REDUCEGROUP GROUP CLASS] (T (LABELGENCLASS CLASS NUMBER GROUP]) (LABELGENCLASS [LAMBDA (CLASS NUMBER GROUP) (* Calls LABELORBITS and then reduces the list by checking CANONICAL. Note that one could alternativly: - make LABELORBITS CHECK as it generates - the checking procedure could generate a badlist, and the badlist would be all that needed to be checked) (* Making use of SIMS, compute candidate labellings and check if they are CANONICAL) (for X in (LABELORBITS (ORBITS CLASS GROUP) NUMBER) when (CANONICAL X GROUP) collect (create LABELING LABELED ← X LSTRUC ←( REDUCEGROUP GROUP X]) (LABELORBITS [LAMBDA (ORBITS NUMBER) (* To make the LABELORBITS function independent of whether or not the labelings are checked as they are generated, or if they are all generated and then checked, LABELORBITS calls a function LOADD with each new labelling; LOADD can then either add that labelling to a list, or CHECK it first) (* ORBITS is a list of sets determined from the permutation group of the nodes to be labelled: the i-th set is the orbit of the i-th node under those permutations that leave node 1 through node (i-1) fixed - NUMBER is the number of labels to attach - returns a list of subsets of NODES with NUMBER elements, each of which satisfy the relation: - if the i-th node is not in S, then no element of the i-th orbit is in S I.e. the orbits of the stabelizer subgroups) (PROG (LORESULT) (LO1 ORBITS NUMBER 0) (RETURN LORESULT]) (LO1 [LAMBDA (ORBITS NUMBER SET) (COND ((MINUSP NUMBER) NIL) ((ZEROP NUMBER) (LOADD SET)) ((ILESSP (LENGTH ORBITS) NUMBER) NIL) [(EQLENGTH ORBITS NUMBER) (* exactly NUMBER orbits left; collect the first of each orbit) (LOADD (PROG ((RESULT SET)) [for X in ORBITS do (SETQ RESULT (UNIONSET RESULT (FIRST X] (RETURN RESULT] (T (* try labelling NUMBER orbits without labelling this one) (LO1 (CDR ORBITS) NUMBER SET) (* If you label (FIRST (CAR ORBITS)) then you must label all of (CAR ORBITS) - Since s<<ps => p (x) << p (Ox); here Ox is (CAR ORBITS), x is (FIRST OX) and if any of Ox is on, then x must be) (LO1 (for O in (CDR ORBITS) when (DISJOINT (FIRST O) (CAR ORBITS)) collect O) (IDIFFERENCE NUMBER (SETSIZE (CAR ORBITS))) (UNIONSET SET (CAR ORBITS]) (LOADD [LAMBDA (NODES) (SETQ LORESULT (CONS NODES LORESULT]) (ORBITS [LAMBDA (NODES GROUP) (* NODES is a set; GROUP is a permutation group on set - returns the list of orbits of the i-th node under those permutations leaving nodes 1 to i-1 fixed; i.e. the stabilizer subgroups of SIMS) (COND ((EMPTY NODES) NIL) ((NULL GROUP) (LISTELT NODES)) (T (CONS (ORBIT1 NODES GROUP) (ORBITS (REST NODES) (REDUCEGROUP GROUP (FIRST NODES]) (CANONICAL [LAMBDA (NODES GROUP) (EVERY GROUP (FUNCTION (LAMBDA (PERM) (COND [(NULL (fetch ORDER of PERM)) (SLTPS (LARGESTELT) NODES (CAR (fetch POWERS of PERM] (T (for P in (fetch POWERS of PERM) bind PRED while (NEQ (SETQ PRED (SLTPSANDPINVS NODES P)) (QUOTE EQL)) always PRED]) (SLTPS [LAMBDA (I S P) (* S is a set of nodes; P is a permutation represented as the list (P↑-1{X1},P↑-1{X2}...) - returns NIL if S is lexicographically less than P{S} and T otherwise. To determine lexicographic order: order the elements of S in the order X1, X2, ,,, XN. Order the elements of P{S} in the same way. Then S << P{S} if at the first element where they differ, the element of S is an earlier element than the corresponding element of P{S} - METHOD: as I goes from X1 to XN (LARGESTELT) by NEXTSMALLESTELT, P↑-1{I} in S iff I in P{S} Procede until it is no longer true that I in S => I in P{S} (I.e. P INVERSE{I}≠I at that point. If I is in S, then S>>P{S}; if I is in P{S} then S<<P{S})) (PROG NIL L1 [COND [(NOT (CONTAINED I S)) (COND ((CONTAINED (CAR P) S) (RETURN T)) (T (SETQ P (CDR P)) (SETQ I (NEXTSMALLESTELT I] ((NOT (CONTAINED (CAR P) S)) (RETURN NIL)) ((ELTLESSP (SETQ I (NEXTSMALLESTELT I)) S) (RETURN (QUOTE EQL))) (T (SETQ P (CDR P] (GO L1]) ) (RPAQQ INPUTMODE FUNCTION) STOP