# Find all sets whose index is divisible by the elements

Suppose I have such a set $$S=\{3,4,5,...n+2\}, n\in \mathbb{Z}_{>\, 0}$$, $$a_n$$ is any permutation of $$S$$ such that $$n|a_n$$, I want to know how many such $$a_n$$. The easy but inefficient way to do this is

n = 7;
Select[Permutations[Range[n] + 2], Union@Mod[#, Range[n]] == {0} &]


{{3, 4, 9, 8, 5, 6, 7}, {3, 8, 9, 4, 5, 6, 7}, {9, 4, 3, 8, 5, 6, 7}, {9, 8, 3, 4, 5, 6, 7}}

For larger $$n$$, the above method is not available, is there an efficient algorithm? Replacepart may be useful.

Hint, the last two numbers can be placed in the position of their divisors, correspondingly, the original element also needs to move. I believe there is an efficient algorithm, in principle, it can work for $$n> 1000$$.

• Not just the last two numbers: every number $m$ with $\frac n2+1 < m \le n$ must go in its own position, since any proper multiple of $m$ is at least $2m$. Sep 4 at 18:39

With some mathematical derivation, we can get a very simple formula.

fSeq[n_] :=
If[n <= 2, 1, Total[fSeq /@ Select[Most@Divisors[n], EvenQ[n - #] &]]]
fCount[n_] := fSeq[n + 1]*fSeq[n + 2]


It takes less than 1 second to calulate fCount/@Range.

To get all solutions

fSeqs[n_] :=
If[n <= 2, {{n}},
Flatten[(Append[#, n] & /@ fSeqs[#] &) /@
Select[Most@Divisors[n], EvenQ[n - #] &], 1]]
fAllSol[n_] := Module[{sol},
sol = {0, 0}~Join~Range[3, n];
Table[
ReplacePart[sol, Join[
Thread[seq1[[;; -2]] -> seq1[[2 ;;]]],
Thread[seq2[[;; -2]] -> seq2[[2 ;;]]]
]],
{seq1, fSeqs[n + 1]}, {seq2, fSeqs[n + 2]}
]~Flatten~1
]


Here is some brief derivation,

Let $$b[a[i]]=i$$ for $$i=1..n$$, then we has a inverse function of a.

For $$i \mid a[i]$$, we have $$a[i] \geq i$$.

If $$a[i] > i$$, we know $$i$$ is placed at the index $$b[i]$$, $$b[i] \mid i$$, and $$b[i] \neq i$$ because $$a[b[i]]=i < a[i]$$. So we know $$b[i] < i$$.

In same way we have $$b[i] > b[b[i]]$$ and so on, then we got a strictly decreasing sequence $$\{i, b[i], b[b[i]], ...\}$$, which must end at 1 or 2, because only $$b$$ and $$b$$ are undefined.

So we have these two sequence, they start from $$n+1$$ and $$n+2$$, end with 1 and 2, for each sequence the next item is divisors of the previous item.

And should notice that one of $$n+1$$ and $$n+2$$ is odd, so it must end at 1, and the even one has to end at 2. That means the sequence of the even one must be even for all items.

Generate all possible sequence for $$n+1$$ and $$n+2$$ and make combination of them, we got all the solutions.

• (+1) wu ying dong gua :) Sep 12 at 14:42
• Nice work! Can we also get all solutions? Sep 12 at 15:03
• Yes of course, the code has been added Sep 12 at 15:17
• @wuyingddg that's wonderful!!! (+1)
– bmf
Sep 12 at 15:48
• @wuyingddg Nice answer, indeed! (+1) :) Sep 12 at 20:04

Here is a recursive solution:

n = 7;
step[res_] :=
Module[{avail = Complement[2 + Range[n], res],
count = 1 + Length[res], todo},
If[count == n + 1, Return[res]];
todo = Select[avail, (Mod[#, count] == 0) &];
If[todo == {} , Return[Nothing]];
tmp = ((step[Append[res, #]]) & /@ todo );
tmp = tmp //. {x1___, {}, x2___} -> {x1, x2} //. {x {x___}} -> x;
If[Depth[tmp] > 3, tmp = Flatten[tmp, 1]];
tmp
]

step[{}]

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


Here is another approach:

f[n_] := Module[{r = Range[n], s},
s = Select[r + 2, Function[x, Mod[x, #] == 0]] & /@ r;
Select[Tuples[s], Length[Union@#] == n &]]


Illustrating:

Table[{j, Grid[{##}], Length@{##}} & @@ (f@j), {j, 2, 20}] //
Grid[#, Frame -> All] & • I'm not sure what's faster, but DuplicateFreeQ would be a more concise way to check whether the numbers are all unique Sep 8 at 8:22
• @LukasLang you maybe right…feel free to test…I don’t have time at present. Sep 8 at 8:27