12
$\begingroup$

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!

Improve this question
$\endgroup$

2 Answers 2

Reset to default
14
$\begingroup$

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.

Improve this answer
$\endgroup$
14
  • $\begingroup$ 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? $\endgroup$ Commented Jan 21, 2014 at 16:05
  • $\begingroup$ 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!! $\endgroup$ Commented Jan 21, 2014 at 16:48
  • 3
    $\begingroup$ @partial81, a simple Select[sol, Unequal @@ # &] would fix that $\endgroup$ Commented Jan 21, 2014 at 17:03
  • $\begingroup$ I knew there was something simpler :D $\endgroup$ Commented Jan 21, 2014 at 17:06
  • $\begingroup$ @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! $\endgroup$ Commented Jan 21, 2014 at 17:37
9
$\begingroup$

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"]
Improve this answer
$\endgroup$
3
  • $\begingroup$ Thank you for this useful post! I like it much that I can define with your solution my terms etc. generally. $\endgroup$ Commented Feb 8, 2014 at 9:51
  • $\begingroup$ @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. $\endgroup$ Commented Feb 8, 2014 at 10:04
  • $\begingroup$ Thanks a lot for this great update! This is really a very nice solution too!! $\endgroup$ Commented Feb 12, 2014 at 19:53

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.