Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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):

Problem

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

Wrong solution

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

One possible solution

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!

share|improve this question
add comment

2 Answers

up vote 13 down vote accepted

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.

share|improve this answer
    
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
3  
@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
show 9 more comments

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]

enter image description here

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"]
share|improve this answer
    
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
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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