# Finding all possible solutions to a math mind game

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!

-

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.

-
Thank you for the quick reply and nice approach! But in your case (e.g. sol[[301]]) it would be: e = i = 5. But this is not allowed too (I will make this more clear in my question). How can I get rid of these wrong solutions? –  partial81 Jan 21 at 16:05
Thanks @Öskå for this fantastic add! Unfortunately your code is above my programming knowledge. If you find time, could you please describe shortly how it works? Perhaps you post also a complete new answer, then I would love to accept yours! Anyway, Thanks a lot!! –  partial81 Jan 21 at 16:48
@partial81, a simple Select[sol, Unequal @@ # &] would fix that –  Rojo Jan 21 at 17:03
I knew there was something simpler :D –  Öskå Jan 21 at 17:06
@Rojo! Your add is easy to understand! Thanks a lot, that is really a nice idea! I am very happy about yours, Öskås and Artes help! If I find time, I will join the chat to ask questions about the code. Thanks for the invitation and thanks again for the help! –  partial81 Jan 21 at 17:37

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"]

-
Thank you for this useful post! I like it much that I can define with your solution my terms etc. generally. –  partial81 Feb 8 at 9:51
@partial81: you're quite welcome. I'd forgotten about this quite amusing question! Take a look at post update I'm making: a rudimentary hill-climbing solver for your kind of puzzles that is generally much faster than using MM Solve`. –  rasher Feb 8 at 10:04
Thanks a lot for this great update! This is really a very nice solution too!! –  partial81 Feb 12 at 19:53