2
$\begingroup$

(Unfortunately, I couldn't change the bounty message. By n above I meant the number of sublists.)

How can I group a list of integers from 1 to 10 into 3 sublists of arbitrary length (but not zero)? I want to return all possible groups. I know Partition and Subsets, but couldn't use them successfully to do the job. Below are some possible splits:

{{1, 2, 3}, {4, 5, 6, 7}, {8, 9, 10}}
{{1, 2, 3, 4}, {5, 6, 7}, {8, 9, 10}}
{{3, 4}, {1, 2, 5, 6, 7}, {8, 9, 10}}
{{3, 8}, {1, 2, 5, 6, 7}, {4, 9, 10}}

Basically, I want to split integers from 1 to 10 into 3 sublists, ensuring that each number appears in only one sublist.

The bigger problem is that I want to divide the list into 3 sublists as above with one more condition: 1 and 2 are not in the same sublist, similar for 3 and 4, 5 and 6, 7 and 8, 9 and 10. I think this filtering part is easier, and I can do it myself by using MemberQ to check. However, if you know a better way to do it, please share.

This is my brute force method. There are probably some duplicates, but it's not efficient and very slow. I haven't filtered to remove cases like 1 and 2 in the same group yet.

ClearAll[convertToIndexedVariables];
convertToIndexedVariables[list_] := Module[{index}, index = 1;
  Table[Table[
    ToExpression["a" <> ToString[index++]], {j, list[[i]]}], {i, 
    Length[list]}]]
sumsWithTotal10 = {a, b, c} /. 
     Solve[Total[{a, b, c}] == 10 && a > 0 && b > 0 && c > 0, {a, b, 
       c}, Integers] // Map[Sort] // DeleteDuplicates;
allList = convertToIndexedVariables /@ sumsWithTotal10;
permutation = Permutations[Range[10]];
allList /. Thread[{a1, a2, a3, a4, a5, a6, a7, a8, a9, a10} -> #] & /@
   permutation // Flatten[#, 1] &

EDIT: Unfortunately, I couldn't change the bounty message. By 'n,' I meant the number of sublists.

$\endgroup$
6
  • 1
    $\begingroup$ The possible splits you show don't follow the exclusion criteria mentioned on the last line. $\endgroup$
    – Syed
    Commented Apr 3 at 13:01
  • $\begingroup$ @Syed I think you are refering to the "bigger problem" part. I think that part I can remove myself as I can use MemberQ or something like that. It would be nice if you or others can address that part but I think I can do it. The difficult part I think is to split it into 3 sublists. $\endgroup$
    – internet
    Commented Apr 3 at 13:14
  • $\begingroup$ Unfortunately, I couldn't change the bounty message. By 'n' I meant the number of sublists. $\endgroup$
    – internet
    Commented Apr 22 at 7:08
  • $\begingroup$ Are you trying to efficiently enumerate the sequence with length StirlingS2? Or does ordering within each sublist matter? $\endgroup$
    – Greg Hurst
    Commented Apr 22 at 17:39
  • 1
    $\begingroup$ @GregHurst ordering doesn't matter. I found that KSetPartitions is exactly what I was looking for. $\endgroup$
    – internet
    Commented Apr 22 at 18:23

6 Answers 6

2
$\begingroup$

Does this exactly correctly solve your problem and your bigger problem?

t1=Table[IntegerDigits[i,3,10],{i,0,3^10-1}];Length[t1](*59049*)
t2=Select[t1,Length[Union[#]]==3&];Length[t2](*55980*)
t3=DeleteCases[t2,
  {i_,i_,_,_,_,_,_,_,_,_}|
  {_,_,i_,i_,_,_,_,_,_,_}|
  {_,_,_,_,i_,i_,_,_,_,_}|
  {_,_,_,_,_,_,i_,i_,_,_}|
  {_,_,_,_,_,_,_,_,i_,i_}];Length[t3](*7680*)
r=Range[10];
f[v_]:=(s=Transpose[{v,r}];{
  Map[Last,Select[s,#[[1]]==1&]],
  Map[Last,Select[s,#[[1]]==2&]],
  Map[Last,Select[s,#[[1]]==3&]]});
t4=Map[f,t3+1];Length[t4](*7680*)
result=Union[Map[Sort,t4]];Length[result](*1280*)

That uses base-3 math to generate all 3^10==59049 indices of triples of subsets, eliminates those which do not include three nonempty subsets leaving 55980, eliminates those containing 1,2 or 3,4 or 5,6 or 7,8 or 9,10 leaving 7680 and then uses those indices to construct your list of triple lists. Eliminating duplicates leaves 1280 triples.

Here is a sample of some of the triples from result

{{{1, 3, 5, 7, 9}, {2, 4, 6, 8}, {10}}, {{1, 3, 5, 7}, {2, 4, 6, 8, 9}, {10}},
 {{1, 3, 5, 7, 10}, {2, 4, 6, 8}, {9}}, {{1, 3, 5, 7}, {2, 4, 6, 8, 10}, {9}},
 {{1, 3, 5, 7, 9}, {2, 4, 6, 10}, {8}}, {{1, 3, 5, 7, 9}, {2, 4, 6}, {8, 10}},
 {{1, 3, 5, 7, 10}, {2, 4, 6, 9}, {8}}, {{1, 3, 5, 7}, {2, 4, 6, 9}, {8, 10}},
 {{1, 3, 5, 7, 10}, {2, 4, 6}, {8, 9}}, {{1, 3, 5, 7}, {2, 4, 6, 10}, {8, 9}},
 {{1, 3, 5, 8, 9}, {2, 4, 6, 7}, {10}}, {{1, 3, 5, 8}, {2, 4, 6, 7, 9}, {10}},
 {{1, 3, 5, 8, 10}, {2, 4, 6, 7}, {9}}, {{1, 3, 5, 8}, {2, 4, 6, 7, 10}, {9}},
 {{1, 3, 5, 9}, {2, 4, 6, 7, 10}, {8}}, {{1, 3, 5, 9}, {2, 4, 6, 7}, {8, 10}},
 {{1, 3, 5, 10}, {2, 4, 6, 7, 9}, {8}}, {{1, 3, 5}, {2, 4, 6, 7, 9}, {8, 10}},
 {{1, 3, 5, 10}, {2, 4, 6, 7}, {8, 9}}, {{1, 3, 5}, {2, 4, 6, 7, 10}, {8, 9}},
 {{1, 3, 5, 8, 9}, {2, 4, 6, 10}, {7}}, {{1, 3, 5, 8, 9}, {2, 4, 6}, {7, 10}},
 {{1, 3, 5, 8, 10}, {2, 4, 6, 9}, {7}}, {{1, 3, 5, 8}, {2, 4, 6, 9}, {7, 10}},
 {{1, 3, 5, 8, 10}, {2, 4, 6}, {7, 9}}, {{1, 3, 5, 8}, {2, 4, 6, 10}, {7, 9}},
 {{1, 3, 5, 9}, {2, 4, 6, 8, 10}, {7}}, {{1, 3, 5, 9}, {2, 4, 6, 8}, {7, 10}},
 {{1, 3, 5, 10}, {2, 4, 6, 8, 9}, {7}}, {{1, 3, 5}, {2, 4, 6, 8, 9}, {7, 10}},
 {{1, 3, 5, 10}, {2, 4, 6, 8}, {7, 9}}, {{1, 3, 5}, {2, 4, 6, 8, 10}, {7, 9}},
 {{1, 3, 5, 7, 9}, {2, 4, 8, 10}, {6}}, {{1, 3, 5, 7, 9}, {2, 4, 8}, {6, 10}},
 {{1, 3, 5, 7, 10}, {2, 4, 8, 9}, {6}}, {{1, 3, 5, 7}, {2, 4, 8, 9}, {6, 10}},
 {{1, 3, 5, 7, 10}, {2, 4, 8}, {6, 9}}, {{1, 3, 5, 7}, {2, 4, 8, 10}, {6, 9}},
 {{1, 3, 5, 7, 9}, {2, 4, 10}, {6, 8}}, {{1, 3, 5, 7, 9}, {2, 4}, {6, 8, 10}},...

Please test this brutally to try to make certain that it includes every split that it should and no others. It does include {1, 10} and {5, 7}

$\endgroup$
6
  • $\begingroup$ Thanks. The orders of the 3 sublists and the elements inside them don't matter, so I tried deleting duplicates as well, reducing it to 1280 cases (Sort /@ Map[Sort, result, {2}] // DeleteDuplicates // Length). The result looks good, but I'm still trying to understand the method. For example, why base 3? I understand that it's related to the 3 groups, but I don't quite grasp the motivation. Additionally, DeleteCases seems to only delete cases where elements match. So how can it delete a case like {1,2,3,4,5,6,7,8,9,10}? EDIT: I actually didn't remove any duplicates! $\endgroup$
    – internet
    Commented Apr 4 at 4:01
  • $\begingroup$ Why base 3? Because every number has to go into one of three sublists. Thus 0 says put the number in the first sublist, 1 says second and 2 says third sublist. Notice that the actual numbers are not in that list yet, it is only which sublist to put the number in. The numbers to put in the list don't appear until the t4=Map[ step. You can display the first few hundred elements of t1,t2,t3,t4 and try to see what is being done at each step of this. Or you can ask more questions. (You don't want to see the much longer much worse methods I tried before I got to this. Still should be better) $\endgroup$
    – Bill
    Commented Apr 4 at 5:08
  • $\begingroup$ I just updated my post with my brute force method. Could you take a look to ensure that there is no misunderstanding about what I want to achieve? $\endgroup$
    – internet
    Commented Apr 4 at 5:53
  • $\begingroup$ I think I'm starting to see it as you mentioned, going from 0, 1, 2 to sublists 1, 2, 3. That is a very good approach. $\endgroup$
    – internet
    Commented Apr 4 at 6:37
  • $\begingroup$ f[s1_]:=(g[s2_]:={s1,s2,Complement[Range[10],s1,s2]};cs1=Complement[Range[10],s1]; Map[g,Subsets[cs1,{1,Length[cs1]-1}]]);t1=Join@@Map[f,Subsets[Range[10],{1,10-2}]] Still needs to be simpler. Still studying your solution. $\endgroup$
    – Bill
    Commented Apr 4 at 17:22
3
$\begingroup$

I just found that this can easily be done using KSetPartitions (an external package).

Quiet @ Needs["Combinatorica`"];

KSetPartitions[Range[10], 3]
$\endgroup$
2
$\begingroup$

I have answered a similar question almost 6 years ago. Check this link for more details. However, there is a slight difference in the question here, that is, it does not restrict to a certain grouping of elements. So, I modified the code a bit as follows.

lst = Range[10];
allGroupings = IntegerPartitions[10, {3}];
groups = Flatten /@ Outer[ConstantArray[Unique[], #] &, allGroupings, 2];
groupPermutations = Flatten[Permutations[#] & /@ groups, 1];
combs = Keys@GatherBy[#, Last] & /@ (Thread[lst -> #] & /@ groupPermutations)//DeleteDuplicates;
RandomSample[combs, 10]

{{{1, 2, 4, 5, 8}, {3, 6, 7, 10}, {9}}, {{1, 3, 4, 7, 10}, {2, 5, 6, 8}, {9}}, {{1, 2, 4, 7}, {3, 9}, {5, 6, 8, 10}}, {{1, 3, 4, 5, 7, 9}, {2, 6}, {8, 10}}, {{1, 3, 6}, {2, 7, 10}, {4, 5, 8, 9}}, {{1, 6, 7, 8}, {2, 3, 4, 10}, {5, 9}}, {{1, 2, 4, 5}, {3, 6, 10}, {7, 8, 9}}, {{1, 4, 5, 8, 9}, {2, 3, 6, 10}, {7}}, {{1, 4, 7}, {2, 3, 6, 8, 9}, {5, 10}}, {{1, 2, 3, 6, 7, 9}, {4, 5, 8}, {10}} ....}

The idea here is to create a group such as {1,1,1,1,1,1,2,2,3,3} that can be used to ID each element in the list. Then, we permute the group and map each element of the list to these group permutations. After which, we gather them by their IDs, which gives out all possible sublists.

Note:

Here, I used DeleteDuplicates[] because of the combinations that are generated by Permutating groups.

Take[groupPermutations, 5] 

{{$35, $35, $35, $35, $35, $35, $35, $35, $36, $37}, {$35, $35, $35, $35, $35, $35, $35, $35, $37, $36}, {$35, $35, $35, $35, $35, $35, $35, $36, $35, $37}, {$35, $35, $35, $35, $35, $35, $35, $36, $37, $35}, {$35, $35, $35, $35, $35, $35, $35, $37, $35, $36}}

The corresponding combs would be (without DeleteDuplicates)

{{{1, 2, 3, 4, 5, 6, 7, 8}, {9}, {10}}, {{1, 2, 3, 4, 5, 6, 7, 8}, {9}, {10}}, {{1, 2, 3, 4, 5, 6, 7, 9}, {8}, {10}}, {{1, 2, 3, 4, 5, 6, 7, 10}, {8}, {9}}, {{1, 2, 3, 4, 5, 6, 7, 9}, {8}, {10}}}

Notice that the 1st and 2nd, and 3rd and 5th are exactly equal. This is because when we gather by IDs in the last step, they turn out to be equal, so I use DeleteDuplicates[] to delete such combinations. I am guessing OP considers this sublist {{1, 2, 3, 4, 5, 6, 7, 8}, {9}, {10}} and {{1, 2, 3, 4, 5, 6, 7, 8}, {10}, {9}} to be equal. If not, OP can do Permuations on this sublist as well.

I was unable to cross check with your code output as my system kept hanging every time I run it. So, please check it if it matches your expectations or not.

$\endgroup$
2
+200
$\begingroup$

Using function FindClique is pretty fast.

FindClique[Graph[UndirectedEdge @@@ edge], {n}, All] contains the groupings for n sub-lists.

sub = Select[
   Subsets[Range[10], {1, 10}], (And @@ ((f |-> Not[ContainsAll[#, f]]) /@ 
        Partition[Range[10], 2])) &];

edge = Select[Subsets[sub, {2}], ContainsNone @@ # &];

Table[AbsoluteTiming[
  Length@FindClique[Graph[UndirectedEdge @@@ edge], {n}, All]], {n, 10}]

{
 {{0.444662, 0}},
 {{0.431703, 16}},
 {{0.442092, 1280}},
 {{0.449733, 9080}},
 {{0.447216, 16944}},
 {{0.468357, 12052}},
 {{0.435492, 3840}},
 {{0.432325, 580}},
 {{0.447429, 40}},
 {{0.44276, 1}}
}

The list above shows timings with length of found groupings for n=1 to n=10.

Example of all groupings for n=2:

FindClique[Graph[UndirectedEdge @@@ edge], {2}, All]

{
{{2,3,5,7,9},{1,4,6,8,10}},{{2,3,5,7,10},{1,4,6,8,9}},
{{2,3,5,8,9},{1,4,6,7,10}},{{2,3,5,8,10},{1,4,6,7,9}},
{{2,3,6,7,9},{1,4,5,8,10}},{{2,3,6,7,10},{1,4,5,8,9}},
{{2,3,6,8,9},{1,4,5,7,10}},{{2,3,6,8,10},{1,4,5,7,9}},
{{2,4,5,7,9},{1,3,6,8,10}},{{2,4,5,7,10},{1,3,6,8,9}},
{{2,4,5,8,9},{1,3,6,7,10}},{{2,4,5,8,10},{1,3,6,7,9}},
{{2,4,6,7,9},{1,3,5,8,10}},{{2,4,6,7,10},{1,3,5,8,9}},
{{2,4,6,8,9},{1,3,5,7,10}},{{2,4,6,8,10},{1,3,5,7,9}}
}
$\endgroup$
5
  • $\begingroup$ I think it does not give the same results as KSetPartitions. $\endgroup$
    – internet
    Commented Apr 23 at 12:30
  • 1
    $\begingroup$ It does. Where you see difference? In the result there are only sub-lists that do not contain both {1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}. So if you want to compare them you need to filter output of KSetPartitions the same way. $\endgroup$ Commented Apr 23 at 12:36
  • $\begingroup$ Ah, you removed that then you're right. $\endgroup$
    – internet
    Commented Apr 23 at 13:00
  • $\begingroup$ That is your requirement stated in your OP so why a surprise? $\endgroup$ Commented Apr 23 at 13:05
  • $\begingroup$ I forgot to filter it (as it's simple) when I compared it with KSetPartitions. $\endgroup$
    – internet
    Commented Apr 23 at 13:07
2
$\begingroup$
res = ResourceFunction["KSetPartitions"][Range[10], 3];
res // Short

(* {{{1},{2},{3,4,5,6,7,8,9,10}},<<9328>>,{{1,4,7,10},{2,5,8},{3,6,9}}} *)

res[[Range[1, 9000, 500]]]

(*{
    {{1}, {2}, {3, 4, 5, 6, 7, 8, 9, 10}}, 
    {{1, 5, 6, 7, 10}, {2}, {3, 4, 8, 9}}, 
    {{1, 3}, {2, 4, 8, 9}, {5, 6, 7, 10}}, 
    {{1, 2, 3, 4}, {5, 6, 7, 9, 10}, {8}}, 
    {{1, 7, 9}, {2, 4}, {3, 5, 6, 8, 10}}, 
    {{1, 5}, {2, 3, 4, 8}, {6, 7, 9, 10}}, 
    {{1, 2, 6, 7, 8, 10}, {3, 5}, {4, 9}}, 
    {{1, 9, 10}, {2, 3, 4, 5, 6}, {7, 8}}, 
    {{1, 3, 7, 8, 9}, {2, 10}, {4, 5, 6}}, 
    {{1, 2, 5, 6}, {3, 4, 7, 8, 10}, {9}}, 
    {{1, 4, 8}, {2, 9, 10}, {3, 5, 6, 7}}, 
    {{1, 3, 4, 8}, {2, 5, 6, 9, 10}, {7}}, 
    {{1, 2, 3, 7}, {4, 10}, {5, 6, 8, 9}},
    {{1, 9}, {2, 6, 7}, {3, 4, 5, 8, 10}}, 
    {{1, 4, 5, 7}, {2, 3, 8, 10}, {6, 9}}, 
    {{1, 2, 10}, {3, 4, 6, 9}, {5, 7, 8}}, 
    {{1, 5, 8}, {2, 3, 10}, {4, 6, 7,9}}, 
    {{1, 3, 4, 8}, {2, 6, 10}, {5, 7, 9}}
  } *)

Combinatorica KSetPartitions

Code for KSetPartitions is given in Computational Discrete Mathematics by Sriram Pemmaraju and Steven Skiena, p. 150, which I think is the function used in the Combinatorica package.

This book is available at the Internet Archive, and the code may be consulted there.

The code is as follows

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]
KSetPartitions[{a, b, c, d}, 2]

(* {{{a}, {b, c, d}}, {{a, b}, {c, d}}, {{a, c, d}, {b}}, 
    {{a, b, c}, {d}}, {{a, d}, {b, c}}, {{a, b, d}, {c}}, 
    {{a, c}, {b, d}}} *)

KSetPartitions[Range[10],3]==res

(* True *) 

Length[KSetPartitions[Range[10], 3]]

(* 9330 *)
$\endgroup$
1
$\begingroup$

To split a list into sublists does not change the order. However, in your third example the order is changed.

To split (without reordering) you may proceed e.g:

First we create a list of possible sublist-lengths and permute them to get all possible list length:

lens = IntegerPartitions[10, {3}];
lens= Flatten[Permutations /@ lens, 1]

enter image description here

Then we fill the list with elements:

TakeList[Range[10], #] & /@ lens

enter image description here

$\endgroup$
1
  • $\begingroup$ Thanks. I want all combinations in sublists where each number appears only once. For example, {1, 10} or {5, 7} are also included. $\endgroup$
    – internet
    Commented Apr 3 at 14:17

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.