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},
lhsRulz = Thread[lhsChars -> lst];
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],
Print[Union[Thread[Characters[rhs] -> res], lhsRulz]]]];
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.