perm filename POLYA[PAT,LMM] blob sn#099907 filedate 1974-04-29 generic text, type T, neo UTF8

(FILECREATED "29-APR-74 03:10:09" POLYA 6633 changes to: POLYAFNS) (DEFINEQ (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]) (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]) (SETSIZE [LAMBDA (X) (ADD1 (WHILE [NOT (EMPTY (SETQ X (REST X] SUM 1]) (REST [LAMBDA (X) (LOGAND X (SUB1 X]) (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]) (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]) (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]) (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]) (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]) (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]) ) (LISPXPRINT (QUOTE POLYAFNS) T) (RPAQQ POLYAFNS (POLYA LFROMCL SETSIZE REST INSERT CYCLEINDEX PCYCLEINDEX ORDERED SUBSETS TAKEN DIFFCL)) (LISPXPRINT (QUOTE POLYAVARS) T) (RPAQQ POLYAVARS ((PROP MACRO SETSIZE REST SETSIZE))) (DEFLIST(QUOTE( [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] [REST ((X) (LOC (ASSEMBLE NIL (CQ (VAG X)) (HRREI 2 , -1) (ADD 2 , 1) (AND 1 , 2] [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] ))(QUOTE MACRO)) (PROGN (QUOTE JUSTEVALUATE) (FILEMAP (NIL (83 5723 (POLYA 95 . 1997) (LFROMCL 2001 . 2215) (SETSIZE 2219 . 2297) (REST 2301 . 2346) (INSERT 2350 . 2535) (CYCLEINDEX 2539 . 2920) ( PCYCLEINDEX 2924 . 3371) (ORDERED 3375 . 3371) (SUBSETS 3375 . 5201) (TAKEN 5205 . 5392) (DIFFCL 5396 . 5720))))) STOP