# Find permutation with highest organization number (OEIS A047838)

EDIT: It turns out I misunderstood the definition of "organization number", so the below is incorrect.

However, for every permutation I create with my definition of "organization number", I can show there's an "equivalent" permutation with the same organization number. Therefore the maximal organization number is the same, and there is a 1-to-1 function that converts between permutations that answer the correct definition of "organization number" and the incorrect definition.

As an example, my permutation {5, 7, 2, 1, 3, 4, 6} which has 7-5 or 2 as the first difference, 2-7 or 5 (absolute value) as the second difference, etc, can be converted to the sequence where 1 is in the 5th position (5 is the first element of my permutation), 2 is in the 7th position (7 is the second element of my permutation), and so on.

Thus, the answers below, with a little tweaking (possibly using Ordering or similar) suffice.

OEIS A047838 defines the "organization number" of a permutation as:

Define the organization number of a permutation pi_1, pi_2, ..., pi_n to be the following. Start at 1, count the steps to reach 2, then the steps to reach 3, etc. Add them up. Then the maximal value of the organization number of any permutation of [1..n] for n = 0, 1, 2, 3, ... is given by 0, 1, 3, 7, 11, 17, 23, ... (this sequence).

The phrase "organization number" appears to be nonstandard, but I'll continue to use it in this question.

In Mathematica, the organization number of a permutation would be:

orgNumber[list_] :=
Total[Table[Abs[list[[i]] - list[[i-1]]], {i,2,Length[list]}]];


Of course, that works for any list, not just permutations.

The OEIS link above provides a formula for the highest possible organization number for a permutation of $$n$$ elements:

maxOrg[n_] = Floor[n^2/2]-1


My question: how can I find a permutation of $$n$$ elements whose organization number is maximal. For $$n > 1$$, there will always be at least 2 such permutations (since the reverse permutation has the same organization number), and, from what I've seen, there are usually several. I just want to find one of them.

For small values of $$n$$, you can brute force it:

maxPerm[n_] := Select[Permutations[Range[1,n]], orgNumber[#] == maxOrg[n] &]


but this gets really slow after about $$n=10$$.

I looked at the "first" permutation meeting this condition for each value of $$n=2$$ through $$n=8$$ and got:

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


Going from an even number to an odd number seems to follow an obvious pattern, so I correctly guessed the following for $$n=9$$:

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


However, I couldn't find enough of a pattern to find a value for $$n=10$$.

In my "real world" application, $$n = 44$$, so brute forcing is not an option.

However, I did use:

t0 = Table[RandomSample[Range], {i, 1, 100000}];
t1 = Max[Map[orgNumber, t0]]


Obviously, results will vary, but I got $$t1 = 885$$. Since the max possible is 967, this is a pretty good value (and I get the permutation(s) matching this number using Select, as above), but, obviously, I'd prefer the true max.

Another interesting question would be: what's the distribution of organization numbers for a given $$n$$.

Based on my random experimentation, the distribution appears to look somewhat Normal, with a mean of $$n^{2/3}$$. I wasn't able to get a real feeling for the standard deviation, though it appears to be about 59.6 for $$n=44$$.

• orgNumber[list_] := Total@Abs@Differences@list should be much faster. – Carl Woll May 22 at 21:18
• Thanks, I forgot about Differences. I'll leave things as is in the code since I know the code I posted is working, and, even with this speed increase, I think large n will still be a problem. – barrycarter May 22 at 21:22
• I don't think you've interpreted this correctly. I believe the correct function for the result is Tr@Abs@Differences@Ordering@res where res is a permutation. A maximal example is then simply generated instantly via Join[Range[2, 2 Floor[#/2], 2], {1}, Range[2 Ceiling[#/2] - 1, 3, -2]] & with argument of n desired. The results match OEIS. – ciao May 23 at 1:19
• @ciao Yes! you are right. Ordering@res is the right answer. – J42161217 May 23 at 2:25
• Read the references. oeis.org/A047838/a047838.txt gives a permutation with maximum organisation number. – Peter Taylor May 23 at 7:56

...and we are done!
Solution for k=44 in 10 seconds

k=44;
r=Last@Select[Flatten[Table[Select[Riffle[#,-Last@IntegerPartitions[Floor[(Floor[k^2/2]-1)/2],{Floor[(k-1)/2]},b=Range[s=Floor[Floor[(Floor[k^2/2]-1)/2]/Floor[k/2]],s+2]]]&/@Reverse/@IntegerPartitions[Floor[(Floor[k^2/2]-1)/2]+1,{Ceiling[(k-1)/2]},Range[s=Floor[Floor[(Floor[k^2/2] - 1)/2]/Floor[k/2]],s+k-8]],Union[FoldList[Total[{##}]&,p,#]]==Range@k&],{p,k}],1],Union@Differences@Union[FoldList[Total[{##}]&,#[],#]]=={1}&];w=FoldList[Total[{##}]&,1,r];
f=w+k-Max@w
Total@Abs@Differences@f
Floor[k^2/2]-1


k=44

{22,44,21,43,20,42,19,41,18,40,17,39,16,38,15,37,14,36,13,35,12,34,11,33,10,32,9,31,8,30,7,29,6,28,5,27,4,26,3,25,2,24,1,23}
967
967

This algorithm tries to find the differences-list of the result.

By examining the differences we can see that half of them are positive and half negative. Also sum of positives is equal to sum of negatives +1 and they are riffled. So we are trying to produce those two sets using IntegerPartition but we must choose as less results as possible in order for this to terminate. In order to make this work we have to "fine-tune" the variable c of the following algorithm (otherwise it will throw errors). The goal of this answer was to reach k=44 which seemed impossible by testing permutations...
Here are the correct values in order to hit k=50

k=50;
c=15;
r=Last@Select[Flatten[Table[Select[Riffle[#,-Last@IntegerPartitions[Floor[(Floor[k^2/2]-1)/2],{Floor[(k-1)/2]},b=Range[s=Floor[Floor[(Floor[k^2/2]-1)/2]/Floor[k/2]],s+2]]]&/@Reverse/@IntegerPartitions[Floor[(Floor[k^2/2]-1)/2]+1,{Ceiling[(k-1)/2]},Range[s=Floor[Floor[(Floor[k^2/2] - 1)/2]/Floor[k/2]],s+c]],Union[FoldList[Total[{##}]&,p,#]]==Range@k&],{p,k}],1],Union@Differences@Union[FoldList[Total[{##}]&,#[],#]]=={1}&];w=FoldList[Total[{##}]&,1,r];
f=w+k-Max@w
Total@Abs@Differences@f
Floor[k^2/2]-1


k=50
{25,50,24,49,23,48,22,47,21,46,20,45,19,44,18,43,17,42,16,41,15,40,14,39,13,38,12,37,11,36,10,35,9,34,8,33,7,32,6,31,5,30,4,29,3,28,2,27,1,26}
1249
1249

• Shiny! Any chance you could explain it? It looks like you don't user Permutations, but instead IntegerPartitions to find which integers add up to the magic number? And then what? – barrycarter May 22 at 23:43
• Actually I studied the differences and tried to produce differences that work. Right now I'm working on some modifications... I let you know – J42161217 May 22 at 23:49
• Wow! Would still be nice to understand the thought process, but that definitely answers the question. – barrycarter May 23 at 1:03
• Is there a copy error here? I''m not about to debug the jumble, but as is it blows up with a stream of errors under 12 and 11.3 MMA on my machine. – ciao May 23 at 1:15
• Read my comments to OP: I believe they have misinterpreted the OEIS entry, and generation is much simpler. – ciao May 23 at 1:20

This answer just shows how to improve the speed of orgNumber:

orgNumber2[p_] := Total @ Abs @ Differences @ p


Comparison:

t0 = Table[RandomSample[Range],{i,1,100000}];

t1 = Max[Map[orgNumber,t0]]; //AbsoluteTiming
t2 = Max[Map[orgNumber2, t0]]; //AbsoluteTiming

t1==t2


{6.94362, Null}

{0.4978, Null}

True

Another almost order of magnitude increase in speed can be obtained by writing a version that works with multiple lists:

orgNumber3[p:{__List}] := Total[Abs @ Transpose @ Differences[Transpose@p], {2}]


Timing:

t3 = Max @ orgNumber3[t0]; //AbsoluteTiming
t1 == t2 == t3


{0.070115, Null}

True

Using ciao's comment, producing the desired permutation is simple:

maxPerm[n_] := Ordering @ Join[
Range[2, 2 Floor[n/2], 2],
{1},
Range[2 Ceiling[n/2] - 1, 3, -2]
]


For $$n=44$$:

r = maxPerm; //AbsoluteTiming
r
orgNumber2[r]


{0.000045, Null}

{23, 1, 44, 2, 43, 3, 42, 4, 41, 5, 40, 6, 39, 7, 38, 8, 37, 9, 36, \ 10, 35, 11, 34, 12, 33, 13, 32, 14, 31, 15, 30, 16, 29, 17, 28, 18, \ 27, 19, 26, 20, 25, 21, 24, 22}

967

For $$n = 10^6$$ :

n = 10^6;
r = maxPerm[n]; //AbsoluteTiming
orgNumber2[r]
Floor[n^2/2] - 1


{0.019479, Null}

499999999999

499999999999