7
$\begingroup$

I would like to define a function of two integer variables $ \{n, k\} $, with $ k | n $, that would print all the possible permutations of the first $ n$ positive integers, such that the subsets of $ k $ elements never contains $ 2 $ times the same elements of the previous permutations. As an example, this should be the output with $ n = 20, k = 4 $:

$\{1, 2, 3, 4\}$, $\{5, 6, 7, 8\}$, $\{9, 10, 11, 12\}$, $\{13, 14, 15, 16\}$, $\{17, 18, 19, 20\}$

$\{1, 5, 9, 13\}$, $\{17, 2, 6, 10\}$, $\{14, 18, 3, 7\}$, $\{11, 15, 19, 4\}$, $\{8, 12, 16, 20\}$

$\{1, 17, 14, 8\}$, $\{5,2,12,15\}$, $\{9, 16, 3, 19\}$, $\{20, 10, 7, 4\}$, $\{11, 18, 6, 13\}$

$ ...$

$\endgroup$
3
  • 5
    $\begingroup$ Could you give example with much smaller {𝑛,𝑘} and its complete output you expect. Like {3,2} or {4,3}. $\endgroup$ Feb 13, 2023 at 8:54
  • $\begingroup$ @VitaliyKaurov Ok, let's say it's $ [4,2] $ (because $ k | n $), so the output would be: $\{1, 2\}$, $\{3, 4\}$ \ $\{1, 3\}$, $\{2, 4\}$ \ $\{1, 4\}$, $\{2, 3\}$ With the slash intended as new line $\endgroup$
    – user967210
    Feb 13, 2023 at 11:36
  • $\begingroup$ Related: partition-a-set-into-subsets-of-size-k $\endgroup$
    – chyanog
    Feb 16, 2023 at 3:42

3 Answers 3

1
$\begingroup$

We may first create all k subsets of 1..n;

Then we need to select n/k subsets that have no common elements. Toward this aim we define a function that, given a number of subsets, selects a further subset that has no common element. It repeats this recursively until n/k subsets. We then feed the first subset to our routine, then the second e.t.c until we fed all subsets starting with 1. Finally we join all results.

main[n_, k_] := Module[{d = Range[n], p, step},
If[! Divisible[n, k], Print["n not divisible by k."]; Return[]];
  p = Subsets[d, {k}];
  
  step[e1_] := Module[{es = Flatten[e1], new, res,fun},
    fun[e_] := ( 
      new = Select[p, (! IntersectingQ[Flatten[{e}], #]) &];
      Append[e, #] & /@ new);
    
    res = Flatten[fun /@ e1, 1];
    If[Length[res[[1]]] == n/k, res, step[res]]
    ];
  
  Join @@ Reap[
     Do[
      Sow[step[{{p[[1]]}}]];
      p = Rest[p];
      , Binomial[n - 1, k - 1]]][[2, 1]] 
  ]

Now for a test:

main[4, 2]

{{{1, 2}, {3, 4}}, {{1, 3}, {2, 4}}, {{1, 4}, {2, 3}}}

Or:

main[6, 3]

{{{1, 2, 3}, {4, 5, 6}}, {{1, 2, 4}, {3, 5, 6}}, {{1, 2, 5}, {3, 4, 
   6}}, {{1, 2, 6}, {3, 4, 5}}, {{1, 3, 4}, {2, 5, 6}}, {{1, 3, 
   5}, {2, 4, 6}}, {{1, 3, 6}, {2, 4, 5}}, {{1, 4, 5}, {2, 3, 
   6}}, {{1, 4, 6}, {2, 3, 5}}, {{1, 5, 6}, {2, 3, 4}}}

Or:

main[6, 2]

{{{1, 2}, {3, 4}, {5, 6}}, {{1, 2}, {3, 5}, {4, 6}}, {{1, 2}, {3, 
   6}, {4, 5}}, {{1, 2}, {4, 5}, {3, 6}}, {{1, 2}, {4, 6}, {3, 
   5}}, {{1, 2}, {5, 6}, {3, 4}}, {{1, 3}, {2, 4}, {5, 6}}, {{1, 
   3}, {2, 5}, {4, 6}}, {{1, 3}, {2, 6}, {4, 5}}, {{1, 3}, {4, 5}, {2,
    6}}, {{1, 3}, {4, 6}, {2, 5}}, {{1, 3}, {5, 6}, {2, 4}}, {{1, 
   4}, {2, 3}, {5, 6}}, {{1, 4}, {2, 5}, {3, 6}}, {{1, 4}, {2, 6}, {3,
    5}}, {{1, 4}, {3, 5}, {2, 6}}, {{1, 4}, {3, 6}, {2, 5}}, {{1, 
   4}, {5, 6}, {2, 3}}, {{1, 5}, {2, 3}, {4, 6}}, {{1, 5}, {2, 4}, {3,
    6}}, {{1, 5}, {2, 6}, {3, 4}}, {{1, 5}, {3, 4}, {2, 6}}, {{1, 
   5}, {3, 6}, {2, 4}}, {{1, 5}, {4, 6}, {2, 3}}, {{1, 6}, {2, 3}, {4,
    5}}, {{1, 6}, {2, 4}, {3, 5}}, {{1, 6}, {2, 5}, {3, 4}}, {{1, 
   6}, {3, 4}, {2, 5}}, {{1, 6}, {3, 5}, {2, 4}}, {{1, 6}, {4, 5}, {2,
    3}}}
$\endgroup$
4
  • $\begingroup$ Thanks for your answer. But the function you defined show all the possible combinations, now I need to sort out just the ones where the subsets doesn't contain two elements that were presents in the previous subsets configurations. E.g. with $ main[6,3] $, I would just expect $\{$ $\{1, 2, 3\}$, $\{4, 5, 6\}$ $\}$, because it's not possible to find other subsets with $ 3 $ elements not containing $ 2 $ elements that were already present in one of the two starting subsets. I hope I explained my request. Thank you $\endgroup$
    – user967210
    Feb 15, 2023 at 22:27
  • $\begingroup$ I found out that sometimes the answer is redundant, I mean with $main[6,2]$ the output contains $2$ times {{1, 2}, {4, 6}, {3, 5}} and all the other sublists (they should be 15 and not 30) $\endgroup$
    – user967210
    Feb 17, 2023 at 7:22
  • $\begingroup$ I can not verify this, I get 30 lists. Try with a fresh kernel. $\endgroup$ Feb 17, 2023 at 8:32
  • $\begingroup$ Yep but among them you get ...{{1, 2}, {3, 5}, {4, 6}}, {{1, 2}, {4, 6}, {3, 5}}..., which is basically the same. Don't worry, I same what fixed that $\endgroup$
    – user967210
    Feb 17, 2023 at 8:40
0
$\begingroup$

Here is one possible solution:

perm[set_List, k_Integer] := If[Length[set]<2k,
  List/@Subsets[set,{k}],
  Flatten[
    Function[s,Prepend[#,s]&/@perm[Complement[
     Drop[set,First@FirstPosition[set,First[s]]],s],k]]
     /@Subsets[set, {k}], 1]
  ];
perm[n_Integer, k_Integer] := perm[Range[n], k];

It might be not the most effective, but it is much faster than @Daniel's main function.

For example,

In[1]:= Timing[perm[10, 2]]
Out[1]:= {0.1,{{{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}},...}}(*4260 elements*)
$\endgroup$
0
$\begingroup$

I define permutationsNk[n,k] for Integer arguments, where k divides into n (or, alternatively, where k belongs to the Divisors of n).

Evaluating eg. res=permutationsNk[4,2] returns

enter image description here

Looking inside the Iconized object, one finds

res // First

![enter image description here

Following along, down the depth of the result, one finds that the first iconized sub-element (of the top-level result) evaluates to

res // First/*(Part[#, 1] &)/*First

![enter image description here

which can be further shown to be

res // First/*(Part[#, 1] &)/*First/*(Part[#, 1] &)/*First

enter image description here

Similarly, the second and third iconized sub-elements of the top-level result evaluate to

enter image description here and enter image description here respectively.

It might have been easier or more convenient to evaluate the result all at once, using something like

res // First/*Map[First/*Map[First]]/*Apply[Join]

enter image description here

however, the results for the general case ($n$ and $k$ integers and $k|n$) can be too many in number and an approach like the one above, might temporarily freeze or hang the notebook.

It's not to say that accessing the results in a piecemeal fashion, is a definite workaround for the problem of the combinatorial explosion in the number of the results, however it seems to help, for reasonable input arguments (however, I haven't tried anything above $n=20$, so I could be wrong for even moderate values of $n$, but I'm confident that it's not the case).

Just to provide another example, evaluating res=permutationsNk[8,4] and using the bulk way (the one-liner presented above) to access the results (again, which might cause trouble with larger values for $n$) returns

enter image description here

Before providing the code, I will produce another example for the case permutations[12,6], only this time the result is provided in plain text format and can be used for testing purposes:

permutations[12,6]

evaluates to

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

Definitions

The following definitions are mostly user interface definitions:

ClearAll[permutationsNk, doPermutationsNk]
permutationsNk[n_?IntegerQ,k_?IntegerQ]/;Mod[n,k]==0:=doPermutationsNk[n,k]

Here we define the messages generated from erroneous user input:

permutationsNk::notint="`1` is not an Integer";
permutationsNk[x_?(IntegerQ/*Not),y_?IntegerQ]:=(Message[permutationsNk::notint,x])
permutationsNk[x_?IntegerQ,y_?(IntegerQ/*Not)]:=(Message[permutationsNk::notint,y])

permutationsNk::badargs="`2` does not divide into `1`, exactly";
permutationsNk[x_,y_]:=(Message[permutationsNk::badargs,x,y])

This is essentially what drives the results: The way to combine different elements of the list {1,2,...,n} is done through ListCorrelate. The auxiliary function times combines the entries in the kernel (ker, ones or zeros) with the numbers in list ({1,2,...,n}). Whenever it encounters a zero in the kernel, it evaluates to Nothing. This behavior, coupled with the fact that the last argument of ListCorrelate is List allows for the construction of the desirable tuples.

Clear[times,listCorrelate]
times=(Switch[#1,0,Nothing,_,Times[##]]&);
listCorrelate[ker_,list_]:=ListCorrelate[ker,list,{1,-1},{},times,List]

An example for how listCorrelate works, consider a kernel ker={a,0,b} and list=Range[4]:

listCorrelate[{a,0,b},Range[4]]

enter image description here

Whenever a zero is encountered in the kernel, Nothing is returned, which in turn is wrapped in a list eg {a,Nothing,3b} which simplifies to {a,3b}.

Putting everything together:

doPermutationsNk[n_,k_]:=Module[{ker,list,firstLL,lastLL,reMo,ico,null,res,permutations,outer,apply,through,res0},
  ker=ConstantArray[1,k];
  list=Range[n];

  firstLL=First/*List/*List;
  lastLL=Last/*List/*List;
  reMo=Rest/*Most;
  ico=Iconize[#1,ToString[#2]]&;

  permutations[j_]:=(Join[#,ConstantArray[0,j]]&)/*Permutations;
  outer[j_,args__]:=Outer[Join/*(listCorrelate[#,list]&)/*(ico[#,j]&),args,1];
  apply[j_]:=(With[{len=Length[{##}]},outer[j,##]//(Flatten[#,len-1]&)]&)/*(ico[#,Length[#]]&);
  through[j_]:={firstLL,reMo/*permutations[j],lastLL};

  {null,{res}}=Reap@Do[ker//(Through[through[j][#]]&)/*Apply[apply[j]]/*Sow,{j,n-k}];

  res0=listCorrelate[ConstantArray[1,k],list]//(ico[#,Length[#]]&)/*List/*(ico[#,Length[#]]&);
  Join[{res0},res]//(ico[#,Length[#]]&)
]

The following two expressions deal with boundary values for $k$:

doPermutationsNk[n_,1]:=Module[{list,ico,res0},
  list=Range[n];

  ico=Iconize[#1,ToString[#2]]&;

  res0=list//List/*Transpose/*(ico[#,Length[#]]&)/*List/*(ico[#,Length[#]]&);
  Join[{res0},{}]//(ico[#,Length[#]]&)
]

and

doPermutationsNk[n_,n_]:=Module[{list,ico,res0},
  list=Range[n];

  ico=Iconize[#1,ToString[#2]]&;

  res0=list//List/*(ico[#,Length[#]]&)/*List/*(ico[#,Length[#]]&);
  Join[{res0},{}]//(ico[#,Length[#]]&)
]
$\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.