4

Edits: In fact it is a set partition problem.

I have a set as follows:

s = {"a", "b", "c", "d", "e", "f"}

I want to divide the set into 2 groups such that each group has exactly $3$ elements. We want to generate all solutions. Note that we treat ({"a", "b", "c"}|{"d", "e", "f"}) and ({"d", "e", "f"}|{"a", "b", "c"}) as the same solution.

So first I used the Subsets function to generate all 3-subsets and then filtered for duplicate solutions.

s3 = Subsets[s, {3}]
DeleteDuplicates[s3, Union[#1] == Union[Complement[s, #2]] &]

Out[*]: {{"a", "b", "c"}, {"a", "b", "d"}, {"a", "b", "e"}, {"a", "b", 
  "f"}, {"a", "c", "d"}, {"a", "c", "e"}, {"a", "c", "f"}, {"a", "d", 
  "e"}, {"a", "d", "f"}, {"a", "e", "f"}}

But I feel like the solution is a bit inefficient. In fact, we only need half of all 3-subsets. I wonder if we can only keep one representative among same solutions when generating the 3-subsets.

Edits: In fact, the problem can be generalized as follows: Given a list of $n$ elements, partition it into $m$ groups, and generate all possible solutions. Similarly, same solutions are generated only once.

licheng
  • 2,029
  • 1
  • 7
  • 15
  • Note that Union in your code is not needed. "Subsets" does not generate duplicate list elements. – Daniel Huber Feb 07 '23 at 13:27
  • Thanks. I am worried about the following situation: the oupput of Complement[{"a", "b", "c", "d", "e", "f"}, {"a", "b", "c"}] == {"e", "d", "f"} is False. But the output of Complement[{"a", "b", "c", "d", "e", "f"}, {"a", "b", "c"}] == {"d", "e", "f"} is True. In fact they should both return True in my expectation. – licheng Feb 07 '23 at 13:34
  • 2
    I believe that in this very specific case you get the set you are looking for by taking half of the subset in order Subsets provides them: Subsets[s, {Length[s]/2}, Binomial[Length[s], Length[s]/2]/2]. – kirma Feb 07 '23 at 14:00
  • 1
    You need to sort the list lexicographically as "Subsets" does. – Daniel Huber Feb 07 '23 at 14:01
  • 2
    First /@ Gather[s3, DisjointQ] ? – Syed Feb 07 '23 at 14:13
  • @Syed It is indeed more concise, but it is still unavoidable to generate all the 3-subsets. I am thinking if there is a way to generate them in some order, by only generating the representative elements (we know it is half of all the 3-subsets.) but not all. (As kirma observed) – licheng Feb 07 '23 at 14:19
  • 1
    Could KSetPartition be of some use? – Syed Feb 07 '23 at 14:43
  • @Syed Thank you very much. KSetPartitions[{a, b, c, d, e, f}, 2] provides all 2-partitions, which is great and avoids the above repeated scenario; however, it also generates too many; for exmaple, {{a}, {b, c, d, e, f}} is included. We have requirements for the number of elements in each group. If there could be more flexible options, that would be even better – licheng Feb 07 '23 at 14:56
  • 1
    What values of $n$ and $m$ are of interest? And rather than a "feeling" of things being inefficient, consider using AbsoluteTiming or RepeatedTiming to evaluate the alternatives. – JimB Feb 07 '23 at 17:26
  • 2
    Related link: partition-a-set-into-subsets-of-size-k – chyanog Feb 08 '23 at 03:07

1 Answers1

6

One way is to place the first element in each of the subsets formed from s-1 of the remaining elements, find complements, and recursively subdivvy those complements.

subsetSubsets[set_, s_ /; s <= 0] := {}
subsetSubsets[set_, s_] /; s > Length[set] := {set}
subsetSubsets[set_, s_Integer] := Module[
  {first, rest, subsets, firstsets, complements},
  subsets = Subsets[Rest[set], {s - 1}];
  firstsets = Map[Append[#, First[set]] &, subsets];
  complements = Map[Complement[set, #] &, firstsets];
  Flatten[Table[
    Map[Prepend[#, firstsets[[j]]] &, 
     subsetSubsets[complements[[j]], s]]
    , {j, Length[firstsets]}], 1]
  ]

Examples:

subsetSubsets[Range[6], 3]

(* Out[41]= {{{2, 3, 1}, {5, 6, 4}}, {{2, 4, 1}, {5, 6, 3}}, {{2, 5, 
   1}, {4, 6, 3}}, {{2, 6, 1}, {4, 5, 3}}, {{3, 4, 1}, {5, 6, 
   2}}, {{3, 5, 1}, {4, 6, 2}}, {{3, 6, 1}, {4, 5, 2}}, {{4, 5, 
   1}, {3, 6, 2}}, {{4, 6, 1}, {3, 5, 2}}, {{5, 6, 1}, {3, 4, 2}}} *)


subsetSubsets[Range[6], 2]


(* Out[42]= {{{2, 1}, {4, 3}, {6, 5}}, {{2, 1}, {5, 3}, {6, 4}}, {{2, 
   1}, {6, 3}, {5, 4}}, {{3, 1}, {4, 2}, {6, 5}}, {{3, 1}, {5, 2}, {6,
    4}}, {{3, 1}, {6, 2}, {5, 4}}, {{4, 1}, {3, 2}, {6, 5}}, {{4, 
   1}, {5, 2}, {6, 3}}, {{4, 1}, {6, 2}, {5, 3}}, {{5, 1}, {3, 2}, {6,
    4}}, {{5, 1}, {4, 2}, {6, 3}}, {{5, 1}, {6, 2}, {4, 3}}, {{6, 
   1}, {3, 2}, {5, 4}}, {{6, 1}, {4, 2}, {5, 3}}, {{6, 1}, {5, 2}, {4,
    3}}} *)
Daniel Lichtblau
  • 58,970
  • 2
  • 101
  • 199