home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
RPC
/
!Perl
/
scripts
/
harness
< prev
next >
Wrap
Text File
|
1997-06-06
|
7KB
|
334 lines
#!perl -w
# !"k$mwd()¡,eea/wh |4bc789w;y=xpnAgCDEF|tIsKmMNOPlRSTU¡gwro[u]^_i
BEGIN
{
srand ($$ ^ time);
push @INC, '.';
}
$boom = 0;
$SIG{USR1} = sub {
$boom = 1;
};
# sub { open(DEATH,">>$$") and print DEATH "Dying from:\n",@_ };
# $SIG{__WARN__} = sub { open(WARN,">>$$") and print WARN "Warning about:\n",@_ };
use Victim qw( &individual &fitness $alphabet $target &intersection &other &alphabet &indexes &duplicates );
$pop_size = 1600;
@best_fitness = undef;
@best_individual = undef;
$mutate_prob = 0.001;
$invert_prob = 0.003;
$cheat_prob = 0.006;
sub pront
{
foreach (@_)
{
y/\r/¡/;
print;
}
}
sub generate_population ($)
{
my $i = shift;
my (@pop, @inv);
while( $i-- )
{
push @pop, [&individual];
}
@pop;
}
sub select_individual ($@)
{
my $sum = shift;
my( $rand, $partial_sum, $i ) = ( rand $sum, 0, scalar @_ );
die $i unless $i > 0;
while( $i-- && $partial_sum <= $rand )
{
$partial_sum += $_[$i];
}
--$i;
}
sub old_permute_crossover ($$)
{
# OK, so they are hermaphrodites
my( $mum, $dad ) = @_;
my( $mum_l, $dad_l ) = (length $mum, length $dad);
die "'$mum'\n'$dad'\nOops. $mum_l != $dad_l" unless $mum_l == $dad_l;
my( $where, $length, $chop );
# Note that this can crossover after the last character!
$where = rand $mum_l;
$chop = substr $mum, $where, 1;
if( -1 != ($length = index ($dad, $chop, $where + 1)))
{
# die "'$chop' '" . substr ($dad, $length, 1) ."'\n";
$length = $length - $where + 1;
}
else
{
$length = $mum_l - $where;
}
$chop = substr $mum, $where, $length;
(substr $mum, $where, $length) = substr $dad, $where, $length;
(substr $dad, $where, $length) = $chop;
($mum, $dad);
}
sub crossover ($$)
{
# OK, so they are hermaphrodites
my( $mum, $dad ) = @_;
my( $mum_l, $dad_l ) = (length $$mum[0], length $$dad[0]);
my( $sprog1, $sprog2 );
die "'$mum'\n'$dad'\nOops. $mum_l != $dad_l" unless $mum_l == $dad_l;
my( $where, $length, $chop );
# Note that this can crossover after the last character!
$where = rand $mum_l;
$length = $mum_l - $where;
$sprog1 = [@$mum];
$sprog2 = [@$dad];
(substr $$sprog1[0], $where, $length) = substr $$dad[0], $where, $length;
(substr $$sprog2[0], $where, $length) = substr $$mum[0], $where, $length;
# Unset cached fitness unless identical
@$sprog1 = ($$sprog1[0]) unless $$sprog1[0] eq $$mum[0];
@$sprog2 = ($$sprog2[0]) unless $$sprog2[0] eq $$dad[0];
# print "Cache win\n" if defined $$sprog2[1];
($sprog1, $sprog2);
}
sub mutate ($)
{
(substr $_[0], rand( length $_[0] ), 1)
= substr $alphabet, rand (length $alphabet), 1;
$_[0];
}
sub old_cheat ($)
{
my ($where) = rand( length $_[0] );
(substr $_[0], $where, 1)
= substr $Victim::uuchars, $where, 1;
$_[0];
}
sub cheat ($)
{
my ($g) = shift;
my ($duplicates) = &duplicates ($g);
if( defined $duplicates )
{
my $char = substr $duplicates, rand (length $duplicates), 1;
my (@where) = indexes( $g, $char );
my $where = $where[rand $#where];
die "$where in '$g' isn't $char" . join( ',', @where )
unless $char eq substr $g, $where, 1;
my $replacements = &other( $Victim::chars, $g );
$replacements = $alphabet if( $replacements eq '' );
# print STDERR"'$g' '$replacements'\n'$char' -> '";
(substr $g, $where, 1)
= substr $replacements, rand (length $replacements), 1;
# die ((substr $g, $where, 1) . "'\n'$g'" )
}
else
{
(substr $g, $where, 1)
= substr $Victim::uuchars, $where, 1;
}
$g;
}
sub invert ($)
{
my ($in, $out) = (shift);
my ($in_l, $i) = length $in;
my ($where, $length);
$where = int rand $in_l;
$length = int rand ($in_l - $where);
# print "$in_l $where $length\n";
# print "»$in«\n";
$out = substr $in, 0, $where;
$i = $length;
while( $i-- )
{
$out .= substr $in, $where + $i, 1;
}
$out .= substr $in, $where + $length;
# print "»$out«\n";
$out;
}
@population = generate_population( $pop_size );
$generation = 0;
print "Here we go\n";
$^W = 0; # Turn off warnings in the evals
do
{
$sum_fitness = 0;
@best_fitness = undef;
@worst_fitness = undef;
$i = $pop_size;
while( $i-- )
{
$this = $population[$i];
unless( defined $$this[1] )
{
$genes = $$this[0];
$population[$i] = $this = [$genes, &fitness( $genes )];
}
$sum_fitness += $fitness[$i] = $$this[1];
@best_fitness = @$this
unless( defined $best_fitness[1] and $$this[1] < $best_fitness[1] );
@worst_fitness = @$this
unless( defined $worst_fitness[1] and $$this[1] > $worst_fitness[1] );
}
$mean_fitness = $sum_fitness / $pop_size;
$best = $best_fitness[1];
$worst = $worst_fitness[1];
$shift = ($best - $worst) * +0 - $worst;
pront "Generation $generation\tBest = $best"
."\tMean = $mean_fitness\tWorst = $worst"
."\n$Victim::uuchars"
."\n$best_fitness[0]\n$best_fitness[2]\n$best_fitness[3]"
." \t\t$best_fitness[4]\n";
# print ($population[0] . "\n");
$sec = 0;
foreach( (@fitness) )
{
$_ += $shift;
$_ = 0 unless $_ > 0; # $_ *= $_;
$sec += $_;
}
# $sum_fitness += $shift * $pop_size;
# print "$sum_fitness $sec\n";
@intermediate = ();
$i = $pop_size;
# printf "%s\n%s\n", ${$population[0]}[0], ${$population[1]}[0];
while( $i-- )
{
push @intermediate,
$population[select_individual($sec,@fitness)];
}
# printf "%s\n%s\n", ${$intermediate[0]}[0], ${$intermediate[1]}[0];
@population = ();
while( scalar @intermediate )
{
push @population, crossover( shift @intermediate, shift @intermediate );
}
$this_mutate = $mutate_prob * $pop_size;
while( $this_mutate-- > 1 || (rand( 1 ) -1) < $this_mutate )
{
$victim = rand $pop_size;
$genes = mutate( ${$population[$victim]}[0] );
$population[$victim] = [$genes];
}
$this_cheat = $cheat_prob * $pop_size;
while( $this_cheat-- > 1 || (rand( 1 ) -1) < $this_cheat )
{
$victim = rand $pop_size;
$genes = cheat( ${$population[$victim]}[0] );
$population[$victim] = [$genes];
}
$this_invert = $invert_prob * $pop_size;
while( $this_invert-- > 1 || (rand( 1 ) -1) < $this_invert )
{
$victim = rand $pop_size;
$genes = invert( ${$population[$victim]}[0] );
$population[$victim] = [$genes];
}
$generation++;
if( $boom )
{
$boom = 0;
print "pop_size = $pop_size\tmutate_prob = $mutate_prob\n";
print "pop_size = $pop_size\tcheat_prob = $cheat_prob\n";
print "pop_size = $pop_size\tinvert_prob = $invert_prob\n";
}
}
while( 1 );