# Optimizing alphametrics code

First of all, thank you all in this great community. I have been reading a lot of threads about Mathematica optimization learning things like using Compile and Listable functions to get the code nice and smooth and I'm impressed to see what this community is capable of.

I'm currently programming an Alphametrics solver. For those of you that does not know what an alphametrics is, I recommend you to read this great Wikipedia entry: http://en.wikipedia.org/wiki/Verbal_arithmetic.

The code that i'm using is this

solveAlphametic[lhs_ == rhs_] :=
Module[{lhsChars, rhsChars, check},
lhsChars = Union @@ Cases[lhs, s_String :> Characters[s], Infinity];
rhsChars = Complement[Characters[rhs], lhsChars];
With[{len = Length[lhsChars], lhsChars = lhsChars},
check[lst_] /; Length[Union[lst]] == len :=
Module[{lhsRulz, res, rhsPattern},
res =
IntegerDigits[
lhs /. s_String :> FromDigits[Characters[s] /. lhsRulz]];
rhsPattern =
With[{rhsSymbols = Symbol /@ rhsChars,
rhsRulz = (# -> Pattern[Evaluate[Symbol[#]], _] &) /@
rhsChars}, (Characters[rhs] /. lhsRulz /. rhsRulz) /;
Intersection[rhsSymbols, lst] == {}];
If[MatchQ[res, rhsPattern],
Map[check, perm[[len]]];]]


The code works perfectly (for example: solveAlphametic["send" + "more" == "money"] gives you {d->7,e->5,m->1,n->6,o->0,r->8,s->9,y->2} ) but is absurdly slow (42.130000 seconds in my computer).

There are online solvers that run this solution in 1 or two seconds and I'm wondering how can one optimize the previous code to achieve the best results.

• A very different method that works tolerably well is to set up an explicit integer linear programming (ILP) branch-and-prune loop. Weight the higher digits first in terms of which to branch on and it goes reasonably well. (Failure to weight means you'll have a long wait, as I have learned from personal experience.) There are several approaches here and the ILP-based method, which does not do this weighting, is indeed slow. Dec 17, 2014 at 19:13

You can use Solve for this but you have to do a little work to transform your "equation" in to a usable form.

This is what my cobbled together makeExpression function does. (It also generates the conditions to ensure that the first letter of each word cannot be zero):

makeExpression[expr_] :=
Module[{ie,
r = Reap[
expr /. x_String :>
Module[{c =
Symbol /@ Characters[x]}, (Sow[{First[c], Union[Rest[c]]}];
Fold[10 #1 + #2 &, 0, c])] // Simplify]},
ie = Union[Flatten[#]] & /@ Transpose[r[[2, 1]]];
And[r[[1]], And @@ (0 < # < 10 & /@ First[ie]),
And @@ (0 <= # < 10 & /@ Last[ie])]]


Then use this in Solve and select the solution(s) that have the same number of values as there are variables.

solveAlphametic2[expr_] :=
Module[{am = makeExpression[expr]},
Select[Solve[am, Union @@ (Variables /@ First[am]), Integers],
Length[#] == Length[Union[#[[All, 2]]]] &]]


Note that you must ensure that the symbols given by the characters in your words have no definitions.

solveAlphametic2["send" + "more" == "money"]


{{d -> 7, e -> 5, m -> 1, n -> 6, o -> 0, r -> 8, s -> 9, y -> 2}}

This is somewhat quicker than 42 seconds.

• Wow, that is so clever. Thank you very much! I really like this approach. Dec 17, 2014 at 19:10
• Hey! I just realise that there are some cases in which Union @@ (Variables /@ First[am]) return {} because (Variables /@ First[am]) gives False. Replacing that for the not-so-elegant Union[Variables [First[am][[1]]], Variables [First[am][[2]]]] solves that problem. Dec 17, 2014 at 19:58
• @PabloGalindoSalgado As I said, "Cobbled together" :-). I'll update my answer! Thanks Dec 17, 2014 at 20:01