Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2003
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2003

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

Search the Archive

Re: Solving Alphametics with Mathematica

  • To: mathgroup at smc.vnet.net
  • Subject: [mg39526] Re: Solving Alphametics with Mathematica
  • From: David Jameson <nospam at nospam.digiportal.com>
  • Date: Fri, 21 Feb 2003 04:08:14 -0500 (EST)
  • References: <auuaku$pjh$1@smc.vnet.net> <av36pf$g00$1@smc.vnet.net> <av6kp3$o1m$1@smc.vnet.net> <av955q$sbp$1@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

Very impressive....more for me to study   (I guess Mathematica programmers
don't use comments  :-)

Seriously though, thanks for taking the time to generalise this solution - I
appreciate it very much.

D

--



"Orestis Vantzos" <atelesforos at hotmail.com> wrote in message
news:av955q$sbp$1 at smc.vnet.net...
> 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: Changing style in Plot
  • Next by Date: Re: Re: Porting graphics to MicroSoft Point, with quality - no
  • Previous by thread: Re: Converting Animations to QuickTime Movies Using iView MediaPro
  • Next by thread: Epsilon-Delta proofs