Merge pull request #1049 from mathics/combinatorica-use-v9

Combinatorica use v9

Author: rocky

mathics/packages/DiscreteMath/CombinatoricaLite.m

@@ -25,7 +25,30 @@
 authors, Wolfram Research, or Cambridge University Press, their licensees,
 distributors and dealers shall in no event be liable for any indirect,
 incidental, or consequential damages.
+ *)
 
+(* :History:
+    Version 2.1 updated to Mathematica 6 by John M. Novak, 2006.
+    Version 2.0 most code rewritten Sriram V. Pemmaraju, 2000-2002
+            Too many changes to describe here. Read the book!
+	Version 1.1 modification by ECM, March 1996.
+		Replaced K with CompleteGraph because K is now the
+			default generic name for the summation index in
+			symbolic sum.
+		Added CombinatorialFunctions.m and Permutations.m to
+			BeginPackage, and commented out CatalanNumber,
+			PermutationQ, ToCycles, FromCycles, and
+			RandomPermutation so there would be no shadowing of
+			symbols among the DiscreteMath packages.
+		Replaced old BinarySearch with new code by Paul Abbott
+			correctly implementing binary search.
+        Version 1.0 by Steven S. Skiena, April 1995.
+        Version .9 by Steven S. Skiena, February 1992.
+	Version .8 by Steven S. Skiena, July 1991.
+	Version .7 by Steven S. Skiena, January 1991.
+	Version .6 by Steven S. Skiena, June 1990.
+ *)
+(*
 And for the 0.6 version:
 		Version 0.6   6/11/90   Beta Release
 		Copyright (c) 1990 by Steven S. Skiena
@@ -284,6 +307,8 @@
 	]
  *)
 
+SetPartitions::usage = "SetPartitions[set] returns the list of set partitions of set. SetPartitions[n] returns the list of set partitions of {1, 2, ..., n}. If all set partitions with a fixed number of subsets are needed use KSetPartitions."
+
 SetPartitions[{}] := {{}}
 SetPartitions[s_List] := Flatten[Table[KSetPartitions[s, i], {i, Length[s]}], 1]
 

mathics/packages/DiscreteMath/CombinatoricaV0.9.m

@@ -595,6 +595,9 @@
 PermutationQ[p_List] := (Sort[p] == Range[Length[p]])
 
 Permute[l_List,p_?PermutationQ] := l [[ p ]]
+Permute[l_List,p_List] := Map[ (Permute[l,#])&, p] /; (Apply[And, Map[PermutationQ, p]])
+
+(* Section 1.1.1 Lexicographically Ordered Permutions, Pages 3-4 *)
 
 LexicographicPermutations[{l_}] := {{l}}
 
@@ -616,6 +619,8 @@
 		]
 	]
 
+(* Section 1.1.2 Ranking and Unranking Permutations, Pages 5-6 *)
+
 RankPermutation[{1}] = 0
 
 RankPermutation[p_?PermutationQ] := (p[[1]]-1) (Length[Rest[p]]!) +
@@ -635,6 +640,8 @@
 NextPermutation[p_?PermutationQ] :=
 	NthPermutation[ RankPermutation[p]+1, Sort[p] ]
 
+(* Section 1.1.3 RandomPermutations, Pages 6-7 *)
+
 RandomPermutation1[n_Integer?Positive] :=
 	Map[ Last, Sort[ Map[({RandomInteger[],#})&,Range[n]] ] ]
 
@@ -650,6 +657,7 @@
 
 RandomPermutation[n_Integer?Positive] := RandomPermutation1[n]
 
+(* Section 1.1.4 Permutation from Transpostions, Page 11 *)
 MinimumChangePermutations[l_List] :=
 	Module[{i=1,c,p=l,n=Length[l],k},
 		c = Table[1,{n}];
@@ -667,6 +675,7 @@
 		]
 	]
 
+(* Section 1.1.5 Backtracking and Distict Permutations, Page 12-13 *)
 Backtrack[space_List,partialQ_,solutionQ_,flag_:One] :=
 	Module[{n=Length[space],all={},done,index,v=2,solution},
 		index=Prepend[ Table[0,{n-1}],1];
@@ -708,6 +717,8 @@
 		]
 	]
 
+(* Section 1.1.6 Sorting and Searching, Page 14-16 *)
+
 MinOp[l_List,f_] :=
 	Module[{min=First[l]},
 		Scan[ (If[ Apply[f,{#,min}], min = #])&, l];
@@ -738,6 +749,7 @@
 		]
 	]
 
+(* Section 1.2.1 Multiplying Permutations, Page 17 *)
 MultiplicationTable[elems_List,op_] :=
 	Module[{i,j,n=Length[elems],p},
 		Table[
@@ -747,12 +759,14 @@
 		]
 	]
 
+(* Section 1.2.2 The Inverse of a Permutation, Page 18 *)
 InversePermutation[p_?PermutationQ] :=
 	Module[{inverse=p, i},
 		Do[ inverse[[ p[[i]] ]] = i, {i,Length[p]} ];
 		inverse
 	]
 
+(* Section 1.2.3 The Equivalence Relation and Classesn, Page 18-19 *)
 EquivalenceRelationQ[r_?SquareMatrixQ] :=
 	ReflexiveQ[r] && SymmetricQ[r] && TransitiveQ[r]
 EquivalenceRelationQ[g_Graph] := EquivalenceRelationQ[ Edges[g] ]
@@ -784,6 +798,7 @@
 		]
 	] /; perms != {}
 
+(* 1.2.4 The Cycle Structure of Permutations; Pages 20-21  *)
 ToCycles[p1_?PermutationQ] :=
 	Module[{p=p1,m,n,cycle,i},
 		Select[
@@ -812,6 +827,7 @@
 		p
 	]
 
+(* 1.2.4 The Cycle Structure of Permutations, Hiding Cycles; Page 22  *)
 HideCycles[c_List] :=
 	Flatten[
 		Sort[
@@ -832,6 +848,7 @@
 		Append[cycles,Take[p,{start,end-1}]]
 	]
 
+(* 1.2.4 The Cycle Structure of Permutations, Counting Cycles; Page 23  *)
 NumberOfPermutationsByCycles[n_Integer,m_Integer] := (-1)^(n-m) StirlingS1[n,m]
 
 StirlingFirst[n_Integer,m_Integer] := StirlingFirst1[n,m]
@@ -1000,8 +1017,11 @@
 		Join[ prev, Map[(Append[#,First[l]])&,Reverse[prev]] ]
 	]
 
+(* We have a builtin that does this.
+GrayCode doesn't work?
 Subsets[l_List] := GrayCode[l]
 Subsets[n_Integer] := GrayCode[Range[n]]
+*)
 
 LexicographicSubsets[l_List] := LexicographicSubsets[l,{{}}]
 
@@ -3131,6 +3151,38 @@
 		(aj < Max[b])
 	]
 
+KSetPartitions::usage = "KSetPartitions[set, k] returns the list of set partitions of set with k blocks. KSetPartitions[n, k] returns the list of set partitions of {1, 2, ..., n} with k blocks. If all set partitions of a set are needed, use the function SetPartitions."
+KSetPartitions[{}, 0] := {{}}
+KSetPartitions[s_List, 0] := {}
+KSetPartitions[s_List, k_Integer] := {} /; (k > Length[s])
+KSetPartitions[s_List, k_Integer] := {Map[{#} &, s]} /; (k === Length[s])
+KSetPartitions[s_List, k_Integer] :=
+       Block[{$RecursionLimit = Infinity},
+             Join[Map[Prepend[#, {First[s]}] &, KSetPartitions[Rest[s], k - 1]],
+                  Flatten[
+                     Map[Table[Prepend[Delete[#, j], Prepend[#[[j]], s[[1]]]],
+                              {j, Length[#]}
+                         ]&,
+                         KSetPartitions[Rest[s], k]
+                     ], 1
+                  ]
+             ]
+       ] /; (k > 0) && (k < Length[s])
+
+KSetPartitions[0, 0] := {{}}
+KSetPartitions[0, k_Integer?Positive] := {}
+KSetPartitions[n_Integer?Positive, 0] := {}
+KSetPartitions[n_Integer?Positive, k_Integer?Positive] := KSetPartitions[Range[n], k]
+
+SetPartitions::usage = "SetPartitions[set] returns the list of set partitions of set. SetPartitions[n] returns the list of set partitions of {1, 2, ..., n}. If all set partitions with a fixed number of subsets are needed use KSetPartitions."
+
+SetPartitions[{}] := {{}}
+SetPartitions[s_List] := Flatten[Table[KSetPartitions[s, i], {i, Length[s]}], 1]
+
+SetPartitions[0] := {{}}
+SetPartitions[n_Integer?Positive] := SetPartitions[Range[n]]
+
+
 End[]
 
 Protect[