AI-Genetic-Pro
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
lib/AI/Genetic/Pro.pm view on Meta::CPAN
package AI::Genetic::Pro;
$AI::Genetic::Pro::VERSION = '1.009';
#---------------
use warnings;
use strict;
use base qw( Class::Accessor::Fast::XS );
#-----------------------------------------------------------------------
use Carp;
use Clone qw( clone );
use Struct::Compare;
use Digest::MD5 qw( md5_hex );
use List::Util qw( sum );
use List::MoreUtils qw( minmax first_index apply );
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use Tie::Array::Packed;
use UNIVERSAL::require;
#-----------------------------------------------------------------------
use AI::Genetic::Pro::Array::Type qw( get_package_by_element_size );
use AI::Genetic::Pro::Chromosome;
#-----------------------------------------------------------------------
__PACKAGE__->mk_accessors(qw(
mce
type
population
terminate
chromosomes
crossover
native
parents _parents
history _history
fitness _fitness _fitness_real
cache
mutation _mutator
strategy _strategist
selection _selector
_translations
generation
preserve
variable_length
_fix_range
_package
_length
strict _strict
workers
size
_init
));
#=======================================================================
# Additional modules
use constant STORABLE => 'Storable';
use constant GD => 'GD::Graph::linespoints';
#=======================================================================
my $_Cache = { };
my $_temp_chromosome;
#=======================================================================
sub new {
my ( $class, %args ) = ( shift, @_ );
#-------------------------------------------------------------------
my %opts = map { if(ref $_){$_}else{ /^-?(.*)$/o; $1 }} @_;
my $self = bless \%opts, $class;
#-------------------------------------------------------------------
$AI::Genetic::Pro::Array::Type::Native = 1 if $self->native;
#-------------------------------------------------------------------
croak(q/Type of chromosomes cannot be "combination" if "variable length" feature is active!/)
if $self->type eq q/combination/ and $self->variable_length;
croak(q/You must specify a crossover strategy with -strategy!/)
unless defined ($self->strategy);
croak(q/Type of chromosomes cannot be "combination" if strategy is not one of: OX, PMX!/)
if $self->type eq q/combination/ and ($self->strategy->[0] ne q/OX/ and $self->strategy->[0] ne q/PMX/);
croak(q/Strategy cannot be "/,$self->strategy->[0],q/" if "variable length" feature is active!/ )
if ($self->strategy->[0] eq 'PMX' or $self->strategy->[0] eq 'OX') and $self->variable_length;
#-------------------------------------------------------------------
$self->_set_strict if $self->strict;
#-------------------------------------------------------------------
return $self unless $self->mce;
#-------------------------------------------------------------------
delete $self->{ mce };
'AI::Genetic::Pro::MCE'->use or die q[Cannot raise multicore support: ] . $@;
return AI::Genetic::Pro::MCE->new( $self, \%args );
}
#=======================================================================
sub _Cache { $_Cache; }
#=======================================================================
# INIT #################################################################
#=======================================================================
sub _set_strict {
my ($self) = @_;
# fitness
my $fitness = $self->fitness();
my $replacement = sub {
my @tmp = @{$_[1]};
my $ret = $fitness->(@_);
my @cmp = @{$_[1]};
die qq/Chromosome was modified in a fitness function from "@tmp" to "@{$_[1]}"!\n/ unless compare(\@tmp, \@cmp);
return $ret;
};
$self->fitness($replacement);
}
#=======================================================================
sub _fitness_cached {
my ($self, $chromosome) = @_;
#my $key = md5_hex(${tied(@$chromosome)});
my $key = md5_hex( $self->_package ? md5_hex( ${ tied( @$chromosome ) } ) : join( q[:], @$chromosome ) );
return $_Cache->{$key} if exists $_Cache->{$key};
$_Cache->{$key} = $self->_fitness_real->($self, $chromosome);
return $_Cache->{$key};
}
#=======================================================================
sub _init_cache {
my ($self) = @_;
$self->_fitness_real($self->fitness);
$self->fitness(\&_fitness_cached);
return;
}
#=======================================================================
sub _check_data_ref {
my ($self, $data_org) = @_;
my $data = clone($data_org);
my $ars;
for(0..$#$data){
next if $ars->{$data->[$_]};
$ars->{$data->[$_]} = 1;
unshift @{$data->[$_]}, undef;
}
return $data;
}
#=======================================================================
# we have to find C to (in some cases) incrase value of range
# due to design model
sub _find_fix_range {
my ($self, $data) = @_;
for my $idx (0..$#$data){
if($data->[$idx]->[1] < 1){
my $const = 1 - $data->[$idx]->[1];
push @{$self->_fix_range}, $const;
$data->[$idx]->[1] += $const;
$data->[$idx]->[2] += $const;
}else{ push @{$self->_fix_range}, 0; }
}
return $data;
}
#=======================================================================
sub init {
my ( $self, $data ) = @_;
croak q/You have to pass some data to "init"!/ unless $data;
#-------------------------------------------------------------------
$self->generation(0);
$self->_init( $data );
$self->_fitness( { } );
$self->_fix_range( [ ] );
$self->_history( [ [ ], [ ], [ ] ] );
$self->_init_cache if $self->cache;
#-------------------------------------------------------------------
if($self->type eq q/listvector/){
croak(q/You have to pass array reference if "type" is set to "listvector"/) unless ref $data eq 'ARRAY';
$self->_translations( $self->_check_data_ref($data) );
}elsif($self->type eq q/bitvector/){
croak(q/You have to pass integer if "type" is set to "bitvector"/) if $data !~ /^\d+$/o;
$self->_translations( [ [ 0, 1 ] ] );
$self->_translations->[$_] = $self->_translations->[0] for 1..$data-1;
}elsif($self->type eq q/combination/){
croak(q/You have to pass array reference if "type" is set to "combination"/) unless ref $data eq 'ARRAY';
$self->_translations( [ clone($data) ] );
$self->_translations->[$_] = $self->_translations->[0] for 1..$#$data;
}elsif($self->type eq q/rangevector/){
croak(q/You have to pass array reference if "type" is set to "rangevector"/) unless ref $data eq 'ARRAY';
$self->_translations( $self->_find_fix_range( $self->_check_data_ref($data) ));
}else{
croak(q/You have to specify first "type" of vector!/);
}
my $size = 0;
if($self->type ne q/rangevector/){ for(@{$self->_translations}){ $size = $#$_ if $#$_ > $size; } }
# else{ for(@{$self->_translations}){ $size = $_->[1] if $_->[1] > $size; } }
else{ for(@{$self->_translations}){ $size = $_->[2] if $_->[2] > $size; } } # Provisional patch for rangevector values truncated to signed 8-bit quantities. Thx to Tod Hagan
my $package = get_package_by_element_size($size);
$self->_package($package);
my $length = ref $data ? sub { $#$data; } : sub { $data - 1 };
if($self->variable_length){
$length = ref $data ? sub { 1 + int( rand( $#{ $self->_init } ) ); } : sub { 1 + int( rand( $self->_init - 1) ); };
}
$self->_length( $length );
$self->chromosomes( [ ] );
push @{$self->chromosomes},
AI::Genetic::Pro::Chromosome->new($self->_translations, $self->type, $package, $length->())
for 1..$self->population;
$self->_calculate_fitness_all();
}
#=======================================================================
# SAVE / LOAD ##########################################################
#=======================================================================
sub spew {
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
STORABLE->use( qw( store retrieve freeze thaw ) ) or croak(q/You need "/.STORABLE.q/" module to save a state of "/.__PACKAGE__.q/"!/);
$Storable::Deparse = 1;
$Storable::Eval = 1;
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
my ( $self ) = @_;
my $clone = {
_selector => undef,
_strategist => undef,
_mutator => undef,
};
$clone->{ chromosomes } = [ map { ${ tied( @$_ ) } } @{ $self->chromosomes } ]
if $self->_package;
foreach my $key(keys %$self){
next if exists $clone->{$key};
$clone->{$key} = $self->{$key};
}
return $clone;
}
#=======================================================================
sub slurp {
my ( $self, $dump ) = @_;
if( my $typ = $self->_package ){
@{ $dump->{ chromosomes } } = map {
my $arr = $typ->make_with_packed( $_ );
bless $arr, q[AI::Genetic::Pro::Chromosome];
} @{ $dump->{ chromosomes } };
}
%$self = %$dump;
return 1;
}
#=======================================================================
sub save {
my ( $self, $file ) = @_;
croak(q/You have to specify file!/) unless defined $file;
store( $self->spew, $file );
}
#=======================================================================
sub load {
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
STORABLE->use( qw( store retrieve freeze thaw ) ) or croak(q/You need "/.STORABLE.q/" module to load a state of "/.__PACKAGE__.q/"!/);
$Storable::Deparse = 1;
$Storable::Eval = 1;
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
my ($self, $file) = @_;
croak(q/You have to specify file!/) unless defined $file;
my $clone = retrieve($file);
return carp('Incorrect file!') unless $clone;
return $self->slurp( $clone );
}
#=======================================================================
# CHARTS ###############################################################
#=======================================================================
sub chart {
GD->require or croak(q/You need "/.GD.q/" module to draw chart of evolution!/);
my ($self, %params) = (shift, @_);
my $graph = GD()->new(($params{-width} || 640), ($params{-height} || 480));
my $data = $self->getHistory;
if(defined $params{-font}){
$graph->set_title_font ($params{-font}, 12);
$graph->set_x_label_font($params{-font}, 10);
$graph->set_y_label_font($params{-font}, 10);
$graph->set_legend_font ($params{-font}, 8);
}
$graph->set_legend(
$params{legend1} || q/Max value/,
$params{legend2} || q/Mean value/,
$params{legend3} || q/Min value/,
);
$graph->set(
x_label_skip => int(($data->[0]->[-1]*4)/100),
x_labels_vertical => 1,
x_label_position => .5,
y_label_position => .5,
y_long_ticks => 1, # poziome linie
x_ticks => 1, # poziome linie
l_margin => 10,
b_margin => 10,
r_margin => 10,
t_margin => 10,
show_values => (defined $params{-show_values} ? 1 : 0),
values_vertical => 1,
values_format => ($params{-format} || '%.2f'),
zero_axis => 1,
#interlaced => 1,
logo_position => 'BR',
legend_placement => 'RT',
bgclr => 'white',
boxclr => '#FFFFAA',
transparent => 0,
title => ($params{'-title'} || q/Evolution/ ),
x_label => ($params{'-x_label'} || q/Generation/),
y_label => ($params{'-y_label'} || q/Value/ ),
( $params{-logo} && -f $params{-logo} ? ( logo => $params{-logo} ) : ( ) )
);
my $gd = $graph->plot( [ [ 0..$#{$data->[0]} ], @$data ] ) or croak($@);
open(my $fh, '>', $params{-filename}) or croak($@);
binmode $fh;
print $fh $gd->png;
close $fh;
return 1;
}
#=======================================================================
# TRANSLATIONS #########################################################
#=======================================================================
sub as_array_def_only {
my ($self, $chromosome) = @_;
return $self->as_array($chromosome)
if not $self->variable_length or $self->variable_length < 2;
if( $self->type eq q/bitvector/ ){
return $self->as_array($chromosome);
}else{
my $ar = $self->as_array($chromosome);
my $idx = first_index { $_ } @$ar;
my @array = @$ar[$idx..$#$chromosome];
return @array if wantarray;
return \@array;
}
}
#=======================================================================
sub as_array {
my ($self, $chromosome) = @_;
if($self->type eq q/bitvector/){
# This could lead to internal error, bacause of underlaying Tie::Array::Packed
#return @$chromosome if wantarray;
#return $chromosome;
my @chr = @$chromosome;
return @chr if wantarray;
return \@chr;
}elsif($self->type eq q/rangevector/){
my $fix_range = $self->_fix_range;
my $c = -1;
#my @array = map { $c++; warn "WARN: $c | ",scalar @$chromosome,"\n" if not defined $fix_range->[$c]; $_ ? $_ - $fix_range->[$c] : undef } @$chromosome;
my @array = map { $c++; $_ ? $_ - $fix_range->[$c] : undef } @$chromosome;
return @array if wantarray;
return \@array;
}else{
my $cnt = 0;
my @array = map { $self->_translations->[$cnt++]->[$_] } @$chromosome;
return @array if wantarray;
return \@array;
}
}
#=======================================================================
sub as_string_def_only {
my ($self, $chromosome) = @_;
return $self->as_string($chromosome)
if not $self->variable_length or $self->variable_length < 2;
my $array = $self->as_array_def_only($chromosome);
return join(q//, @$array) if $self->type eq q/bitvector/;
return join(q/___/, @$array);
}
#=======================================================================
sub as_string {
return join(q//, @{$_[1]}) if $_[0]->type eq q/bitvector/;
return join(q/___/, map { defined $_ ? $_ : q/ / } $_[0]->as_array($_[1]));
}
#=======================================================================
sub as_value {
my ($self, $chromosome) = @_;
croak(q/You MUST call 'as_value' as method of 'AI::Genetic::Pro' object./)
unless defined $_[0] and ref $_[0] and ( ref $_[0] eq 'AI::Genetic::Pro' or ref $_[0] eq 'AI::Genetic::Pro::MCE');
croak(q/You MUST pass 'AI::Genetic::Pro::Chromosome' object to 'as_value' method./)
unless defined $_[1] and ref $_[1] and ref $_[1] eq 'AI::Genetic::Pro::Chromosome';
return $self->fitness->($self, $chromosome);
}
#=======================================================================
# ALGORITHM ############################################################
#=======================================================================
sub _calculate_fitness_all {
my ($self) = @_;
$self->_fitness( { } );
$self->_fitness->{$_} = $self->fitness()->($self, $self->chromosomes->[$_])
for 0..$#{$self->chromosomes};
# sorting the population is not necessary
# my (@chromosomes, %fitness);
# for my $idx (sort { $self->_fitness->{$a} <=> $self->_fitness->{$b} } keys %{$self->_fitness}){
# push @chromosomes, $self->chromosomes->[$idx];
# $fitness{$#chromosomes} = $self->_fitness->{$idx};
# delete $self->_fitness->{$idx};
# delete $self->chromosomes->[$idx];
# }
#
# $self->_fitness(\%fitness);
# $self->chromosomes(\@chromosomes);
return;
}
#=======================================================================
sub _select_parents {
my ($self) = @_;
unless($self->_selector){
croak "You must specify a selection strategy!"
unless defined $self->selection;
my @tmp = @{$self->selection};
my $selector = q/AI::Genetic::Pro::Selection::/ . shift @tmp;
$selector->require or die $!;
$self->_selector($selector->new(@tmp));
}
$self->_parents($self->_selector->run($self));
return;
}
#=======================================================================
sub _crossover {
my ($self) = @_;
unless($self->_strategist){
my @tmp = @{$self->strategy};
my $strategist = q/AI::Genetic::Pro::Crossover::/ . shift @tmp;
$strategist->require or die $!;
$self->_strategist($strategist->new(@tmp));
}
my $a = $self->_strategist->run($self);
$self->chromosomes( $a );
return;
}
#=======================================================================
sub _mutation {
my ($self) = @_;
unless($self->_mutator){
my $mutator = q/AI::Genetic::Pro::Mutation::/ . ucfirst(lc($self->type));
unless($mutator->require){
$mutator = q/AI::Genetic::Pro::Mutation::Listvector/;
$mutator->require;
}
$self->_mutator($mutator->new);
}
return $self->_mutator->run($self);
}
#=======================================================================
sub _save_history {
my @tmp;
if($_[0]->history){ @tmp = $_[0]->getAvgFitness; }
else { @tmp = (undef, undef, undef); }
push @{$_[0]->_history->[0]}, $tmp[0];
push @{$_[0]->_history->[1]}, $tmp[1];
push @{$_[0]->_history->[2]}, $tmp[2];
return 1;
}
#=======================================================================
sub inject {
my ($self, $candidates) = @_;
for(@$candidates){
push @{$self->chromosomes},
AI::Genetic::Pro::Chromosome->new_from_data($self->_translations, $self->type, $self->_package, $_, $self->_fix_range);
$self->_fitness->{$#{$self->chromosomes}} = $self->fitness()->($self, $self->chromosomes->[-1]);
}
$self->_strict( [ ] );
$self->population( $self->population + scalar( @$candidates ) );
return 1;
}
#=======================================================================
sub _state {
my ( $self ) = @_;
my @res;
if( $self->_package ){
@res = map {
[
${ tied( @{ $self->chromosomes->[ $_ ] } ) },
$self->_fitness->{ $_ },
]
} 0 .. $self->population - 1
}else{
@res = map {
[
$self->chromosomes->[ $_ ],
$self->_fitness->{ $_ },
]
} 0 .. $self->population - 1
}
return \@res;
}
#=======================================================================
sub evolve {
my ($self, $generations) = @_;
# generations must be defined
$generations ||= -1;
if($self->strict and $self->_strict){
for my $idx (0..$#{$self->chromosomes}){
croak(q/Chromosomes was modified outside the 'evolve' function!/) unless $self->chromosomes->[$idx] and $self->_strict->[$idx];
my @tmp0 = @{$self->chromosomes->[$idx]};
my @tmp1 = @{$self->_strict->[$idx]};
croak(qq/Chromosome was modified outside the 'evolve' function from "@tmp0" to "@tmp1"!/) unless compare(\@tmp0, \@tmp1);
}
}
# split into two loops just for speed
unless($self->preserve){
for(my $i = 0; $i != $generations; $i++){
# terminate ----------------------------------------------------
last if $self->terminate and $self->terminate->($self);
# update generation --------------------------------------------
$self->generation($self->generation + 1);
# update history -----------------------------------------------
$self->_save_history;
# selection ----------------------------------------------------
$self->_select_parents();
# crossover ----------------------------------------------------
$self->_crossover();
# mutation -----------------------------------------------------
$self->_mutation();
}
}else{
croak('You cannot preserve more chromosomes than is in population!') if $self->preserve > $self->population;
my @preserved;
for(my $i = 0; $i != $generations; $i++){
# terminate ----------------------------------------------------
last if $self->terminate and $self->terminate->($self);
# update generation --------------------------------------------
$self->generation($self->generation + 1);
# update history -----------------------------------------------
$self->_save_history;
#---------------------------------------------------------------
# preservation of N unique chromosomes
@preserved = map { clone($_) } @{ $self->getFittest_as_arrayref($self->preserve - 1, 1) };
# selection ----------------------------------------------------
$self->_select_parents();
# crossover ----------------------------------------------------
$self->_crossover();
# mutation -----------------------------------------------------
$self->_mutation();
#---------------------------------------------------------------
for(@preserved){
my $idx = int rand @{$self->chromosomes};
$self->chromosomes->[$idx] = $_;
$self->_fitness->{$idx} = $self->fitness()->($self, $_);
}
}
}
if($self->strict){
$self->_strict( [ ] );
push @{$self->_strict}, $_->clone for @{$self->chromosomes};
}
}
#=======================================================================
# ALIASES ##############################################################
#=======================================================================
sub people { $_[0]->chromosomes() }
#=======================================================================
sub getHistory { $_[0]->_history() }
#=======================================================================
sub mutProb { shift->mutation(@_) }
#=======================================================================
sub crossProb { shift->crossover(@_) }
#=======================================================================
sub intType { shift->type() }
#=======================================================================
# STATS ################################################################
#=======================================================================
sub getFittest_as_arrayref {
my ($self, $n, $uniq) = @_;
$n ||= 1;
$self->_calculate_fitness_all() unless scalar %{ $self->_fitness };
my @keys = sort { $self->_fitness->{$a} <=> $self->_fitness->{$b} } 0..$#{$self->chromosomes};
if($uniq){
my %grep;
my $chromosomes = $self->chromosomes;
if( my $pkg = $self->_package ){
my %tmp;
@keys = grep {
my $key = ${ tied( @{ $chromosomes->[ $_ ] } ) };
#my $key = md5_hex( ${ tied( @{ $chromosomes->[ $_ ] } ) } ); # ?
$tmp{ $key } && 0 or $tmp{ $key } = 1;
} @keys;
#@keys = grep {
# my $add_to_list = 0;
# my $key = md5_hex(${tied(@{$chromosomes->[$_]})});
# unless($grep{$key}) {
# $grep{$key} = 1;
# $add_to_list = 1;
# }
# $add_to_list;
# } @keys;
}else{
my %tmp;
@keys = grep {
my $key = md5_hex( join( q[:], @{ $chromosomes->[ $_ ] } ) );
$tmp{ $key } && 0 or $tmp{ $key } = 1;
} @keys;
}
}
$n = scalar @keys if $n > scalar @keys;
return [ reverse @{$self->chromosomes}[ splice @keys, $#keys - $n + 1, $n ] ];
}
#=======================================================================
sub getFittest { return wantarray ? @{ shift->getFittest_as_arrayref(@_) } : shift @{ shift->getFittest_as_arrayref(@_) }; }
#=======================================================================
sub getAvgFitness {
my ($self) = @_;
my @minmax = minmax values %{$self->_fitness};
my $mean = sum(values %{$self->_fitness}) / scalar values %{$self->_fitness};
return $minmax[1], int($mean), $minmax[0];
}
#=======================================================================
1;
__END__
=head1 NAME
AI::Genetic::Pro - Efficient genetic algorithms for professional purpose with support for multiprocessing.
=head1 SYNOPSIS
use AI::Genetic::Pro;
sub fitness {
my ($ga, $chromosome) = @_;
return oct('0b' . $ga->as_string($chromosome));
}
sub terminate {
my ($ga) = @_;
my $result = oct('0b' . $ga->as_string($ga->getFittest));
return $result == 4294967295 ? 1 : 0;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 1000, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.01, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 0, # cache results
-history => 1, # remember best results
-preserve => 3, # remember the bests
-variable_length => 1, # turn variable length ON
-mce => 1, # optional MCE support
-workers => 3, # number of workers (MCE)
);
# init population of 32-bit vectors
$ga->init(32);
# evolve 10 generations
$ga->evolve(10);
# best score
print "SCORE: ", $ga->as_value($ga->getFittest), ".\n";
# save evolution path as a chart
$ga->chart(-filename => 'evolution.png');
# save state of GA
$ga->save('genetic.sga');
# load state of GA
$ga->load('genetic.sga');
=head1 DESCRIPTION
This module provides efficient implementation of a genetic algorithm for
professional purpose with support for multiprocessing. It was designed to operate as fast as possible
even on very large populations and big individuals/chromosomes. C<AI::Genetic::Pro>
was inspired by C<AI::Genetic>, so it is in most cases compatible
(there are some changes). Additionally C<AI::Genetic::Pro> isn't a pure Perl solution, so it
doesn't have limitations of its ancestor (such as slow-down in the
case of big populations ( >10000 ) or vectors with more than 33 fields).
If You are looking for a pure Perl solution, consider L<AI::Genetic>.
=over 4
=item Speed
To increase speed XS code is used, however with portability in
mind. This distribution was tested on Windows and Linux platforms
(and should work on any other).
view release on metacpan - search on metacpan
( run in 1.433 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )