MathGroup Archive 2003

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

Search the Archive

Re: Solving Alphametics with Mathematica

  • To: mathgroup at smc.vnet.net
  • Subject: [mg38671] Re: Solving Alphametics with Mathematica
  • From: "Allan Hayes" <hay at haystack.demon.co.uk>
  • Date: Sat, 4 Jan 2003 07:26:03 -0500 (EST)
  • References: <av3669$fpn$1@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

Andrzej,

You say
> but disappointingly NMinimize was unable to find any solution that gave
> 0 for the minimum of Abs.

However, when I ran your code with version 4.2 for Microsoft Windows (June
5, 2002) the expected answer was given:

    eq = 10^3*b + 10^2*a + 10*s + e + 10^3*b + 10^2*a +
        10*l + l - 10^4*g - 10^3*a - 10^2*m - 10*e - s;

    ss = And @@ Union[DeleteCases[Flatten[
    Outer[Abs[#1 - #2] >= 1 & , Variables[eq],
    Variables[eq]]], False], SameTest ->
    (TrueQ[Simplify[First[#1] == First[#2]]] & )];


    Timing[NMinimize[{Abs[eq], 0 <= a <= 9 && 1 <= b <= 9 &&
         0 <= e <= 9 && 1 <= g <= 9 && 0 <= l <= 9 &&
         0 <= m <= 9 && 0 <= s <= 9 &&
         (a | b | e | g | l | m | s) \[Element] Integers && ss},
       Variables[eq]]]

        {106.99*Second, {0., {a -> 4, b -> 7, e -> 3, g -> 1,
            l -> 5, m -> 9, s -> 8}}}

The calculation was slightly quicker with the ss1, calculated below, in
place of ss

    << "DiscreteMath`Combinatorica`"

    ss1 = Abs[Times @@ Apply[Subtract, KSubsets[
            Variables[eq], 2], {1}]] >= 1;

    Timing[NMinimize[{Abs[eq], 0 <= a <= 9 && 1 <= b <= 9 &&
         0 <= e <= 9 && 1 <= g <= 9 && 0 <= l <= 9 &&
         0 <= m <= 9 && 0 <= s <= 9 &&
         (a | b | e | g | l | m | s) \[Element] Integers, ss1},
       Variables[eq]]]

        {96.94*Second, {0., {a -> 4, b -> 7, e -> 3, g -> 1,
            l -> 5, m -> 9, s -> 8}}}


"Andrzej Kozlowski" <andrzej at platon.c.u-tokyo.ac.jp> wrote in message
news:av3669$fpn$1 at smc.vnet.net...
>
> On Wednesday, January 1, 2003, at 05:41 PM, David Jameson wrote:
>
> > Anyone know how to use Mathematic to solve Alphametics puzzles?
> > For example, the sum
> >
> >    B A S E
> > +  B A L L
> > -------------------
> >  G A M E S
> >
> > has only one solution in base 10. I've tried several ways of represent
> > this
> > "sum" in Mathematica but have not been able to get it to solve it.
> >
> > There are lots of other examples of these puzzles at
> > http://www.creativepuzzels.nl/spel/speel1/frameng.htm
> > if anyone is interested.
> >
> > Cheers,
> > David Jameson
> >
>
>
>
> When I first say this question I did the following:
>
>
>
> <<NumericalMath`NMinimize`
>
>
>
> eq=10^3 b + 10^2 a +10 s+ e+10^3 b + 10^2a+10l+l-10^4g-10^3a-10^2m-10e-s
>
>
> NMinimize[{Abs[eq], 0 <= a <= 9 && 1 <= b <= 9 &&
>      0 <= e <= 9 && 1 <= g <= 9 && 0 <= l <= 9 &&
>      0 <= m <= 9 && 0 <= s <= 9 &&
>      Element[a | b | e | g | l | m | s ,Integers], Variables[eq]]
>
>
> {0., {a -> 0, b -> 5, e -> 3, g -> 1, l -> 0, m -> 0,
>     s -> 3}}
>
> So
>
>     5033
>   + 5000
> -------
>    10033
>
> was the solution I posted. However the moderator wrote back (thanks a
> lot!)  pointing out that that some of my variables are equal (a==l==m
> ==0 and e==s), which violates the conditions of the problem (not quite
> clearly stated in my opinion). No problem, I though,t and modified my
> method as follows:
>
>
> ss = And @@ Union[DeleteCases[Flatten[
>        Outer[Abs[#1 - #2] >= 1 & , Variables[eq],
>         Variables[eq]]], False], SameTest ->
>       (TrueQ[Simplify[First[#1] == First[#2]]] & )]
>
>
> Abs[a - b] >= 1 && Abs[a - e] >= 1 && Abs[b - e] >= 1 &&
>    Abs[a - g] >= 1 && Abs[b - g] >= 1 && Abs[e - g] >= 1 &&
>    Abs[a - l] >= 1 && Abs[b - l] >= 1 && Abs[e - l] >= 1 &&
>    Abs[g - l] >= 1 && Abs[a - m] >= 1 && Abs[b - m] >= 1 &&
>    Abs[e - m] >= 1 && Abs[g - m] >= 1 && Abs[l - m] >= 1 &&
>    Abs[a - s] >= 1 && Abs[b - s] >= 1 && Abs[e - s] >= 1 &&
>    Abs[g - s] >= 1 && Abs[l - s] >= 1 && Abs[m - s] >= 1
>
> and then tried:
>
> NMinimize[{Abs[eq], a == 4 && 0 <= b <= 9 &&
>       0 <= e <= 9 && 1 <= g <= 9 && 0 <= l <= 9 &&
>       0 <= m <= 9 && 0 <= s <= 9 && ss &&
>       Element[a | b | e |
>         g | l | m | s , Integers]}, Variables[eq]]
>
> but disappointingly NMinimize was unable to find any solution that gave
> 0 for the minimum of Abs. Of course NMinimize accepts lots of different
> methods and a big array of options so by playing around with them one
> might be able to find one that works. Instead however I tired to reduce
> the complexity of the problem by choosing one variable (I chose a) and
> substituting values for 0 to 9 for it, and then trying the same
> approach again. In other words I evaluated:
>
>
>
> (NMinimize[{Abs[eq /. a -> #1],
>       0 <= a <= 9 && 1 <= b <= 9 && 0 <= e <= 9 &&
>         1 <= g <= 9 && 0 <= l <= 9 && 0 <= m <= 9 &&
>         0 <= s <= 9 && ss && (a | b | e | g | l | m | s) $B":(B
>          Integers /. a -> #1}, Variables[
>       eq /. a -> #1]] & ) /@ Range[0, 9]
>
>
>
>
> {{56., {b -> 5, e -> 3, g -> 1, l -> 9, m -> 2, s -> 8}},
>    {2676., {b -> 9, e -> 3, g -> 2, l -> 8, m -> 0, s -> 7}},
>    {1., {b -> 6, e -> 9, g -> 1, l -> 5, m -> 4, s -> 3}},
>    {247., {b -> 6, e -> 2, g -> 1, l -> 9, m -> 0, s -> 8}},
>    {0., {b -> 7, e -> 3, g -> 1, l -> 5, m -> 9, s -> 8}},
>    {1., {b -> 7, e -> 8, g -> 1, l -> 4, m -> 0, s -> 3}},
>    {255., {b -> 8, e -> 7, g -> 1, l -> 0, m -> 9, s -> 2}},
>    {1., {b -> 8, e -> 9, g -> 1, l -> 5, m -> 4, s -> 3}},
>    {864., {b -> 9, e -> 6, g -> 1, l -> 0, m -> 7, s -> 2}},
>    {1., {b -> 9, e -> 6, g -> 1, l -> 5, m -> 8, s -> 0}}}
>
>
> As you can see, it finds the right answer, with a->4 and {b -> 7, e ->
> 3, g -> 1, l -> 5, m -> 9, s -> 8}. I do find it  a little strange that
> the more straight forward method does not work but this rather obvious
> modification does.
>
>
>
> Andrzej Kozlowski
> Yokohama, Japan
> http://www.mimuw.edu.pl/~akoz/
> http://platon.c.u-tokyo.ac.jp/andrzej/
>
>




  • Prev by Date: MathROOT version 0.8.2.0 (stable) released
  • Next by Date: Re: Solving Alphametics with Mathematica
  • Previous by thread: Re: Solving Alphametics with Mathematica
  • Next by thread: Re: Solving Alphametics with Mathematica