Performing Computations on Sets

Question

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.

Answer 1

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}}} *)

Answer 2

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).

Answer 3

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

Answer 4

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.}}} *)

Answer 5

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$.

Answer 6

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".