Skip to content

Commit

Permalink
Combinatorica V0.9 workarounds and expanded tests (#1220)
Browse files Browse the repository at this point in the history 
SetPartitions[]` and `KSetPartitions[]` from Combinatorica workin V2.0
(In V.09 it is not broken, it is just altogether missing.)

So copy the 2.0.0 code into V0.9
  • Loading branch information
@rocky
rocky authored Dec 14, 2024
1 parent 2ae6b7d commit e2312db
Show file tree
Hide file tree
Showing 2 changed files with 126 additions and 21 deletions.
55 changes: 51 additions & 4 deletions mathics/packages/DiscreteMath/CombinatoricaV0.9.m
View file
Original file line number Diff line number Diff line change
Expand Up @@ -324,6 +324,9 @@

KSubsets::usage = "KSubsets[l,k] returns all subsets of set l containing exactly k elements, ordered lexicographically."

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."


K::usage = "K[n] creates a complete graph on n vertices. K[a,b,c,...,k] creates a complete k-partite graph of the prescribed shape."

LabeledTreeToCode::usage = "LabeledTreeToCode[g] reduces the tree g to its Prufer code."
Expand Down Expand Up @@ -492,6 +495,8 @@

SelfComplementaryQ::usage = "SelfComplementaryQ[g] returns True if graph g is self-complementary, meaning it is isomorphic to its complement."

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."

ShakeGraph::usage = "ShakeGraph[g,d] performs a random perturbation of the vertices of graph g, with each vertex moving at most a distance d from its original position."

ShortestPathSpanningTree::usage = "ShortestPathSpanningTree[g,v] constructs the shortest-path spanning tree originating from v, so that the shortest path in graph g from v to any other vertex is the path in the tree."
Expand Down Expand Up @@ -1061,6 +1066,38 @@
KSubsets[Rest[l],k]
]

(* From combinatorica 2.0.0 *)
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 = 512},
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[{}] := {{}}
SetPartitions[s_List] := Flatten[Table[KSetPartitions[s, i], {i, Length[s]}], 1]

SetPartitions[0] := {{}}
SetPartitions[n_Integer?Positive] := SetPartitions[Range[n]]

(* end *)

NextKSubset[set_List,subset_List] :=
Take[set,Length[subset]] /; (Take[set,-Length[subset]] === subset)

Expand Down Expand Up @@ -1096,10 +1133,18 @@
Partitions[n_Integer,1] := { Table[1,{n}] }
Partitions[_,0] := {}

(* FIXME: Below the If[] is added to fold in the rule:
Partitions[0,_] := { {} }
from above. That rule
is taking precedence over the above in Mathematica, but not in
Mathics3.
*)
Partitions[n_Integer,maxpart_Integer] :=
Join[
Map[(Prepend[#,maxpart])&, Partitions[n-maxpart,maxpart]],
Partitions[n,maxpart-1]
If[n<0, {}, (* rocky added If *)
Join[
Map[(Prepend[#,maxpart])&, Partitions[n-maxpart,maxpart]],
Partitions[n,maxpart-1]
]
]

NextPartition[p_List] := Join[Drop[p,-1],{Last[p]-1,1}] /; (Last[p] > 1)
Expand Down Expand Up @@ -3329,8 +3374,9 @@
IsomorphismQ,
Isomorphism,
Josephus,
KSubsets,
K,
KSetPartitions,
KSubsets,
LabeledTreeToCode,
LastLexicographicTableau,
LexicographicPermutations,
Expand Down Expand Up @@ -3414,6 +3460,7 @@
SamenessRelation,
SelectionSort,
SelfComplementaryQ,
SetPartitions,
ShakeGraph,
ShortestPathSpanningTree,
ShortestPath,
Expand Down
92 changes: 75 additions & 17 deletions test/package/test_combinatorica.py
View file
Original file line number Diff line number Diff line change
Expand Up @@ -489,12 +489,50 @@ def test_combinations_1_5():
def test_2_1_to_2_3():
for str_expr, str_expected, message in (
(
# 2.1.1 uses Partitions which is broken
# 2.1.2 Ferrers Diagrams can't be tested easily and robustly here
# easily
# 2.1.3 uses Partitions which is broken
"PartitionsP[10]",
"NumberOfPartitions[10]",
"Partitions[6]",
"{{6}, {5, 1}, {4, 2}, {4, 1, 1}, {3, 3}, "
"{3, 2, 1}, {3, 1, 1, 1}, {2, 2, 2}, {2, 2, 1, 1}, "
"{2, 1, 1, 1, 1}, {1, 1, 1, 1, 1, 1}}",
"Generating Partitions 2.1.1, Page 52",
),
(
"Partitions[6, 3]",
"{{3, 3}, {3, 2, 1}, {3, 1, 1, 1}, {2, 2, 2}, "
"{2, 2, 1, 1}, {2, 1, 1, 1, 1}, {1, 1, 1, 1, 1, 1}}",
"Generating Partitions 2.1.1, Page 52",
),
(
"Length[Partitions[10]]",
"42",
"Generating Partitions 2.1.1, Page 52",
),
# 2.1.2 Ferrers Diagrams can't be tested easily and robustly here
# easily
# (
# "(p=Table[1,{6}]; Table[p=NextPartition[p], {NumberOfPartitions[6]}])",
# "{{6}, {5, 1}, {4, 2}, {4, 1, 1}, {3, 3}, "
# "{3, 2, 1}, {3, 1, 1, 1}, {2, 2, 2}, {2, 2, 1, 1}, "
# "{2, 1, 1, 1, 1}, {1, 1, 1, 1, 1, 1}}",
# "Generating Partitions 2.1.1, Page 52",
# ),
(
"Select[Partitions[7], (Apply[And,Map[OddQ, #]])&]",
"{{7}, {5, 1, 1}, {3, 3, 1}, {3, 1, 1, 1, 1}, " "{1, 1, 1, 1, 1, 1, 1}}",
"Bijections between Partitions 2.1.3, Page 56",
),
(
"Select[Partitions[7], (Length[#] == Length[Union[#]])&]",
"{{7}, {6, 1}, {5, 2}, {4, 3}, {4, 2, 1}}",
"Bijections between Partitions 2.1.3, Page 56",
),
(
"DurfeeSquare[p=RandomPartition[20]] == DurfeeSquare[TransposePartition[p]]",
"True",
"Counting Partitions 2.1.3, Page 57",
),
(
"{PartitionsP[10], NumberOfPartitions[10]}",
"{42, 42}",
"Counting Partitions 2.1.4, Page 57",
),
(
Expand All @@ -503,14 +541,24 @@ def test_2_1_to_2_3():
"Random Compositions 2.2.1, Page 60",
),
(
"TableauQ[{{1,2,5}, {3,4,5}, {6}}]",
"True",
"Young Tableau 2.3, Page 64",
"Compositions[6,3]",
"{{0, 0, 6}, {0, 1, 5}, {0, 2, 4}, {0, 3, 3}, "
"{0, 4, 2}, {0, 5, 1}, {0, 6, 0}, {1, 0, 5}, {1, 1, 4}, "
"{1, 2, 3}, {1, 3, 2}, {1, 4, 1}, {1, 5, 0}, {2, 0, 4}, "
"{2, 1, 3}, {2, 2, 2}, {2, 3, 1}, {2, 4, 0}, {3, 0, 3}, "
"{3, 1, 2}, {3, 2, 1}, {3, 3, 0}, {4, 0, 2}, {4, 1, 1}, "
"{4, 2, 0}, {5, 0, 1}, {5, 1, 0}, {6, 0, 0}}",
"Generating Compositions 2.2.2, Page 61",
),
(
"TableauQ[{{1,2,5,9,10}, {5,4,7,13}, {4,8,12},{11}}]",
"False",
"Young Tableau 2.3, Page 64",
"(c = {0, 0, 6}; Table[c = NextComposition[c], {28}])",
"{{6, 0, 0}, {5, 1, 0}, {4, 2, 0}, {3, 3, 0}, "
"{2, 4, 0}, {1, 5, 0}, {0, 6, 0}, {5, 0, 1}, {4, 1, 1}, "
"{3, 2, 1}, {2, 3, 1}, {1, 4, 1}, {0, 5, 1}, {4, 0, 2}, "
"{3, 1, 2}, {2, 2, 2}, {1, 3, 2}, {0, 4, 2}, {3, 0, 3}, "
"{2, 1, 3}, {1, 2, 3}, {0, 3, 3}, {2, 0, 4}, {1, 1, 4}, "
"{0, 2, 4}, {1, 0, 5}, {0, 1, 5}, {0, 0, 6}}",
"Generating Compositions 2.2.2, Page 62",
),
# Need to not evaluate expected which reformats \n's
# (
Expand All @@ -522,6 +570,16 @@ def test_2_1_to_2_3():
# "False",
# "Young Tableau 2.3, Page 63",
# ),
(
"TableauQ[{{1,2,5}, {3,4,5}, {6}}]",
"True",
"Young Tableau 2.3, Page 64",
),
(
"TableauQ[{{1,2,5,9,10}, {5,4,7,13}, {4,8,12},{11}}]",
"False",
"Young Tableau 2.3, Page 64",
),
):
check_evaluation(str_expr, str_expected, message)

Expand Down Expand Up @@ -569,11 +627,11 @@ def test_combinatorica_rest():
"2",
"BinarySearch - find where key is a list",
),
# (
# "SetPartitions[3]",
# "{{{1, 2, 3}}, {{1}, {2, 3}}, {{1, 2}, {3}}, {{1, 3}, {2}}, {{1}, {2}, {3}}}",
# "SetPartitions"
# ),
(
"SetPartitions[3]",
"{{{1, 2, 3}}, {{1}, {2, 3}}, {{1, 2}, {3}}, {{1, 3}, {2}}, {{1}, {2}, {3}}}",
"SetPartitions",
),
(
"TransposePartition[{8, 6, 4, 4, 3, 1}]",
"{6, 5, 5, 4, 2, 2, 1, 1}",
Expand Down

0 comments on commit e2312db

Please sign in to comment.