4
$\begingroup$

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.

$\endgroup$
10
  • 2
    $\begingroup$ 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]. $\endgroup$
    – kirma
    Feb 7, 2023 at 14:00
  • 1
    $\begingroup$ You need to sort the list lexicographically as "Subsets" does. $\endgroup$ Feb 7, 2023 at 14:01
  • 2
    $\begingroup$ First /@ Gather[s3, DisjointQ] ? $\endgroup$
    – Syed
    Feb 7, 2023 at 14:13
  • 1
    $\begingroup$ Could KSetPartition be of some use? $\endgroup$
    – Syed
    Feb 7, 2023 at 14:43
  • 2
    $\begingroup$ Related link: partition-a-set-into-subsets-of-size-k $\endgroup$
    – chyanog
    Feb 8, 2023 at 3:07

1 Answer 1

6
$\begingroup$

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}}} *)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.