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