[Wellington-pm] SEND + MORE = MONEY

[Douglas Bagnall]

Yesterday, I had a go with a hybrid stochastic/ combinatorial approach. 
  I reasoned (or rather, imagined) that when the error is low, the most 
significant digits would be settled, and permutations of the less 
significant digits would quickly find the solution.  This was not true. 
  While M and O are easily fixed, S could be any manner of things with 
the sum out by only one.

So I gave that up, but seeing that there were these local minima,  I 
imagined again that the evolutionary process was occasionally getting 
stuck in them, thus not coming up with an answer in any given number of 
cycles.  I borrowed from the natural world and introduced periodic 
cataclysmic events, so if progress is arbitrarily slow, the entire pool 
gets jumbled.  It seems to work -- it hasn't been stuck since, over 
thousands of cycles.

On an Athlon XP 2800+, it takes about 0.2 seconds per solution -- the 
script solves it 100 times to get a reasonable average.

$ time ./sum4.pl
found '9567 + 1085 = 10652' (SONYEMDR => 90625178), 100 times

real    0m17.634s


For questions with more than one solution, it tends to find them all. 
For example, Srdjan's sum has 2 solutions:

$ ./sum4.pl 'SEND + ME + MORE = MONEY'
found '9458 + 14 + 1074 = 10546' (SONYEMDR => 90564187), 52 times
found '9346 + 13 + 1073 = 10432' (SONYEMDR => 90423167), 48 times



douglas
























#!/usr/bin/perl -w

use strict;
my $message = shift || 'SEND + MORE = MONEY';
my $GOES = shift || 100;
my $ITERATIONS = shift || 2000;
my $POOL = shift || 100;
my $CUTOFF = shift || 34;
my $CATACLYSMS = shift || 400;
my $INF = 1e999;
my $MAXMAG = 12; #maximum word length.

my @letters = keys %{{ map { $_ => 1} ($message =~ /([A-Z])/g)}};
my $letters = join('', @letters);
my $len  = @letters;

my $equation = $message;
$equation =~ s/=/-/;  # should check for bad chars,
                       # put () around each side.

my %answers;
my $noanswer = 0;

OUTER: foreach(1..$GOES){
     my @nums = (0..9);
     my %candidates = map {
	for (my $i = 10; --$i;) {
	    my $r = int(rand($i + 1));
	    ($nums[$i], $nums[$r]) = ($nums[$r], $nums[$i]);
	};
	substr(join('', @nums), 0, $len) => $INF;
     }(1..$POOL);

     foreach my $i (1..$ITERATIONS){
	my @scores = sort {$a <=> $b} (values(%candidates));
	my $cutoff = $scores[$CUTOFF];
	my %new_candidates;
	while (my ($digits, $score) = each %candidates) {
	    if ($score eq $INF){
		$_ = $equation;
		eval "tr/$letters/$digits/";
		next if(/\b0/);
		$score = abs (eval $_);
		next if ($score > $cutoff);
		if ($score == 0){
		    s/-/=/;
		    #print "found $digits in $i iterations\n";
		    $answers{$digits} += 1;
		    next OUTER;
		}
	    }
	    $new_candidates{$digits} = $score if ($score <= $cutoff);
	}
	%candidates = %new_candidates;
	my @mutatees = keys(%candidates);
	my $c = @mutatees;
	if ($i % $CATACLYSMS){
	    while ($c < $POOL){
		foreach my $digits (@mutatees){
		    my $pos = int(rand($len));
		    my $new_n = int(rand(10));
		    my $old_n = substr($digits, $pos, 1, 'x');
		    $digits =~ s/$new_n/$old_n/;
		    $digits =~ s/x/$new_n/;
		    $candidates{$digits} = $INF;
		    last if (++$c >= $POOL);
		}
	    }
	}
	else{
	    # damage all answers.
	    %candidates = ();
	    $c = 0;
	    #print " * cataclysm after $i cycles\n";
	    while ($c < $POOL){
		foreach my $digits (@mutatees){
		    foreach(1..3){
			my $pos = int(rand($len));
			my $new_n = int(rand(10));
			my $old_n = substr($digits, $pos, 1, 'x');
			$digits =~ s/$new_n/$old_n/;
			$digits =~ s/x/$new_n/;
		    }
		    $candidates{$digits} = $INF;
		    last if (++$c >= $POOL);		
		}
	    }
	}
     }
     print "No solution found after $ITERATIONS iterations!\n";
     $noanswer += 1;
}


while(my ($digits, $count) = each(%answers)){
     $_ = $message;
     eval "tr/$letters/$digits/";
     print "found '$_' ($letters => $digits), $count times\n";
}