# How to improve code finding x+y+z+w=40 to generate numbers 1 through 40?

Edit: Appended work to find generators for any number as per azerbajdzan and ubpdqn. See below

Ran into this problem and was wondering if there is a more elegant and concise way of coding this if anyone is interested. Can we code it in a single line using Maximize? Is there a way to generate all 64 expressions without hard-coding like I did below? I tried but had problems with the constructs.

Have four numbers (x,y,z,w) such that x+y+z+w=40. Find the numbers such that can add or subtract some or all in order to generate numbers 1 through 40.

Here's my code:

ClearAll[x, y, z, w]
(* generate all 9139 different ways of combining 4 number*)
integerSet =
FindInstance[
x + y + z + w == 40 && 1 <= x <= 40 && 1 <= y <= 40 &&
1 <= z <= 40 && 1 <= w <= 40, {x, y, z, w}, Integers, 10000];
Length@DeleteDuplicates@Sort[({x, y, z, w} /. integerSet)]
(* generate all possible combinations of adding or subtracting some
or all the numbers, join (x,y,z,w) at end too *)
countTable = Table[
theList = integerSet[[j]];
rocks = {x, y, z, w} /. theList;
numList = {(x + y), (x - y), (x + z), (x - z), (x + w), (x -
w), (y + z), (y - z), (y + w), (y - w), (z + w), (z - w), (x +
y + z), (x + y - z), (x - y + z), (-x + y + z), (x - y -
z), (-x + y - z), (-x - y + z), (x + y + w), (x + y - w), (x -
y + w),
(-x + y + w), (x - y - w), (-x + y - w), (-x - y + w), (x + z +
w), (x + z - w), (x - z + w), (-x + z + w), (x - z - w), (-x +
z - w),
(-x - z + w), (y + z + w), (y + z - w), (y - z + w), (-y + z +
w), (y - z - w), (-y + z - w), (-y - z + w), (y + x + w), (y +
x - w),
(y - x + w), (-y + x + w), (y - x - w), (-y + x - w), (-y - x +
w), (x + y + z + w), (x + y + z - w), (x + y - z + w), (x -
y + z + w),
(-x + y + z + w), (x + y - z - w), (x - y - z + w), (-x - y +
z + w), (x - y + z - w), (-x + y - z + w), (x - y - z -
w), (-x - y + z - w),
(-x - y - z + w)
} /. theList;
{rocks,
Sort@DeleteDuplicates[Select[Join[numList, rocks], # > 0 &]]},
{j, 1, Length@integerSet}
];
(* find maximum length of values *)
maxNum = Max@(Length@#[[2]] & /@ countTable)
Select[countTable, Length@#[[2]] == maxNum &]

(* {{{27, 9, 3, 1}, {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32,
33, 34, 35, 36, 37, 38, 39, 40}}} *)


Edit section

With help by azerbajdzan and ubpdqn below, I was able to put together some info about enumerating a number $$N$$ with $$K$$ generators $$G$$. For example, enumerating numbers $$1$$ through $$40$$ with generators $$\{1,3,9,27\}$$

In order to enumerate a number $$N$$ by a minimum number of generators $$K$$, we use ubpdqn's work with powers of $$3$$ explained below in his post. This gives the largest number $$N_k=\sum_{j=0}^{K-1}$$ enumerated by $$K$$ generators $$G=\displaystyle \{3^j\}_{j=0}^{j=K-1}=\{1,3,9,\cdots,3^{K-1}\}$$. This leads to the following table which list the range of numbers $$\{N\}$$ requiring a minimum number $$K$$ of generators $$G$$ with the upper bound in each range equal to $$N_k$$:

$$\begin{array}{|c|c|} \hline \text{K} & \text{Range} \\ \hline 2 & \{2,4\} \\ 3 & \{5,13\} \\ 4 & \{14,40\} \\ 5 & \{41,121\} \\ 6 & \{122,364\} \\ 7 & \{365,1093\} \\ 8 & \{1094,3280\} \\ 9 & \{3281,9841\} \\ 10 & \{9842,29524\} \\ 11 & \{29525,88573\} \\ 12 & \{88574,265720\} \\ 13 & \{265721,797161\} \\ 14 & \{797162,2391484\} \\ 15 & \{2391485,7174453\} \\ 16 & \{7174454,21523360\} \\ 17 & \{21523361,64570081\} \\ 18 & \{64570082,193710244\} \\ 19 & \{193710245,581130733\} \\ 20 & \{581130734,1743392200\} \\ \hline \end{array}$$

Take for example $$K=5$$ with range $$\{41,121\}$$. This means that $$41$$ cannot be generated by $$4$$ digits and $$122$$ cannot be generated by $$5$$ digits. The upper and lower end points of each range is easily computed by the formula for $$N_k$$. I propose as an hypothesis based on a preliminary study: Generators for the remaining points in each range can be determined by

$$\large G=\bigg\{3^{n}\bigg\}_{n=0}^{K-2}\cup \bigg(N-\sum_{n=0}^{K-2}\bigg)$$

For example, let $$N=25000$$ which can be enumerated by $$10$$ generators:

$$\{1,3,9,27,81,243,729,2187,6561,15159\}$$

This is the code I used to check this assertion:

theK = 10
theN = 25000

theIterate =
Join[Table[
3^n, {n, 0, theK - 2}], {theN -
Total[Table[3^n, {n, 0, theK - 2}]]}];
Print["theIterate: ", theIterate];
tu = Tuples[{-1, 0, 1}, {theK}];
Print["Number enumerated: ",
ContainsAll[Total[theIterate #] & /@ tu, Range[theN]]];


fu[x_, n_] :=
With[{tu = Tuples[{-1, 0, 1}, {n}], ra = Range[x]},
Select[IntegerPartitions[x, {n}],
ContainsAll[(f |-> Total[f*#]) /@ tu, ra] &]]


For x==40 and n==4:

fu[40, 4]


{{27, 9, 3, 1}}


For example for 30 we have more possibilities:

fu[30, 4]


{{20, 7, 2, 1}, {20, 6, 3, 1}, {19, 7, 3, 1}, {18, 8, 3, 1}, {17, 9, 3, 1}}


For 100 there is no solution with 4 numbers:

fu[100, 4]


{}


But for 100 with 5 numbers there are solutions:

fu[100, 5]


{{67,22,7,3,1},{67,21,8,3,1},{67,20,9,3,1},{66,23,7,3,1},{66,22,8,3,1},
{66,21,9,3,1},{65,23,8,3,1},{65,22,9,3,1},{64,24,8,3,1},{64,23,9,3,1},
{63,25,8,3,1},{63,24,9,3,1},{62,25,9,3,1},{61,26,9,3,1},{60,27,9,3,1}}

• Very Nice azerbajdzan! I'll work on it later to figure out what's happening. Yours is a nice way of figuring out what combination of N numbers added together equal 100 and can generate all numbers 1 through 100 or are there sets with no solution? Will look at that one too!
– josh
Commented May 17 at 16:42
• @josh Why don't you accept it as an answer then? Commented May 17 at 19:15
• Because I appreciate your expertise in the matter and like to post a bounty on it and award it to you
– josh
Commented May 17 at 21:40
• @azerbajdzan nice answer: enjoyed working through it. +1 :) Commented May 18 at 4:27

This is not an answer but an observation regarding base problem.

It is, therefore, a comment. I have voted for @azerbajdzan answer which is very nice and applies to general question.

I post this as an (hopefully) amusing comment but also to illustrate some Wolfram Language/Mathematica nice functionalities wrt to exposition.

This question is related to the coin denomination puzzle: minimum number of coins that could represent values range from 1 to 40. The unique answer of powers of 3 is a nice feature of ternary representations of numbers 1 to 40 (note $$\sum^3_{i=0} 3^i =\frac{81-1}{2}=40$$. All the numbers can be represented using ternary representation, e.g.

i = IntegerDigits[#, 3, 4] & /@ Range[40];
a = {27, 9, 3, 1};
ans = a . # & /@ i;
func[u_] :=
Row[Join @@ MapIndexed[Table[a[[#2[[1]]]], #1] &, u] /. {} ->
Nothing, "+"]
Row[#, "="] & /@ Thread[{func /@ i, ans}] // Column


Exploiting the fact that 2 = 3-1, the relevant +/- can derived.

v = PowerRange[x^3, 1, 1/x];
pol[u_] :=
NestWhile[
Expand[(Coefficient[#, x, Range[3, 0, -1]] /. {2 -> x - 1}) . v] &,
u . v, Max[Coefficient[#, x, Range[3, 0, -1]]] == 2 &]
Column[Row[{HoldForm[#], #}, "="] /.
Thread[v -> PowerRange[27, 1, 1/3]] & /@ (pol /@ i),
Alignment -> Left]


Update This is update in relation to comment. For case for n numbers adding to $$\frac{3^n - 1}{2}$$.

tern[n_] :=
Module[{i = IntegerDigits[#, 3, n] & /@ Range[(3^n - 1)/2],
v = PowerRange[x^(n - 1), 1, 1/x],
r = PowerRange[3^(n - 1), 1, 1/3], poly},
poly[u_] :=
NestWhile[
Expand[(Coefficient[#, x, Range[n - 1, 0, -1]] /. {2 -> x - 1}) .
v] &, u . v,
Max[Coefficient[#, x, Range[n - 1, 0, -1]]] == 2 &];
Column[
Row[{HoldForm[#], #}, "="] /. Thread[v -> r] & /@ (poly /@ i),
Alignment -> Left]]


For example tern[6] as per comment:

• Is it always true then that the largest number $N$, that can be $\pm$-iterated as above by $k$ digits is $$\displaystyle\sum_{j=0}^{k-1} 3^j$$ with iterated digits $$\displaystyle\{3^j\}_{j=0}^{k-1}$$? For example, take $k=6$, then $N=364$ with iterates $\{1,3,9,27,81,243\}$? So basically this is the simplest way to solve this problem?
– josh
Commented May 18 at 23:37
• @josh for this special case you can just apply the approach I used second, so derive sums. azerbajdzan answer deals with more general case which are not as simple. Commented May 18 at 23:51
• But the others that are not sum of powers of 3 are easily found using as seeds, the lower powers. For example, consider enumerating $1$ through $1338105$ using a $14$-digit sequence of numbers. The sequence is simply: $$\{1, 3, 9, 27, 81, 243, 729, 2187, 6561, 19683, 59049, 177147, 531441,540944\}$$. I'll write it up and update my post above when I post the bounty.
– josh
Commented May 19 at 13:40
Length@IntegerPartitions[40, {4}]


(* 478 *)

IntegerPartitions[40, {4}]


If you need to do this for every 0 < n < 41:

Table[Length@IntegerPartitions[n,{4}],{n,40}]

• Nice! Thank you. I'll wait a bit for other suggestions if any and then post the final optimized version.
– josh
Commented May 17 at 16:03
• You will never find terser, more-efficient code. Never. Gosh... not even an upvote?! Commented May 17 at 16:10
• It's terse but your code only generates possible combinations of 4 numbers. Is there a concise Mathematica construct to find the combination that generates all numbers from 1 through 40?
– josh
Commented May 17 at 16:14
• -1 @josh is more diplomatic than I am. Your response completely misinterprets the question. I certainly don't understand why there are 5 upvotes (so far).
– JimB
Commented May 18 at 6:32