I have the following list of squares.
{1, 4, 9, 16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256}
Their sum is $1496$, I want to make two partitions with the given numbers and each partition should have a sum of $748$, does Mathematica have a built-in function for that?
Can be done with a bit of programming. Below I also enforce that exactly half the values be used in each subset. I show one subset in the result and obviously its complement would be the companion subset.
vals = Range[16]^2;
vars = Array[x, Length[vals]];
c1 = Map[0 <= # <= 1 &, vars];
c2 = Total[vars] == 8;
c3 = 2*vars.vals == Total[vals];
DeleteCases[(vars*vals) /.
First[FindInstance[Flatten[{c1, c2, c3}], vars, Integers]], 0]
--- Edit ---
There are other solutions in this case. Can find them all using Reduce.
DeleteCases[(vars*vals) /. {ToRules[
Reduce[Flatten[{c1, c2, c3}], vars, Integers]]}, 0, {2}]
(* {{16, 25, 36, 81, 100, 121, 144, 225}, {9, 36, 49, 64, 100,
121, 144, 225}, {9, 36, 49, 64, 81, 144, 169, 196}, {9, 25, 36, 49,
64, 144, 196, 225}, {9, 16, 36, 64, 81, 121, 196, 225}, {9, 16, 36,
49, 100, 144, 169, 225}, {9, 16, 25, 36, 81, 100, 225, 256}, {4, 25,
49, 64, 81, 100, 169, 256}, {4, 25, 36, 64, 81, 144, 169, 225}, {4,
16, 49, 64, 100, 121, 169, 225}, {4, 16, 25, 49, 81, 121, 196,
256}, {4, 16, 25, 49, 64, 169, 196, 225}, {4, 9, 64, 81, 100, 121,
144, 225}, {4, 9, 36, 49, 81, 144, 169, 256}, {4, 9, 25, 64, 100,
121, 169, 256}, {4, 9, 25, 64, 81, 144, 196, 225}, {4, 9, 25, 36,
49, 144, 225, 256}, {4, 9, 16, 81, 100, 144, 169, 225}, {4, 9, 16,
36, 81, 121, 225, 256}, {1, 25, 49, 64, 100, 144, 169, 196}, {1, 25,
36, 49, 64, 121, 196, 256}, {1, 16, 64, 81, 100, 121, 169,
196}, {1, 16, 36, 49, 100, 121, 169, 256}, {1, 16, 36, 49, 81, 144,
196, 225}, {1, 16, 25, 64, 100, 121, 196, 225}, {1, 16, 25, 36, 49,
169, 196, 256}, {1, 9, 36, 81, 100, 121, 144, 256}, {1, 9, 36, 64,
100, 144, 169, 225}, {1, 9, 25, 36, 81, 144, 196, 256}, {1, 9, 16,
49, 100, 121, 196, 256}, {1, 9, 16, 36, 121, 144, 196, 225}, {1, 4,
49, 64, 121, 144, 169, 196}, {1, 4, 25, 64, 81, 121, 196, 256}, {1,
4, 25, 49, 100, 144, 169, 256}, {1, 4, 16, 81, 100, 121, 169,
256}, {1, 4, 16, 25, 100, 121, 225, 256}, {1, 4, 16, 25, 81, 169,
196, 256}, {1, 4, 9, 49, 64, 169, 196, 256}} *)
--- Edit #2 ---
Here is a method that is somewhat generating function related, but unfortunately it is not very efficient. The idea is to expand a certain multinomial to its 7th power, making sure to get no nontrivial powers of factors (as that would correspond to repeated use of elements from our list). We also repress powers that exceed our goal sum.
tv = Total[vars*t^(Range[16]^2)]
(*
t x[1] + t^4 x[2] + t^9 x[3] + t^16 x[4] + t^25 x[5] + t^36 x[6] +
t^49 x[7] + t^64 x[8] + t^81 x[9] + t^100 x[10] + t^121 x[11] +
t^144 x[12] + t^169 x[13] + t^196 x[14] + t^225 x[15] + t^256 x[16] *)
Timing[
expanded =
Nest[Expand[#*tv] /. {x[_]^n_ :> 0,
t^m_ /; m > (Total[vals]/2) :> 0} &, tv, 7];]
(* {2.990000, Null} *)
Coefficient[expanded, t^(Total[vals]/2)]
(*
40320 x[1] x[4] x[8] x[9] x[10] x[11] x[13] x[14] +
40320 x[3] x[6] x[7] x[8] x[9] x[12] x[13] x[14] +
40320 x[1] x[5] x[7] x[8] x[10] x[12] x[13] x[14] +
40320 x[1] x[2] x[7] x[8] x[11] x[12] x[13] x[14] +
40320 x[3] x[6] x[7] x[8] x[10] x[11] x[12] x[15] +
40320 x[4] x[5] x[6] x[9] x[10] x[11] x[12] x[15] +
40320 x[2] x[3] x[8] x[9] x[10] x[11] x[12] x[15] +
40320 x[2] x[4] x[7] x[8] x[10] x[11] x[13] x[15] +
40320 x[2] x[5] x[6] x[8] x[9] x[12] x[13] x[15] +
40320 x[3] x[4] x[6] x[7] x[10] x[12] x[13] x[15] +
40320 x[1] x[3] x[6] x[8] x[10] x[12] x[13] x[15] +
40320 x[2] x[3] x[4] x[9] x[10] x[12] x[13] x[15] +
40320 x[3] x[4] x[6] x[8] x[9] x[11] x[14] x[15] +
40320 x[1] x[4] x[5] x[8] x[10] x[11] x[14] x[15] +
40320 x[3] x[5] x[6] x[7] x[8] x[12] x[14] x[15] +
40320 x[1] x[4] x[6] x[7] x[9] x[12] x[14] x[15] +
40320 x[2] x[3] x[5] x[8] x[9] x[12] x[14] x[15] +
40320 x[1] x[3] x[4] x[6] x[11] x[12] x[14] x[15] +
40320 x[2] x[4] x[5] x[7] x[8] x[13] x[14] x[15] +
40320 x[1] x[3] x[6] x[9] x[10] x[11] x[12] x[16] +
40320 x[2] x[5] x[7] x[8] x[9] x[10] x[13] x[16] +
40320 x[1] x[4] x[6] x[7] x[10] x[11] x[13] x[16] +
40320 x[2] x[3] x[5] x[8] x[10] x[11] x[13] x[16] +
40320 x[1] x[2] x[4] x[9] x[10] x[11] x[13] x[16] +
40320 x[2] x[3] x[6] x[7] x[9] x[12] x[13] x[16] +
40320 x[1] x[2] x[5] x[7] x[10] x[12] x[13] x[16] +
40320 x[1] x[5] x[6] x[7] x[8] x[11] x[14] x[16] +
40320 x[2] x[4] x[5] x[7] x[9] x[11] x[14] x[16] +
40320 x[1] x[2] x[5] x[8] x[9] x[11] x[14] x[16] +
40320 x[1] x[3] x[4] x[7] x[10] x[11] x[14] x[16] +
40320 x[1] x[3] x[5] x[6] x[9] x[12] x[14] x[16] +
40320 x[1] x[4] x[5] x[6] x[7] x[13] x[14] x[16] +
40320 x[1] x[2] x[3] x[7] x[8] x[13] x[14] x[16] +
40320 x[1] x[2] x[4] x[5] x[9] x[13] x[14] x[16] +
40320 x[3] x[4] x[5] x[6] x[9] x[10] x[15] x[16] +
40320 x[2] x[3] x[4] x[6] x[9] x[11] x[15] x[16] +
40320 x[1] x[2] x[4] x[5] x[10] x[11] x[15] x[16] +
40320 x[2] x[3] x[5] x[6] x[7] x[12] x[15] x[16] *)
What would be nice is to have a more sensible way of doing this. By sensible I mean something that extracts a coefficient but does not have to work so hard to repress unwanted terms in a polynomial or series expansion.
Reduce ?
$\endgroup$
Commented
Oct 28, 2013 at 15:29
{{1, 16, 81, 169, 225, 256}, {4, 9, 25, 36, 49, 64, 100, 121, 144, 196}}.
$\endgroup$
c2 in the constraint list. One could modify the other approach by using NestList and keeping lower powers.
$\endgroup$
Commented
Oct 28, 2013 at 21:39
An easy way, using PowersRepresentations[]:
$PowersRepresentations[n,k,p] $ gives the distinct representations of the integer n as a sum of k non-negative p^th integer powers.
s1 = Join@@ (Select[PowersRepresentations[748,#,2], # ⋂ Range@16 == # &] & /@ Range@8)
Gives all possible ways to total 748.
For filtering the ones that are complementaries:
s = Tally[s1, Union[#1, #2] == Range@16 &][[All, 1]];
Length@s
(*
57
*)
This is a small version of a PE problem which asks for counts of certain solutions. If the OP is interested, there is a generating function approach to finding such counts. Consider the product of binomial terms where the power of z is the sequence of squares defined in the problem statement.
Expand[Product[(1 + z^k), {k, Range[16]^2}]]
The coefficient of $z^{748}$ gives the number of ways of writing 748 as a sum of squares from the list of the first 16 squares. The following use ofCoefficientshows there are 114 ways.
Coefficient[Expand[Product[(1 + z^k), {k, Range[16]^2}]], z, 748]
The number of squares m summed for any particular representation of 748 is given by incorporating an additional parameter t. The exponent of t in the coefficient of $z^{748}$ in the following expansion gives the number of squares m.
Coefficient[Expand[Product[(1 + t*z^k), {k, Range[16]^2}]], z, 748]
(* 10 t^6 + 28 t^7 + 38 t^8 + 28 t^9 + 10 t^10 *)
The result shows there must be from m=6 to m=10 squares summed to represent 748, and the number of ways for each m is given by the corresponding coefficient.
The challenge becomes to find such counts when there are 100 rather than simply 16 squares in the original set. Enumerating the partitions is doomed, even expanding the generating function may exceed memory limits. The trick is for the OP, if pursuing PE solutions, to find a recursive method of constructing only the "interesting" part of the generating function.
According to Wikipedia this simple algorithm often works (it only generates a single solution, as is how I interpreted the needs of the OP).
set = Reverse@Sort[{1, 4, 9, 16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256}];
listA = {};
listB = {};
Do[
If[Total[listA] < Total[listB],
AppendTo[listA, i],
AppendTo[listB, i]],
{i, set}
]
{Total[listA], Total[listB]}
{748, 748}
It's iterating through each element and appends it to whatever list has the smallest sum. It's important that the set is in descending order, which is why I put Reverse@Sort in there, even if Sort isn't technically needed for this specific set.
Scan[If[Total[listA] < Total[listB], listA = Flatten[{listA, #}], listB = Flatten[{listB, #}]] &, set] in preference to Do
$\endgroup$
Commented
Oct 28, 2013 at 23:18
Total[listA, Infinity].
$\endgroup$
{16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256}
$\endgroup$
Commented
Oct 29, 2013 at 17:09
I am not aware of an inbuilt function. The following is a brute-force ugly (which I am sure will be put to shame shortly, by some number theory wizardry):
l={1, 4, 9, 16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256};
hits = Select[Subsets[l], Plus @@ # == Plus @@ l/2 &]
{#, Complement[l, #]} & /@ hits
which will run into a lot of trouble for larger lists, but works for your example. There seem to be 114 ways to partition your lists (or half that number, if ordering is not considered).
Finding partitions of equal (or arbitrary) length is very easy using the second argument of Subsets:
hits = Select[Subsets[l, {8}], Plus @@ # == Plus @@ l/2 &]
which reduces the number of combinations to 38 (19).
The following will produce all 114 subsets that total 748. Note: Only 38 of these are of length 8.
d = Table[j^2, {j, 16}];
s=Select[Subsets[d], Total[#] == 748 &];
Length[%]
114
Clearly, the complement of each of these with d, the full set, will return the partitions we seek. We then use Sort and Union to eliminate duplicates, partitions with the elements in both orders.
This results in 57 partitions.
Union[Sort /@ ({#, Complement[d, #]} & /@ s)];
Length[%]
57
With[{sum = Total[#]/2, len = Length[#]},
Reap@Do[If[(#.i == sum), Sow[{Pick[#, i, 1], Pick[#, i, 0]}]],
{i, Tuples[{0, 1}, {len}][[;; 2^(len - 1)]]}]
] &[list]
This is my attempt on solving this (I hope I did not over read something).
I wrote a function SymmetricPartitionSum which takes a list and a goal, where the list has the constraint to be of even length.
SymmetricPartitionSum[list_ /; EvenQ[Length[list]], goal_] :=
Select[Subsets[list, {Length[list]/2}], Total[#] == goal &]
Since your list seems to be the squares: $a(n)=a^2$ you can use this such as:
SymmetricPartitionSum[Table[n^2,{n,1,18}], 751]
=> {{1,4,9,16,25,64,144,196,256},{1,4,9,16,25,81,121,169,289},
{1,4,9,16,36,64,100,196,289},{1,4,9,16,36,81,100,144,324}, ... }
Which you can reuse using Subset to pair the results and pick your favourite.
It would be nice, if Mathematica would provide a Partition definition, which takes a partition criteria as an argument. Which could be a lambda (or a regular function).
With this you can formulate questions like: give me all the partitions of this list of length n, where the partition's point constraint is of following definition...
Here's another approach. It uses a recursive subroutine that, given a list of positive integers, finds all the subsets with a given sum. [EDIT - This is a slightly faster version.]
f[y_,t_] := Block[{F},
F[j_,s_] := If[j == 1, If[ y[[1]] == s, {1},{} ],
Switch[Sign[y[[j]] - s],
1, F[j-1,s]*2,
0,Join[F[j-1,s]*2, {1}],
_,Join[F[j-1,s]*2,
F[j-1,s-y[[j]]]*2 + 1] ] ];
F[Length@y,t] ]
a = f[x = {1,3,5,4,2}, 7]
(* {10, 5, 19} *)
b = IntegerDigits[a, 2, Length@x]
(* {{0,1,0,1,0}, {0,0,1,0,1}, {1,0,0,1,1}} *)
Pick[x,#,1]& /@ b
(* {{3,4}, {5,2}, {1,4,2}} *)
Now use f to find all the partitions of xx into two sublists with the same sum, taking advantage of the symmetry of the problem by getting only the sublists that contain the last element of xx.
t = Tr[ xx = Range[16]^2 ]
s = t/2 - Last@xx
m = MaxMemoryUsed[];
(* 1496 *)
(* 492 *)
AbsoluteTiming@Length[ yy =
Pick[xx,#,1]& /@ IntegerDigits[f[Most@xx,s]*2+1,2,Length@xx] ]
Union[Tr/@yy]*2
m = (Print[#-m];#)&@MaxMemoryUsed[];
(* {0.274014 Second, 57} *)
(* {1496} *)
(* 0 *)
For comparison, here's a faster solution that uses more memory.
AbsoluteTiming@Length[ zz =
Append[#,Last@xx]& /@ (Pick[#,Tr/@#,s]&) @ Subsets[Most@xx] ]
Union[Tr/@zz]*2
m = (Print[#-m];#)&@MaxMemoryUsed[];
(* {0.187110 Second, 57} *)
(* {1496} *)
(* 2985008 *)
zz == Sort@yy
(* True *)
With xx = Range[24]^2 there are 5419 equal-sum partitions; {time, memory} are
{62.63, 1589960} for yy vs {48.67, 1043591688} for zz.
