Acorn User 10/AU_CD10.iso/Updates/Perl/Non-RPC/!Perl/scripts/harness

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 );