Algorithm-Evolve

 view release on metacpan or  search on metacpan

examples/ArrayEvolver.pm  view on Meta::CPAN

use strict;
use Algorithm::Evolve::Util ':arr';
our $VERSION = '0.03';

our %configs;

sub import {
    my $class = shift;
    
    %configs = (
        gene_length    => 20,
        alphabet       => [0,1],
        reference_gene => [ ('1') x 20 ],
        mutation_rate  => 0.05,
        crossover_pts  => 2,
        @_
    );
}

sub new {
    my $pkg = shift;
    my $array = shift
        || arr_random($configs{gene_length}, $configs{alphabet});
    return bless { _gene => $array }, $pkg;
}

sub crossover {
    my ($pkg, $c1, $c2) = @_;
    return map { $pkg->new($_) } 
           arr_crossover($c1->gene, $c2->gene, $configs{crossover_pts});
}

sub fitness {

examples/ArrayEvolver.pm  view on Meta::CPAN

1;
__END__

=head1 NAME

ArrayEvolver - A generic base critter class for use with Algorithm::Evolve

=head1 SYNOPSIS

  package ArrayCritters;
  use ArrayEvolver gene_length => 50,
                   alphabet => [qw(foo bar baz boo)],
                   ...;
  our @ISA = ('ArrayEvolver');
  ## ArrayCritters is now a valid critter class
  
  sub foo_method {
      my $self = shift;
      $self->{foo}++;   ## You can add object attributes
  }
  

examples/ArrayEvolver.pm  view on Meta::CPAN

      ## task at hand
  }

You can use this class as a base class any time your representation is an
array gene.

=head1 USE ARGUMENTS

=over

=item gene_length

The length of arrays to evolve. Defaults to 20.

=item alphabet

A reference to an array of valid tokens for the genes. Defaults to [0,1].
Unlike in StringEvolver, the tokens can be any length.

=item reference_gene

By default, fitness is measured as the number of positions in which a
critter's gene agrees with a reference array. However, if you are 
implementing a non-trivial evolver, you will probably override the fitness
method and this argument won't make a difference. It defaults to
C<('1') x 20>.

=item mutation_rate

examples/StringEvolver.pm  view on Meta::CPAN

use strict;
use Algorithm::Evolve::Util ':str';
our $VERSION = '0.03';

our %configs;

sub import {
    my $class = shift;
    
    %configs = (
        gene_length    => 20,
        alphabet       => [0,1],
        reference_gene => '1' x 20,
        mutation_rate  => 0.05,
        crossover_pts  => 2,
        @_
    );
}

sub new {
    my $pkg = shift;
    my $string = shift
        || str_random($configs{gene_length}, $configs{alphabet});
    return bless { _gene => $string }, $pkg;
}

sub crossover {
    my ($pkg, $s1, $s2) = @_;
    return map { $pkg->new($_) } 
           str_crossover($s1->gene, $s2->gene, $configs{crossover_pts});
}

sub fitness {

examples/StringEvolver.pm  view on Meta::CPAN

1;
__END__

=head1 NAME

StringEvolver - A generic base critter class for use with Algorithm::Evolve

=head1 SYNOPSIS

  package StringCritters;
  use StringEvolver gene_length => 50,
                    alphabet => ['A' .. 'F'],
                    ...;
  our @ISA = ('StringEvolver');
  ## StringCritters is now a valid critter class

  sub foo_method {
      my $self = shift;
      $self->{foo}++;   ## You can add object attributes
  }
  

examples/StringEvolver.pm  view on Meta::CPAN

      ## task at hand
  }

You can use this class as a base class any time your representation is a
string gene.

=head1 USE ARGUMENTS

=over

=item gene_length

The length of strings to evolve. Defaults to 20.

=item alphabet

A reference to an array of valid tokens for the genes. All elements of the
array should be single characters. Defaults to [0,1].

=item reference_gene

By default, fitness is measured as the number of characters in which a
critter's gene agrees with a reference string. However, if you are 

examples/breeding_perls.pl  view on Meta::CPAN

## Now set up 'main' as a critter class. That means objects of the 'main'
## class are critters, which are the members of the evolving population. We
## use a base class that has default methods necessary for A::E to use it as a
## critter class (mutation, fitness, crossover, etc). This base class uses an
## array for the "gene" of the critter. Each item in the array is a valid Perl
## statement (a member of the alphabet). As you can see, you could easily add
## more statements to the alphabet, or change the number of Perl statements in
## the array genes, etc.
##############################################################################

use ArrayEvolver gene_length => 30,
                 alphabet => [qw( $x+=1; $x=$y; $x|=$y; $x+=$y; $y=$x; )],
                 mutation_rate => (1/30);
our @ISA = 'ArrayEvolver';

############################################################################
## We override the default inherited fitness method. In A::E, fitness is
## *maximized*. If were were minimizing fitness, we could just use
## "abs( $TARGET - eval )" as the fitness measure. The fitness measure we 
## actually use gives the highest fitness if the result of the Perl code is
## $TARGET, and gives lower fitness the farther away the result is from the

examples/rock_paper_scissors.pl  view on Meta::CPAN

our @ISA = ('StringEvolver');

use lib '../lib';
use Algorithm::Evolve;

sub compare {
    my ($class, $crit1, $crit2) = @_;

    my ($string1, $string2) = ($crit1->gene, $crit2->gene);
    my ($score1, $score2)   = (0, 0);
    my $length              = length($string1);
    my $offset1             = int rand $length;
    my $offset2             = int rand $length;

    ## .. and wrap around
    $string1 x= 2;
    $string2 x= 2;

    for (1 .. $length) {
        my $char1 = substr($string1, $offset1++, 1);
        my $char2 = substr($string2, $offset2++, 1);

        next if $char1 eq $char2; ## tie

        if (($char1 eq 'R' && $char2 eq 'S') or
            ($char1 eq 'S' && $char2 eq 'P') or
            ($char1 eq 'P' && $char2 eq 'R'))
        {
            $score1++;

lib/Algorithm/Evolve/Util.pm  view on Meta::CPAN

our %EXPORT_TAGS = (
    str => [qw/str_crossover str_mutate str_agreement str_random/],
    arr => [qw/arr_crossover arr_mutate arr_agreement arr_random/],
);
our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;

sub str_crossover {
    my ($s1, $s2, $n_point) = @_;
    
    $n_point ||= 2;
    my $len    = length($s1);

    croak "Can't do ${n_point}-point crossover on length $len string"
        if $n_point >= $len;

    ## this allows for duplication of indices. maybe a fixme

    my @points = sort { $a <=> $b } map { int(rand $len) } 1 .. $n_point;
    push @points, $len if $n_point % 2;

    for (0 .. @points/2 - 1) {
        my ($x, $y) = @points[2*$_, 2*$_+1];
        (substr($s1, $x, $y-$x+1), substr($s2, $x, $y-$x+1)) =

lib/Algorithm/Evolve/Util.pm  view on Meta::CPAN

}

sub str_agreement {
    my ($s1, $s2) = @_;

    ## substr is safe for unicode; xor'ing characters is not. But
    ## xor is about 30 times faster on longish strings...

    if ($UNICODE_STRINGS) {
        my $tally = 0;
        for (0 .. length($s1)-1) {
            $tally++ if substr($s1, $_, 1) eq substr($s2, $_, 1);
        }
        return $tally;
    }

    my $xor = $s1 ^ $s2;
    return $xor =~ tr/\x0/\x0/;
}

sub str_mutate {
    my ($string, $n, $alphabet) = @_;
    
    $n        ||= 1;
    $alphabet ||= [0,1];

    croak "Invalid alphabet"
        unless ref $alphabet eq 'ARRAY' and @$alphabet > 1;

    my $len = length($string);
    my @mutate_indices = $n < 1
        ? map { rand() < $n ? $_ : () } 0 .. $len-1
        : (shuffle 0 .. $len-1)[ 0 .. int($n)-1 ];
        
    for my $idx (@mutate_indices) {
        my $char                 = substr($string, $idx, 1);
        my @different            = grep { $char ne $_ } @$alphabet;
        substr($string, $idx, 1) = $different[ int(rand @different) ];
    }
    
    return $string;
}

sub str_random {
    my ($length, $alphabet) = @_;
    
    $alphabet ||= [0,1];

    return join '', map { $alphabet->[ rand @$alphabet ] } 1 .. $length;
}

##########################################

sub arr_crossover {
    my ($a1_ref, $a2_ref, $n_point) = @_;
    
    $n_point ||= 2;
    my @a1     = @$a1_ref;
    my @a2     = @$a2_ref;
    my $len    = @a1;

    croak "Can't do ${n_point}-point crossover on length $len array"
        if $n_point >= $len;

    ## this allows for duplication of indices. maybe a fixme

    my @points = sort { $a <=> $b } map { int(rand $len) } 1 .. $n_point;
    push @points, $len-1 if $n_point % 2;

    for (0 .. @points/2 - 1) {
        my ($x, $y)   = @points[2*$_, 2*$_+1];
        my @tmp       = @a1[$x .. $y];

lib/Algorithm/Evolve/Util.pm  view on Meta::CPAN

    for my $idx (@mutate_indices) {
        my $char      = $arr[$idx];
        my @different = grep { $char ne $_ } @$alphabet;
        $arr[$idx]    = $different[ int(rand @different) ];
    }
    
    return \@arr;
}

sub arr_random {
    my ($length, $alphabet) = @_;
    
    $alphabet ||= [0,1];

    return [ map { $alphabet->[ rand @$alphabet ] } 1 .. $length ];
}


##########################################
##########################################
##########################################
1;
__END__

=head1 NAME

lib/Algorithm/Evolve/Util.pm  view on Meta::CPAN

array reference. A position in the gene refers to a single character for string
genes and an array element for array genes.

=over 4

=item C<str_crossover( $string1, $string2 [, $N ] )>

=item C<arr_crossover( \@array1, \@array2 [, $N ] )>

Returns a random N-point crossover between the two given genes. C<$N> defaults
to 2. The two inputs should be the same length, although this is not enforced.
C<$N> must be also less than the size of the genes.

If you are unfamiliar with the crossover operation, it works like this: Lay
down the two genes on top of each other. Pick N positions at random, and cut
both genes at each position. Now swap every other pair of segments, and tape
the genes back up. So one possible 2-point crossover on the string genes
C<aaaaaa> and C<bbbbbb> would produce the two genes C<abbaaa> and C<baabbb>
(the two "cuts" here were after the 1st and 3rd positions).

=item C<str_agreement( $string1, $string2 )>

lib/Algorithm/Evolve/Util.pm  view on Meta::CPAN

=item C<str_mutate( $string1 [, $num [, \@alphabet ]] )>

=item C<arr_mutate( \@array1 [, $num [, \@alphabet ]] )>

Returns a random mutation of the gene according to the given alphabet
(defaulting to {0,1}). If C<$num> is less than 1, it performs I<probabilistic
mutation>, with each position having a C<$num> probability of being mutated. If
C<$num> is greater than or equal to 1, it performs I<N-point mutation>: exactly
C<$num> positions are chosen at random and mutated. C<$num> defaults to 1. A
convenient rule of thumb is start with a mutation rate of 1/gene_length.

A mutation will always change the character in question: an 'a' will never be
chosen to replace an existing 'a' in a mutation. The following identity holds
for N-point mutations:

  str_agreement( str_mutate($some_string, $n, \@alph), $some_string )
    == length($some_string) - $n;

The alphabet for a string gene should consist of only single characters unless
you know what you're doing. Conceivably, you can implement an 'add' and 'remove'
mutation by using an alphabet that contains strings with length != 1. But this
seems a little hackish to me. For array genes, the alphabet can be just about
anything meaningful to you.

=item C<str_random( $size [, \@alphabet ] )>

=item C<arr_random( $size [, \@alphabet ] )>

Returns a random gene of the given size over the given alphabet, defaulting to
{0,1}.