Mfcttrf

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[44]], 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$.

...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]],#]]==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]],#]]==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

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

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

Comparison:

t0 = Table[RandomSample[Range[44]],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

Addendum

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[44]; //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