Finding all possible solutions to a math mind game

Question

In the example below the letters shall be replaced by numbers. The numbers are from 1 to 9, and each letter has the same number (e.g. E = 4 all the time. Different letters must have different numbers, so E = W = 4 is not allowed):

If one choose e.g. E = 4 (and some other numbers for the other letters), it can be easily seen that

is not a correct solution because E is in the first two rows 4 but not in the third row!

After some attempts I found that

is a solution.

I know that there are also some other solutions which solve this problem correctly. So, my question is: How can I find with Mathematica (9.0.1) ALL possible solutions?

My approach is the following: I create an array with all possible combinations:

values = 
Table[{(z*1000 + w*100 + e*10 + i), (v*1000 + i*100 + e*10 + r), 
(z*1000 + w*100 + e*10 + i) + (v*1000 + i*100 + e*10 + r)}, 
{z, 1, 9}, {w, 1, 9}, {e, 1, 9}, {i, 1, 9}, {v, 1, 9}, {r,1, 9}];

And then I want to search in the array values for the correct combinations. But I have some problems to write a nice searching-program for this. Could anybody help?

I also have doubts if it is a good idea to create such a big values-array because I create numbers like 1111 which are forbidden. Is there a way that I can create a leaner array?

Or does anybody have another nice idea how I could find all correct solutions for this problem?

I would be very happy about any help!

Answer 1

There are many solutions but not so many that Solve wouldn't be the right way to go. Since the task has been changed I slightly refine the solution. First we find all integer solutions satisfying 1 <= x <= 9 with Solve:

sol1 = {z, w, e, i, v, r, f, u, n} /. 
Solve[ Join[{1000 z + 100 w + 10 e + i + 1000 v + 100 i + 10 e + r ==
             10000 f + 1000 u + 100 e + 10 n + f}, 
             Thread[ 1 <= # <= 9 & @ {z, w, e, i, v, r, f, u, n}]], 
       {z, w, e, i, v, r, f, u, n}, Integers];

Length @ sol1

2673

Then we choose only solutions with different digits using Select[ sol1, Unequal @@ # &] as proposed by Rojo in the comments. Alternative approach using {Unequal @@ {z, w, e, i, v, r, f, u, n}} in Solve is not recommended since it would be very inefficient.

sol = Select[ sol1, Unequal @@ # &]

{{4, 2, 8, 5, 9, 6, 1, 3, 7}, {6, 4, 3, 9, 8, 2, 1, 5, 7}, 
 {6, 9, 2, 3, 7, 8, 1, 4, 5}, {7, 9, 2, 3, 6, 8, 1, 4, 5}, 
 {8, 4, 3, 9, 6, 2, 1, 5, 7}, {9, 2, 8, 5, 4, 6, 1, 3, 7}}

Let's rewrite solutions in the standard representation:

{ 1000 #1 + 100 #2 + 10 #3 + #4, 1000 #5 + 100 #4 + 10 #3 + #6, 
 10000 #7 + 1000 #8 + 100 #3 + 10 #9 + #7} & @@@ sol

{{4285, 9586, 13871}, {6439, 8932, 15371}, {6923, 7328, 14251}, 
 {7923, 6328, 14251}, {8439, 6932, 15371}, {9285, 4586, 13871}}

And check the solutions:

And @@ ( #1 + #2 == #3 & @@@ %)

True

Edit

The question is not quite clear whether "The numbers are from 1 to 9" (see the first line) or "from 0 to 9" as suggests the second example. One might also assume that all numbers are from 0 to 9" except for f.

In all cases Solve provides quite simple and flexible approach. The case of "numbers are from 1 to 9" we considered above.

II

"all numbers form 0 to 9"

sol2 = {z, w, e, i, v, r, f, u, n} /. 
Solve[ Join[{1000 z + 100 w + 10 e + i + 1000 v + 100 i + 10 e + r 
             == 10000 f + 1000 u + 100 e + 10 n + f}, 
            Thread[ 0 <= # <= 9& @ {z, w, e, i, v, r, f, u, n}]], 
       {z, w, e, i, v, r, f, u, n}, Integers];

There are

Length @ Select[ sol2, Unequal @@ # &]

 46

solutions

III

"all numbers form 0 to 9 except for f"

Obviously this implies that f == 1 and impose this condition onto Solve, but the former aproach works quite well:

sol3 = {z, w, e, i, v, r, f, u, n} /. 
Solve[ Join[{1000 z + 100 w + 10 e + i + 1000 v + 100 i + 10 e + r
             == 10000 f + 1000 u + 100 e + 10 n + f}, 
       Thread[ 0 <= # <= 9& @ {z, w, e, i, v, r, f, u, n}], {f > 0}], 
       {z, w, e, i, v, r, f, u, n}, Integers];

Now we have only

Length @ Select[ sol3, Unequal @@ # &]

14

solutions.

Answer 2

Here's a solution that lets you define terms/sum/entries/constraints generally. Spits out a table where rows are valid values for the corresponding column variables with verification of solutions.

ClearAll[z, w, e, i, v, r, f, u, n];

(* Define alphabet,terms, and sum *)
vars = {z, w, e, i, v, r, f, u, n};
term1 = {z, w, e, i};
term2 = {v, i, e, r};
sum = {f, u, e, n, f};

(* Define Constraints *)
(* minimum and maximun values *)
{min, max} = {0, 9};

(* must all letters assume differing values? *)
mustDiffer = False;

(* Additional constraints, use {} for none *)
conditions = {r > e && n > w > 5 && v > 8 && z > 7};

(* Solve It *)
solutions = TableForm[Select[vars /. Solve[Join[{FromDigits[term1] +
          FromDigits[term2] == FromDigits[sum]},
       Table[min <= zz <= max, {zz, vars}], conditions], vars, Integers],
    ! mustDiffer || Unequal @@ # &], TableHeadings -> {None, vars}];

(* Display Results & Checks *)
If[solutions[[1]] == vars || solutions[[1]] == {}, "No solutions found for given",
 Labeled[solutions, {Length[solutions[[1]]] "Solutions found for given\n", 
    "\nCheck all ok:" (varSave = SymbolName /@ vars; 
      res = And @@ ((ToExpression[ToString[varSave] <> "=" <> ToString[#]]; 
            FromDigits[term1] + FromDigits[term2] == FromDigits[sum]) & /@solutions[[1]]); 
      ClearAll @@ varSave; res)},
   {Top, Bottom}] // Framed]

Here's another way of doing this, a rudimentary hill-climbing solver that is usually much faster than using Mathematica's Solve, particularly when there are more than two terms and/or terms are lengthy:

(* hill climber *)
ClearAll["Global`*"]

terms = {{s, e, n, d}, {m, o, r, e}, {m, o, n, e, y}};
terms = {{f, i, f, t, y}, {s, t, a, t, e, s}, {a, m, e, r, i, c, a}};
terms = {{z, w, e, i}, {v, i, e, r}, {f, u, e, n, f}};
terms = {{f, o, r, t, y}, {t, e, n}, {t, e, n}, {s, i, x, t, y}}

{letters, nonos} = {Union @@ terms, Union@terms[[All, 1]]};
{nonopos, numletters} = {Position[letters, #] & /@ nonos // Flatten, 
   Length[letters]};
check = Total[FromDigits /@ (Join[Most[terms], -{Last[terms]}])];

integers = N[Range[0, 9]];
While[Times @@ (numbers = RandomSample[integers, 10])[[nonopos]] == 0];

{curscore, testcnt, guard} = {Infinity, 0, 100000};
{swaps, bump, bumpthreshold} = {RandomInteger[{1, 10}, {guard, 2}], 
   RandomInteger[200, guard], 4};

mapper := Thread[letters -> Take[numbers, numletters]];

swapper := (keeps = numbers; 
   numbers[[swaps[[testcnt]]]] = 
    numbers[[swaps[[testcnt]] // Reverse]]; 
   If[Times @@ numbers[[nonopos]] == 0., testcnt++; numbers = keeps; 
    swapper]);

While[++testcnt <= guard && curscore != 0,
  keeps = numbers;
  swapper;
  newscore = Abs[check /. mapper];
  curscore = 
   If[bump[[testcnt]] < bumpthreshold, newscore, 
    If[newscore < curscore, newscore, numbers = keeps; curscore]]];

If[curscore == 0, 
 TableForm[{{terms, Round[terms /. mapper], 
    testcnt, (check /. mapper) == 0}}, 
  TableAlignments -> {Right, Right, Right}], "None found"]