Re: Re: Arithmetic Puzzle (so simple it's hard)

• To: mathgroup at smc.vnet.net
• Subject: [mg71553] Re: [mg71496] Re: [mg71301] Arithmetic Puzzle (so simple it's hard)
• From: Julio Vera <jvera60 at yahoo.co.uk>
• Date: Thu, 23 Nov 2006 05:41:23 -0500 (EST)

```Hi Janos,

I gave it a try, too. Got the solution you found
{6, 7, 0}{1, 4, 2}{9, 5, 1,
4, 0}

plus another one.

The solutions I found are

{0,5,6,4,9,1,2,7}, {6,7,0,1,4,2,9,5}

Here´s how I did it.

In[6]:= PossibleValues= {0,1,2,4,5,6,7,9}
Out[6]= {0,1,2,4,5,6,7,9}

In[15]:= letters= {b_,u_,t_,a_,s_,k_,f_,x_}
Out[15]= {b_,u_,t_,a_,s_,k_,f_,x_}

In[41]:= permu= Permutations[PossibleValues];

In[37]:= condition[letters]= If[(100*b+10*u+t)*(100*a+10*s+k)-(10000*f+1000*x+100*a+10*s+t)== 0, {b,u,t,a,s,k,f,x}]
Out[37]= If[-100 a-10000 f-10 s-t+(100 a+k+10 s) (100 b+t+10 u)-1000 == 0, {b,u,t,a,s,k,f,x}]

In[38]:= Cases[Map[condition,permu],_List]
Out[38]= {{0,5,6,4,9,1,2,7},{6,7,0,1,4,2,9,5}}

Julio

János <janos.lobb at yale.edu> wrote:
On Nov 14, 2006, at 5:06 AM, Bruce Colletti wrote:

> How would this problem be solved in Mathematica?
>
> BUT * ASK = FEAST, where each letter is a 1-digit number, no two
> letters may stand for the same number, and the letters are in
> {0,1,2,4,5,6,7,9}.
>
> Thankx.
>
> Bruce

Here is a latecomer newbie, without brute force :)

I was wondering if a genetical algorithm would find any solution, so I
wrote one.

Started with some parameters:
In[1]:=
pwr = 16;
psize = 2^pwr;
gencyc = 50;
cros = 2;
mut = 1;
nums = {0, 1, 2, 4, 5, 6, 7,
9};
abc = {b, u, t, a, s, k, f,
e};

where psize is the population size, gencyc is the number of generation
cycles, cros is the number of cross sections to stitch and mut is the
number of mutations for an individual in the population.

Here is the cross selection function:

In[8]:=
crosssel[xx_, yy_] :=
Module[{},
pos = Sort[Table[Random[
Integer, {1, Length[
xx]}], {i, cros}]];
gg = Union[Join[{1}, pos,
{Length[xx]}]];
cgg = First[Last[
Reap[i = 1; While[
i <= Length[gg],
Which[i == 1,
Sow[gg[[i]]],
i > 1 && i < Length[
gg] && gg[[i]] -
gg[[i - 1]] > 1,
Sow[gg[[i]]],
i == Length[gg],
Sow[gg[[i]]]];
i++]]]];
hh = If[Length[cgg] < 3,
First[Last[Reap[
Sow[{cgg[[1]],
cgg[[2]] - 2}];
Sow[{cgg[[2]] - 1,
cgg[[2]]}]; ]]],
inhh = First[Last[
Reap[i = 1; While[
i < Length[cgg],
Sow[{cgg[[i]],
cgg[[i + 1]] - 1}];
i++; ]; Sow[
{cgg[[i - 1]],
cgg[[i]]}]]]];
Join[Most[Most[inhh]],
{Last[inhh]}]];
Flatten[
(If[Mod[Position[hh,
#1], 2] == {{1}},
Take[xx, #1],
Take[yy, #1]] & ) /@
hh]]

Here is the mutate function:

In[9]:=
mutate[xx_] := Module[{},
pos = Sort[Table[
{Random[Integer,
{1, Length[xx]}]},
{i, mut}]];
vals = Table[nums[[
Random[Integer,
{1, Length[nums]}]]],
{i, 1, mut}];
nnpos = Table[{i},
{i, Length[vals]}];
ReplacePart[xx, vals,
pos, nnpos]]

Here is the fitness function:

In[10]:=
fitness[x_] := Module[
{b = x[[1]], u = x[[2]],
t = x[[3]], a = x[[4]],
s = x[[5]], k = x[[6]],
f = x[[7]], e = x[[8]]},
Return[Abs[
(100*b + 10*u + t)*
(100*a + 10*s + k) -
(10000*f + 1000*e +
100*a + 10*s + t)]]]

here are some starting variables to collect data:

In[11]:=
lst = {};
kk = 1;
rnstart = Table[Table[
nums[[Random[Integer,
{1, Length[nums]}]]],
{j, Length[abc]}],
{i, psize}];

and here is the main body of the program:

In[17]:=
While[kk <= gencyc,
pstart = Partition[rnstart,
2]; crossmap =
(crosssel[#1[[1]],
#1[[2]]] & ) /@
pstart; mutatemap =
(mutate[#1] & ) /@
crossmap; fitmap =
({fitness[#1], #1} & ) /@
mutatemap; sortmap =
Union[Select[fitmap,
Length[Union[#1[[
2]]]] > 7 &&
#1[[2,1]] != 0 & ]];
ftnum = Ceiling[
Length[sortmap]/2];
If[ftnum == 0,
Print["There is no \
unique, Length 8 element, in \
random list after ",
ToString[kk],
" iteration"];
Break[]; , Null];
ft = Take[sortmap, ftnum];
AppendTo[lst, First[ft]];
If[First[First[ft]] ==
0 && Length[Union[
Last[First[ft]]]] ==
8, but = Take[
Last[First[ft]],
Take[Last[First[ft]],
{4, 6}]; feast =
Join[Take[Last[First[
ft]], {7, 8}],
Take[Last[First[ft]],
{4, 5}], Take[
Last[First[ft]],
{3, 3}]]; Print[but,
rnstart = Table[
ft[[Random[Integer,
{1, Length[ft]}],2]],
{i, 1, psize}]; kk++; ]

From In[14]:=
{6, 7, 0}{1, 4, 2}{9, 5, 1,
4, 0}
From In[14]:=
{6, 7, 0}{1, 4, 2}{9, 5, 1,
4, 0}
From In[14]:=
{6, 7, 0}{1, 4, 2}{9, 5, 1,
4, 0}
From In[14]:=
{6, 7, 0}{1, 4, 2}{9, 5, 1,
4, 0}
From In[14]:=
{6, 7, 0}{1, 4, 2}{9, 5, 1,
4, 0}

With this relatively high population size of 2^16 after three
generations a solution was found - five times :).  It needs a minimum
2^10 population size to iterate the main body more than once.  It is
looking only for those solutions where B aka b is not zero.

Any suggestions to make it faster would be highly appreciated.  /It
took 526 seconds to run with above parameters/

János

----------------------------------------------
Trying to argue with a politician is like lifting up the head of a
corpse.
(S. Lem: His Master Voice)

---------------------------------

Rates near 39yr lows. \$510,000 Loan for \$1698/mo -   Calculate new house payment
--0-1004065506-1164193407=:27259
Content-Type: text/html; charset="iso-8859-1"
X-Sun-Content-Length: 6989

Hi Janos,<br>    <br>    I gave it a try, too. Got the solution you found     <pre><tt>{6, 7, 0}{1, 4, 2}{9, 5, 1,<br>   4, 0}</tt><span style="font-family: arial;"><br></span><span style="font-family: arial,mon;"><br></span>plus another one.<br></pre>    The solutions I found are<br>    <br>    {0,5,6,4,9,1,2,7}, {6,7,0,1,4,2,9,5} <br>    <br>    Here´s how I did it. <br>    <br>    In[6]:= PossibleValues= {0,1,2,4,5,6,7,9}<br>    Out[6]= {0,1,2,4,5,6,7,9}<br>    <br>    In[15]:= letters= {b_,u_,t_,a_,s_,k_,f_,x_}<br>    Out[15]= {b_,u_,t_,a_,s_,k_,f_,x_}<br>    x instead of e, since e is already used<br>  <br>    In[41]:= permu= Permutations[PossibleValues];<br>    <br>    In[37]:= condition[letters]= If[(100*b+10*u+t)*(100*a+10*s+k)-(10000*f+1000*x+100*a+10*s+t)== 0, {b,u,t,a,s,k,f,x}]<br>    Out[37]= If[-100 a-10000 f-10 s-t+(100 a+k+10 s) (100 b+t+10 u)-1000 == 0, {b,u,t,a,s,k,f,x}]<br>    <br>    In[38]:= Cases[Map[condition,permu],_List]<br>    Out[38]=
{{0,5,6,4,9,1,2,7},{6,7,0,1,4,2,9,5}}<br>    <br>    Julio<br><br><b><i>János &lt;janos.lobb at yale.edu&gt;</i></b> wrote:<blockquote class="replbq" style="border-left: 2px solid rgb(16, 16, 255); margin-left: 5px; padding-left: 5px;">  <br>On Nov 14, 2006, at 5:06 AM, Bruce Colletti wrote:<br><br>&gt; How would this problem be solved in Mathematica?<br>&gt;<br>&gt; BUT * ASK = FEAST, where each letter is a 1-digit number, no two  <br>&gt; letters may stand for the same number, and the letters are in  <br>&gt; {0,1,2,4,5,6,7,9}.<br>&gt;<br>&gt; Thankx.<br>&gt;<br>&gt; Bruce<br><br>Here is a latecomer newbie, without brute force :)<br><br>I was wondering if a genetical algorithm would find any solution, so I  <br>wrote one.<br><br>Started with some parameters:<br>In[1]:=<br>pwr = 16;<br>psize = 2^pwr;<br>gencyc = 50;<br>cros = 2;<br>mut = 1;<br>nums = {0, 1, 2, 4, 5, 6, 7,<br>     9};<br>abc = {b, u, t, a, s, k, f,<br>     e};<br><br>where psize is the population size, gencyc
is the number of generation  <br>cycles, cros is the number of cross sections to stitch and mut is the  <br>number of mutations for an individual in the population.<br><br>Here is the cross selection function:<br><br>In[8]:=<br>crosssel[xx_, yy_] :=<br>   Module[{},<br>    pos = Sort[Table[Random[<br>         Integer, {1, Length[<br>           xx]}], {i, cros}]];<br>     gg = Union[Join[{1}, pos,<br>        {Length[xx]}]];<br>     cgg = First[Last[<br>        Reap[i = 1; While[<br>           i &lt;= Length[gg],<br>           Which[i == 1,<br>           Sow[gg[[i]]],<br>           i &gt; 1 &amp;&amp; i &lt; Length[<br>           gg] &amp;&amp; gg[[i]] -<br>           gg[[i - 1]] &gt; 1,<br>           Sow[gg[[i]]],<br>           i == Length[gg],<br>           Sow[gg[[i]]]];<br>           i++]]]];<br>     hh = If[Length[cgg] &lt; 3,<br>       First[Last[Reap[<br>          Sow[{cgg[[1]],<br>           cgg[[2]] - 2}];<br>           Sow[{cgg[[2]] - 1,<br>           cgg[[2]]}];
]]],<br>       inhh = First[Last[<br>           Reap[i = 1; While[<br>           i &lt; Length[cgg],<br>           Sow[{cgg[[i]],<br>           cgg[[i + 1]] - 1}];<br>           i++; ]; Sow[<br>           {cgg[[i - 1]],<br>           cgg[[i]]}]]]];<br>        Join[Most[Most[inhh]],<br>         {Last[inhh]}]];<br>     Flatten[<br>      (If[Mod[Position[hh,<br>           #1], 2] == {{1}},<br>         Take[xx, #1],<br>         Take[yy, #1]] &amp; ) /@<br>       hh]]<br><br>Here is the mutate function:<br><br>In[9]:=<br>mutate[xx_] := Module[{},<br>    pos = Sort[Table[<br>        {Random[Integer,<br>          {1, Length[xx]}]},<br>        {i, mut}]];<br>     vals = Table[nums[[<br>        Random[Integer,<br>         {1, Length[nums]}]]],<br>       {i, 1, mut}];<br>     nnpos = Table[{i},<br>       {i, Length[vals]}];<br>     ReplacePart[xx, vals,<br>      pos, nnpos]]<br><br>Here is the fitness function:<br><br>In[10]:=<br>fitness[x_] := Module[<br>    {b = x[[1]], u =
x[[2]],<br>     t = x[[3]], a = x[[4]],<br>     s = x[[5]], k = x[[6]],<br>     f = x[[7]], e = x[[8]]},<br>    Return[Abs[<br>      (100*b + 10*u + t)*<br>        (100*a + 10*s + k) -<br>       (10000*f + 1000*e +<br>        100*a + 10*s + t)]]]<br><br>here are some starting variables to collect data:<br><br>In[11]:=<br>lst = {};<br>kk = 1;<br>rnstart = Table[Table[<br>      nums[[Random[Integer,<br>        {1, Length[nums]}]]],<br>      {j, Length[abc]}],<br>     {i, psize}];<br><br>and here is the main body of the program:<br><br>In[17]:=<br>While[kk &lt;= gencyc,<br>   pstart = Partition[rnstart,<br>      2]; crossmap =<br>     (crosssel[#1[[1]],<br>        #1[[2]]] &amp; ) /@<br>      pstart; mutatemap =<br>     (mutate[#1] &amp; ) /@<br>      crossmap; fitmap =<br>     ({fitness[#1], #1} &amp; ) /@<br>      mutatemap; sortmap =<br>     Union[Select[fitmap,<br>       Length[Union[#1[[<br>           2]]]] &gt; 7 &amp;&amp;<br>         #1[[2,1]] != 0 &amp; ]];<br>
ftnum = Ceiling[<br>      Length[sortmap]/2];<br>    If[ftnum == 0,<br>     Print["There is no \<br>unique, Length 8 element, in \<br>random list after ",<br>       ToString[kk],<br>       " iteration"];<br>      Break[]; , Null];<br>    ft = Take[sortmap, ftnum];<br>    AppendTo[lst, First[ft]];<br>    If[First[First[ft]] ==<br>       0 &amp;&amp; Length[Union[<br>         Last[First[ft]]]] ==<br>       8, but = Take[<br>        Last[First[ft]],<br>        {1, 3}]; ask =<br>       Take[Last[First[ft]],<br>        {4, 6}]; feast =<br>       Join[Take[Last[First[<br>           ft]], {7, 8}],<br>        Take[Last[First[ft]],<br>         {4, 5}], Take[<br>         Last[First[ft]],<br>         {3, 3}]]; Print[but,<br>       ask, feast], Null];<br>    rnstart = Table[<br>      ft[[Random[Integer,<br>        {1, Length[ft]}],2]],<br>      {i, 1, psize}]; kk++; ]<br><br> From In[14]:=<br>{6, 7, 0}{1, 4, 2}{9, 5, 1,<br>   4, 0}<br> From In[14]:=<br>{6, 7, 0}{1, 4, 2}{9, 5, 1,<br>
4, 0}<br> From In[14]:=<br>{6, 7, 0}{1, 4, 2}{9, 5, 1,<br>   4, 0}<br> From In[14]:=<br>{6, 7, 0}{1, 4, 2}{9, 5, 1,<br>   4, 0}<br> From In[14]:=<br>{6, 7, 0}{1, 4, 2}{9, 5, 1,<br>   4, 0}<br><br>With this relatively high population size of 2^16 after three  <br>generations a solution was found - five times :).  It needs a minimum  <br>2^10 population size to iterate the main body more than once.  It is  <br>looking only for those solutions where B aka b is not zero.<br><br>Any suggestions to make it faster would be highly appreciated.  /It  <br>took 526 seconds to run with above parameters/<br><br>János<br><br><br><br><br>----------------------------------------------<br>Trying to argue with a politician is like lifting up the head of a  <br>corpse.<br>(S. Lem: His Master Voice)<br><br></blockquote><br><p>&#32;

<font color="666666"><font size="2"><hr size=1>Sponsored Link</font></font><br><br>Rates near 39yr lows. \$510,000 Loan for \$1698/mo -
<a href="http://www.lowermybills.com/lre/index.jsp?sourceid=lmb-9137-16419&moid=4119";>Calculate new house payment</a>
--0-1004065506-1164193407=:27259--

```

• Prev by Date: Re: general form of a n-derivative
• Next by Date: WW 1.0 matching bracket highlighting
• Previous by thread: Re: Arithmetic Puzzle (so simple it's hard)
• Next by thread: Re: Arithmetic Puzzle (so simple it's hard)