Services & ResourcesWolfram ForumsMathGroup Archive

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

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

• To: mathgroup at smc.vnet.net
• Subject: [mg71496] Re: [mg71301] Arithmetic Puzzle (so simple it's hard)
• From: János <janos.lobb at yale.edu>
• Date: Mon, 20 Nov 2006 18:11:59 -0500 (EST)
• References: <200611141006.FAA06684@smc.vnet.net>

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]],
        {1, 3}]; ask =
       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,
       ask, feast], Null];
    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)

• Follow-Ups:
  • Re: Re: Arithmetic Puzzle (so simple it's hard)
    • From: Daniel Lichtblau <danl@wolfram.com>

• References:
  • Arithmetic Puzzle (so simple it's hard)
    • From: Bruce Colletti <vze269bv@verizon.net>