Skip to content

Combinatorica use v9 #1049

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
rocky merged 5 commits into from
Dec 17, 2020
Merged

Combinatorica use v9 #1049

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
8239336
Use V0.9 in testing. It seems more complete
rocky Dec 15, 2020
4445408
More tests
rocky Dec 15, 2020
d436c1d
Start adding book section correspondences
rocky Dec 16, 2020
1a47243
Progress to page 23
rocky Dec 17, 2020
0b7bcc4
Extend /; testing
rocky Dec 17, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
25 changes: 25 additions & 0 deletions mathics/packages/DiscreteMath/CombinatoricaLite.m
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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]

Expand Down
52 changes: 52 additions & 0 deletions mathics/packages/DiscreteMath/CombinatoricaV0.9.m
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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}}

Expand All @@ -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]]!) +
Expand All @@ -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]] ] ]

Expand All @@ -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}];
Expand All @@ -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];
Expand Down Expand Up @@ -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];
Expand Down Expand Up @@ -738,6 +749,7 @@
]
]

(* Section 1.2.1 Multiplying Permutations, Page 17 *)
MultiplicationTable[elems_List,op_] :=
Module[{i,j,n=Length[elems],p},
Table[
Expand All @@ -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] ]
Expand Down Expand Up @@ -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[
Expand Down Expand Up @@ -812,6 +827,7 @@
p
]

(* 1.2.4 The Cycle Structure of Permutations, Hiding Cycles; Page 22 *)
HideCycles[c_List] :=
Flatten[
Sort[
Expand All @@ -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]
Expand Down Expand Up @@ -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,{{}}]

Expand Down Expand Up @@ -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[
Expand Down
Loading