MathGroup Archive 2006

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

Search the Archive

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


János 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:
> [...]
> 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

I'll instead point out that NMinimize can be adapted to this sort of 
problem. I do not claim it is a particularly good fit, and indeed the 
speed is worse than brute force. All the same this approach might be of 
interest for other optimization problems involving permutations.

We define an auxiliary function that converts a list of reals from zero
to n into a permutation of Range[n]. The idea is to start with Range[n], 
then walk the input list, using the kth element to indicate where in a 
shuffle to swap with the current kth element of the permutation under 
construction.

Use of Compile perhaps not needed for n=8, the case in question. Also we 
really force them to be a hair larger than zero because otherwise we 
sometimes get values driven down to zero and the permutation finder 
fails to work as it should.

getPerm = Compile[{{vec,_Real,1}}, Module[
   {p1, len=Length[vec], k, nlen},
   p1 = Range[len];
   nlen = N[len];
   Do [
     k = Ceiling[j-1 + vec[[j]]/nlen*(nlen-j+1)];
     p1[[{j,k}]] = p1[[{k,j}]];
     , {j,len}];
   p1
   ]]

I set this up as a quadratic optimization. Well, not really, actually 
it's quartic. But the name "QP" I suppose could apply to that as well. 
We minimize the square of the difference of the two values, with the 
variables {b,u,...} taking on the permutation given by an auxiliary set 
of variables {x[1],x[2],...,x[8]}. We use the DifferentialEvolution 
method and allow some settings as parameters. Quite possibly other 
methods would work better.

QP[cp_, it_, sp_] := Module[
   {letters, len, values, vars, x, rul, rnges,
     obj, eval, nmin, vals},
   letters = {b,u,t,a,s,k,f,e};
   len = Length[letters];
   values = {0,1,2,4,5,6,7,9};
   vars = Array[x,len];
   rnges = Map[0.01<=#<=len&, vars];
   rul[vars:{__Real}] := Thread[letters->values[[getPerm[vars]]]];
   obj = ((100*b+10*u+t) * (100*a+10*s+k) -
     (10000*f+1000*e+100*a+10*s+t))^2;
   eval[vv:{__Real}] := obj/.rul[vv];
   {nmin,vals} = NMinimize[{eval[vars],rnges},
     vars, MaxIterations->it,
     Method->{DifferentialEvolution,SearchPoints->sp,
       PostProcess->False,CrossProbability->cp}];
   {nmin, Thread[letters->values[[getPerm[vars/.vals]]]]}
   ]

With crossover set fairly high we get a correct result relatively fast.

In[65]:= Timing[QP[.9, 100, 20]]

Out[65]= {2.22, {0., {b -> 0, u -> 5, t -> 6, a -> 4,
   s -> 9, k -> 1, f -> 2, e -> 7}}}

Also it seems to be reasonably stable insofar as increasing some 
parameters (SearchPoints and/or MaxIterations) usually (based on a 
handful of experiments) still gives a correct result.

Again, I don't particularly recommend this approach for an exact 
factorization problem. It does however illustrate a way in which one 
might approach combinatorial optimization heuristically, in that it 
converts a list of reals to a permutation. I would not be surprised if 
there are better methods, improvements to be made by use of "local" 
refinement (e.g. further swapping of pairs), other optimization 
approaches that work better, etc.

Daniel Lichtblau
Wolfram Research




  • Prev by Date: RE: Re: Best practice for naming of options
  • Next by Date: Re: Re: Why does this lead to an answer with complex numbers?
  • Previous by thread: Re: Arithmetic Puzzle (so simple it's hard)
  • Next by thread: Re: Arithmetic Puzzle (so simple it's hard)