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];
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}];
]

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)