4
$\begingroup$

I'm trying to solve an equation of this type on integers

(10 - x) (6 - y) (4 - z) (3 - w) == x*y*z*w

for

1 <= x <= 10 
1 <= y <= 6
1 <= z <= 4 
1 <= w <= 3

I tried Solve and Reduce and they work fine

Reduce[(10 - x) (6 - y) (4 - z) (3 - w) == x*y*z*w 
&& 1 <= x <= 10 &&  1 <= y <= 6 && 1 <= z <= 4 && 1 <= w <= 3, {x, y, z, w}, Integers]

Solve[(10 - x) (6 - y) (4 - z) (3 - w) == x*y*z*w && 1 <= x <= 10 && 
1 <= y <= 6 && 1 <= z <= 4 && 1 <= w <= 3, {x, y, z, w}, Integers]

they both give the right answer

The problem is that I need to Solve bigger equations (of the same type) with more variables like

ClearAll[x, y, z, w, a, b, c, d]
Solve[(20 - x) (10 - y) (6 - z) (4 - w) (3 - a) (3 - b) (3 - c) (3 - d) == x*y*z*w*a*b*c*d 
&& 1 <= x <= 20 && 1 <= y <= 10 && 
1 <= z < 6 && 1 <= w < 4 && 1 <= a <= 3 && 1 <= b <= 3 && 
1 <= c < 3 && 1 <= d < 3, {x, y, z, w, a, b, c, d}, Integers]

but even the above one (with 8 variables) takes forever (this one should return 272 solutions)

In fact I want to solve an equation with more than 20 variables

What is the most efficient way to solve equations like these?

I want the "number of solutions" of this one

Reduce[(99 - a) (50 - b) (26 - c) (18 - d) (11 - e) (9 - f) (7 - 
  g) (7 - h) (6 - i) (5 - j) (5 - k) (4 - l) (4 - m) (4 - n) (4 - 
  o) (3 - p) (3 - q) (3 - r) (3 - s) (3 - t) (3 - u) (3 - v) (3 - 
  w) (3 - x) (3 - y) == 
  a*b*c*d*e*f*g*h*i*j*k*l*m*n*o*p*q*r*s*t*u*v*w*x*y && 1 <= a <= 99 &&
 1 <= b <= 50 && 1 <= c <= 26 && 1 <= d <= 18 && 1 <= e <= 11 && 
 1 <= f <= 9 && 1 <= g < 7 && 1 <= h < 7 && 1 <= i <= 6 && 
 1 <= j <= 5 && 1 <= k <= 5 && 1 <= l <= 4 && 1 <= m <= 4 && 
 1 <= n <= 4 && 1 <= o <= 4 && 1 <= p <= 3 && 1 <= q <= 3 && 
 1 <= r <= 3 && 1 <= s < 3 && 1 <= t <= 3 && 1 <= u <= 3 && 
 1 <= v <= 3 && 1 <= w < 3 && 1 <= x < 3 && 1 <= y < 3, {a, b, c, d, 
 e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, 
 y}, Integers]
$\endgroup$

3 Answers 3

5
$\begingroup$

a wee bit of a speed up over complete brute force:

lims = {99, 50, 26, 18, 11, 9, 7, 7, 6, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 
   3, 3, 3, 3, 3, 3};
lims = lims[[;; 5]];
n = Length@lims;
x0 = Table[Symbol["x" <> ToString[i]], {i, n}];
      (*better to use raw symbols for iterators*)
prodx0 = Product[x0[[i]], {i, Length@lims}]
prod1 = Product[lims[[i]] - x0[[i]], {i, Length@lims}]

solve for one of the variables (The one with the largest range )

test = x0[[1]] /. First@Solve[ prodx0 == prod1 , x0[[1]]]

(99 (50 - x2) (26 - x3) (18 - x4) (11 - x5))/((50 - x2) (26 - x3) (18 - x4) (11 - x5) + x2 x3 x4 x5)

now loop over n-1 variables, checking for the remaining one to be an integer.

sol = Reap[
 Do[If[IntegerQ[test], Sow[Flatten[{test, x0[[2 ;;]]}]]], 
   Evaluate[
    Sequence @@ Transpose[{x0[[2 ;;]], lims[[2 ;;]] - 1}]]]][[2]]

This finds 1785 solutions to the length 5 problem in about 2 seconds.

$\endgroup$
3
  • $\begingroup$ You just saved 1.96 millions years of computation :) Could you explain what it wrong with Subscript iterator? $\endgroup$
    – anderstood
    Apr 13, 2017 at 22:18
  • $\begingroup$ this is really fast! unfortunately it can't solve my equation but it's the fastest from all of my approaches. thanks for your help $\endgroup$
    – ZaMoC
    Apr 13, 2017 at 23:45
  • $\begingroup$ i do not know why, but for some reason when you have a lot of iterators its better the have x1,x2,x3.. rather than x[1],x[2],.. or subscripts. For something like this you never see them anyway. $\endgroup$
    – george2079
    Apr 14, 2017 at 0:32
3
$\begingroup$

It may not suit your needs, but using a brute force approach, you can find the 272 solutions. First, observe that $x=20$, $y=10$, etc. will not lead to solutions, so it suffices to consider $1\leq x \leq 19$, $1\leq y \leq 9$, etc.

Flatten[Table[
   If[(20 - x) (10 - y) (6 - z) (4 - w) (3 - a) (3 - b) (3 - c) (3 - 
    d) - x*y*z*w*a*b*c*d == 0, {x, y, z, w, b, c, d}, 
    Unevaluated[Sequence[]]], {x, 1, 19}, {y, 1, 9}, {z, 1, 5}, {w, 1, 3},
       {a, 1, 2}, {b, 1, 2}, {c, 1, 2}, {d, 1, 2}], 7]

(* 272 *)

Unevaluated[Sequence[]] is just to prevent If to return Null, see this answer.

Using Reduce or Solve would be neater, but at least this approach returns the solutions in about 0.2 seconds.

For even more variables, the computation time will increase exponentially, but might be reasonable depending on your problem. You can use ParallelTable and also, print solutions as they are coming out and track the process, at least.

You could even try a combination of this approach and Reduce (e.g. brute force for the $n-4$ first variables and Reduce for the other ones).

Edit For the more complex problem you added, the following should work... if you could wait for $10^{12}$ minutes (approx. 2 millions years only).

lims = {99, 50, 26, 18, 11, 9, 7, 7, 6, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 
   3, 3, 3, 3, 3, 3};
lims = lims[[1 ;; 5]]; (* remove this line for full computation ! *)
n = Length@lims;
x0 = Array[Subscript[x, #] &, n];
prodx0 = Product[x0[[i]], {i, Length@lims}];
prod1 = Product[lims[[i]] - x0[[i]], {i, Length@lims}];
sols = Flatten[
    ParallelTable[
     If[prod1 - prodx0 == 0, x0, Unevaluated[Sequence[]]], 
     Evaluate[Sequence @@ Transpose[{x0, lims - 1}]]], 
    n - 1]; // AbsoluteTiming
$\endgroup$
0
$\begingroup$

I doubt this is going to help with the largest problems, but you can set this up more easily -- let min be a vector with all the minumum values for the variables and max be all the maximum values. Then you can write the equations without explicitly writing out all the variables:

min = {1, 1, 1, 1}; max = {10, 6, 4, 3};
Solve[{Product[(max[[i]] - x[i]), {i, 1, Length[min]}] == 
    Product[x[i], {i, 1, Length[min]}], 
   Thread[min <= Array[x, Length[min]] <= max]} // Flatten, 
 Array[x, Length[min]], Integers]
$\endgroup$

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.