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/
>
>