# Performing Computations on Sets

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.

-
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
I would love to see number theory based solution. –  Kuba Jun 15 '13 at 22:31
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

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

-

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). - +1 Oh the Extract! – mmal Jun 15 '13 at 21:49 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.}}} *)  - 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  - Thank you so much!! – Orangutango Jun 15 '13 at 21:15 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$. - 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 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".

-
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