8
$\begingroup$

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]]];
$\endgroup$

3 Answers 3

9
+50
$\begingroup$
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}}
$\endgroup$
4
  • $\begingroup$ 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! $\endgroup$
    – josh
    Commented May 17 at 16:42
  • 1
    $\begingroup$ @josh Why don't you accept it as an answer then? $\endgroup$ Commented May 17 at 19:15
  • $\begingroup$ Because I appreciate your expertise in the matter and like to post a bounty on it and award it to you $\endgroup$
    – josh
    Commented May 17 at 21:40
  • $\begingroup$ @azerbajdzan nice answer: enjoyed working through it. +1 :) $\endgroup$
    – ubpdqn
    Commented May 18 at 4:27
7
$\begingroup$

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

enter image description here

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]

enter image description here

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:

enter image description here

$\endgroup$
3
  • $\begingroup$ 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? $\endgroup$
    – josh
    Commented May 18 at 23:37
  • $\begingroup$ @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. $\endgroup$
    – ubpdqn
    Commented May 18 at 23:51
  • $\begingroup$ 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. $\endgroup$
    – josh
    Commented May 19 at 13:40
3
$\begingroup$
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}]
$\endgroup$
4
  • $\begingroup$ Nice! Thank you. I'll wait a bit for other suggestions if any and then post the final optimized version. $\endgroup$
    – josh
    Commented May 17 at 16:03
  • $\begingroup$ You will never find terser, more-efficient code. Never. Gosh... not even an upvote?! $\endgroup$ Commented May 17 at 16:10
  • $\begingroup$ 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? $\endgroup$
    – josh
    Commented May 17 at 16:14
  • 3
    $\begingroup$ -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). $\endgroup$
    – JimB
    Commented May 18 at 6:32

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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