Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I would like to find a permutation of $\quad S=\{\frac{1}{10}, \frac{1}{2}, \frac{4}{7}, \frac{3}{5}, \frac{2}{3} \}\quad$ that maximizes the sum of theses elements raised to unique powers: $\;\{0,1,2,3,4\}$.
I think it is

\begin{align}\biggr(\frac{1}{10}\biggr)^0 + \biggr(\frac{4}{7}\biggr)^1 + \biggr(\frac{2}{3}\biggr)^2 + \biggr(\frac{3}{5}\biggr)^3 + \biggr(\frac{1}{2}\biggr)^4&\approx 2.294373016\end{align}

but I would like to verify that this is the case via computation. Also it would be useful to know how to perform general operations on sets.

share|improve this question
3  
I confess I am surprised that it is not attained by using highest powers on smallest terms. But indeed it is nothing like that. Is a heuristic method acceptable (i.e. using NMinimize)? –  Daniel Lichtblau Jun 15 '13 at 21:12
2  
I would love to see number theory based solution. –  Kuba Jun 15 '13 at 22:31
1  
While I find this an interesting problem and we have lots of interesting answers, I don't see how the problem as stated has produced a question about anything to do with Mathematica. –  Jagra Jun 16 '13 at 0:18
    
@Kuba I would love to get an idea what you mean by a number theory based solution. –  Artes Jun 16 '13 at 17:32
    
@Artes I'm not a mathematician but couple of years ago I went on a few "algebra and number theory" lectures/classes and this question reminds me them. –  Kuba Jun 16 '13 at 20:59
add comment

6 Answers

A brute force solution is to check all possible values of this function.

num = {1/10, 1/2, 4/7, 3/5, 2/3};
pow = {0, 1, 2, 3, 4};

To obtain value for one combination use the Inner function

Inner[Power, num, pow, Plus]
(* => 2222701/992250 *)

Then we apply function Inner[Power, num, #, Plus]& on all permutations

prm = Permutations[pow];
val = Inner[Power, num, #, Plus] & /@ prm;

What is left is to find a position of the maximum of this list

{Part[val, #], Part[prm, #]} &@ Flatten@Position[val, Max[val]]
(* => {{289091/126000}, {{0, 4, 1, 3, 2}}} *)
share|improve this answer
add comment

A variation:

mySet = {1/10, 1/2, 4/7, 3/5, 2/3};
perms = Permutations[mySet];
powersums = Total[Transpose @ perms^Range[0, 4]];
Extract[perms, Position[powersums, Max[powersums]]]
{{1/10, 4/7, 2/3, 3/5, 1/2}}

Another variation (beware: slower on large sets):

Last @ Sort @ With[{perms = Permutations[{1/10, 1/2, 4/7, 3/5, 2/3}]},
   Thread[{Total[Transpose@perms ^ Range[0, 4]], perms}]]
{289091/126000, {1/10, 4/7, 2/3, 3/5, 1/2}}

Third way is a bit different:

Last @ Pick[perms, 
  Unitize @ Differences @ FoldList[Max, 0, Total[Transpose@N@perms ^ Range[0, 4]]], 1]
{1/10, 4/7, 2/3, 3/5, 1/2}

Fastest of mine:

(Table[

     {sol} = With[{perms = Permutations[N@mySet]}, 
              Pick[perms, Unitize[# - Max@#], 0] &[Total[Transpose@perms ^ Range[0, 4]]]];
     mySet[[Ordering @ Ordering @ sol]],

     {100}] // Last // Timing)/{100, 1}
{0.00003484, {1/10, 4/7, 2/3, 3/5, 1/2}}

All integer version:

(Table[

   lcm = LCM @@ Denominator /@ mySet;
   With[{perms = Permutations[lcm mySet]},
     Last @ Pick[perms, #, Max@#] &[
              lcm ^ Reverse @ Range[0, 4] . Transpose @ perms ^ Range[0, 4]]] / lcm,

     {100}] // Last // Timing)/{100, 1}
{0.00004405, {1/10, 4/7, 2/3, 3/5, 1/2}}

The integer version slows down when the size of the terms grows, first around where lcm^4 exceeds 32 bits and next when it exceeds Developer$MaxMachineInteger` (on a relatively new MacBook Pro).

share|improve this answer
    
+1 Oh the Extract! –  mmal Jun 15 '13 at 21:49
add comment

Too long for a comment...

One can treat it as an integer nonlinear program. I've not proved this in elaborate detail, but I believe it remains a correct formulation when we relax the integrality constraint, as I do below.

This is, I will say, FAR slower than even brute-force enumeration. It has the possible advantage of generalizing to cases where brute force is ruled out due to size.

vals = {1/10, 1/2, 4/7, 3/5, 2/3};
len = Length[vals];
powers = Range[0, len - 1];

vars = Array[c, {len, len}];
fvars = Flatten[vars];
obj = Total[(vars.vals)^powers];
c1 = Thread[Total[vars] == 1];
c2 = Thread[Total[Transpose[vars]] == 1];
c3 = {Map[0 <= # <= 1 &, fvars]};
constraints = Join[c1, c2, c3];

Timing[NMaximize[{obj, constraints}, fvars]]

(* Out[67]= {17.520000, {2.29437299145, {c[1, 1] -> 0.999999952053, 
   c[1, 2] -> 4.79474305884*10^-8, c[1, 3] -> 0., c[1, 4] -> 0., 
   c[1, 5] -> 0., c[2, 1] -> 0., c[2, 2] -> 9.84212843447*10^-8, 
   c[2, 3] -> 0.999997045009, c[2, 4] -> 2.82613784397*10^-6, 
   c[2, 5] -> 3.04319072001*10^-8, c[3, 1] -> 0., c[3, 2] -> 0., 
   c[3, 3] -> 1.06376117914*10^-8, c[3, 4] -> 1.64066369746*10^-7, 
   c[3, 5] -> 0.999999825296, c[4, 1] -> 0., c[4, 2] -> 0., 
   c[4, 3] -> 2.94239801718*10^-6, c[4, 4] -> 0.99999691333, 
   c[4, 5] -> 1.44272074304*10^-7, c[5, 1] -> 4.79474305884*10^-8, 
   c[5, 2] -> 0.999999853631, c[5, 3] -> 1.95540634579*10^-9, 
   c[5, 4] -> 9.64658775082*10^-8, c[5, 5] -> 0.}}} *)
share|improve this answer
add comment

Let's demonstrate quite a straightforward approach:

With[{ lst = #1^0 + #2 + #3^2 + #4^3 + #5^4 & @@@ Permutations[{1/10, 1/2, 4/7, 3/5, 2/3}]}, 
      Position[lst, Max @ lst]]
{{12}}
Permutations[{1/10, 1/2, 4/7, 3/5, 2/3}][[12]]
{1/10, 4/7, 2/3, 3/5, 1/2}

#1^0 + #2 + #3^2 + #4^3 + #5^4 & - a pure function of 5 variables, an equivalent of a common definition like f[x_, y_, u_, w_, z_] := x^0 + y + u^2 + w^3 + z^4.

Edit

Here we define a bit more general function mp which can work with lists of arbitrary length and therefore instead of playing with a pure function #1^0 + #2 + #3^2 + ... + #n^(n-1) & like above, we can take advantage of Inner since now it becomes especially handy (in case of lists of constant length it wouldn't be really better). The only limitation of this approach is that generation of all permutations needs much memory (exponentially increasing with the length of the input list).

mp[lst_List] := Module[{ prm = Permutations[lst], vls}, 
                  vls = Inner[ Power, #, Range[0, Length[lst] - 1], Plus]& @ prm;
                  prm[[#]] & @@@ Position[ vls, Max @ vls] ]

Let's check the above result:

mp[{1/10, 1/2, 4/7, 3/5, 2/3}]
{{1/10, 4/7, 2/3, 3/5, 1/2}}

so it works as we'd expect. A bit longer list needs significantly more time (and memory) for the evaluation process, but mp can also provide an adequate permutation:

mp[{7/8, 1/7, 4/5, 3/10, 2/3, 5/9, 7/12, 1/6, 12/17}]
{{1/7, 2/3, 12/17, 4/5, 7/8, 7/12, 5/9, 3/10, 1/6}}

and finally we provide an obvious result:

mp[{1, 2, 3}]
mp[{3, 1, 2}] == mp[{1, 2, 3}]
{{1, 2, 3}}
True
share|improve this answer
    
Thank you so much!! –  Orangutango Jun 15 '13 at 21:15
add comment

Many functions work with lists (what you call sets) just as well as numbers.

s = {1/10, 1/2, 4/7, 3/5, 2/3};
p = Range[0, 4];
perm = Permutations[s];
totals = Total[#^p] & /@ perm;
maxPos = First[Flatten[Position[totals, Max[totals]]]]
perm[[maxPos]]

In the totals step, we do the $S_{i}\hat{}p_{i}$ calculation for all the permutations of the list $S$.

share|improve this answer
2  
The mathematical definition of a set is a bit more specific. It makes no difference in this example, but sets contain only distinct (non-repeated) elements. –  Corey Kelly Jun 16 '13 at 2:55
add comment

The 0 power has to be assigned to the smallest fraction, $\frac{1}{10}$ since

$0<a_{i}<a_{j}<1 \implies a_{i}^{0}+a_{j}^{1}=1+a_{j}>1+a_{i}=a_{1}^{1}+a_{j}^{0}$

The idea of contradicting maximimality with transpositions can be pursued telescopically:

 Or @@ (Reduce[{((1/2)^# + x^4) > ((1/2)^4 + x^#) && 1/2 < x <= 2/3}, 
 x] & /@ {1, 2, 3})
 (* False *)

... so that the $4$ power now has to be assigned to $\frac{1}{2}$

Or @@ (Reduce[{((2/3)^# + x^2) > ((2/3)^2 + x^#) && 4/7 <= x < 2/3}, 
 x] & /@ {1, 3}) 
(* False *)

... so that the $2$ power now has to be assigned to $\frac{2}{3}$

Or @@ (Reduce[{((3/5)^# + x^3) > ((3/5)^3 + x^#) && 4/7 <= x < 3/5}, 
 x] & /@ {1})
(*False *)

... so that the $3$ power now has to be assigned to $\frac{3}{5}$

leaving the $1$ power to be assigned to $\frac{4}{7}$ in the maximal assignment - a verification "via computation".

share|improve this answer
    
Nice! Now if only this could be extended to locate the optima given a set of numbers between 0 and 1. –  Orangutango Jun 24 '13 at 2:22
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.