MathGroup Archive 2003

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Solving Alphametics with Mathematica

  • To: mathgroup at smc.vnet.net
  • Subject: [mg38691] Re: Solving Alphametics with Mathematica
  • From: atelesforos at hotmail.com (Orestis Vantzos)
  • Date: Sun, 5 Jan 2003 06:33:58 -0500 (EST)
  • References: <auuaku$pjh$1@smc.vnet.net> <av36pf$g00$1@smc.vnet.net> <av6kp3$o1m$1@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

OK, here it goes:

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]]]];
       Do[check[IntegerDigits[n, 10, len]], {n, 1, 10^len - 1}]]
  ]

In[34]:=
solveAlphametic["ball" + "base" == "games"]

{a -> 4, b -> 7, e -> 3, g -> 1, l -> 5, m -> 9, s -> 8}

This code is much more involved, but (hopefully) solves many
alphametics.
OK, let's say we want to check whether 45679 is a solution.
Check does the following:
45679 is turned into {4,5,6,7,9}
It is checked to see whether it contains duplicate digits
(Length[Union[lst]]==len).
lhsRulz = {"a"->4, "b"->5, "e"->6, "l"->7, "s"->9}
"ball"+"base" is evaluated in one pass using the lhsRulz to give 
   5477+5496 = 10973 ---> res = {1,0,9,7,3}
Now we create rhsPattern which is a template for what "games" should
be:
rhsPattern = {g_, 4, m_, 6, 9}/;Intersection[{g,m},{4,5,6,7,9}]=={}
Comparing res with rhsPattern we see that it is not so, and check
proceeds to the next number.
Should our number be a solution, we create a set of replacements for
"games" -similar to lhsRulz- unify it with lhsRulz and display it.

Hope that helped,
Orestis


  • Prev by Date: Re: Re: OOP experiments in Mathematica- The Stack
  • Next by Date: Re: OOP experiments- Component
  • Previous by thread: Re: Re: Solving Alphametics with Mathematica
  • Next by thread: Re: Can I creating any 3d objects or scenes with Mathematica?