AI-Genetic-Pro
view release on metacpan or search on metacpan
NAME
AI::Genetic::Pro - Efficient genetic algorithms for professional
purpose with support for multiprocessing.
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
lib/AI/Genetic/Pro.pm view on Meta::CPAN
_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;
#-------------------------------------------------------------------
lib/AI/Genetic/Pro.pm view on Meta::CPAN
#-------------------------------------------------------------------
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;
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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,
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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);
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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;
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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];
lib/AI/Genetic/Pro.pm view on Meta::CPAN
# 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->{ $_ },
]
lib/AI/Genetic/Pro.pm view on Meta::CPAN
[
$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]};
lib/AI/Genetic/Pro.pm view on Meta::CPAN
}
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 ){
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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
lib/AI/Genetic/Pro/Array/Type.pm view on Meta::CPAN
use Exporter::Lite;
use Tie::Array::Packed;
#=======================================================================
our @EXPORT_OK = qw(
get_package_by_element_size
get_array_ref_by_element_size
);
#-----------------------------------------------------------------------
our $Native = 0;
#=======================================================================
sub get_package_by_element_size {
return if $Native;
my $size = shift;
my $type = #$size < 32 ? undef : # Pure Perl array
#$size < 32 ? 'AI::Genetic::Pro::Array::Tied' : # Pure Perl array
$size < 128 ? 'Tie::Array::Packed::Char' : # 8 bits
$size < 256 ? 'Tie::Array::Packed::UnsignedChar' : # 8 bits
$size < 65_537 ? 'Tie::Array::Packed::ShortNative' : # 16 bits
$size < 131_073 ? 'Tie::Array::Packed::UnsignedShortNative' : # 16 bits
$size < 2_147_483_648 ? 'Tie::Array::Packed::Integer' : # 32 bits
$size < 4_294_967_297 ? 'Tie::Array::Packed::UnsignedInteger' : # 32 bits; MAX
undef;
return unless $type;
return $type;
}
#=======================================================================
sub get_array_ref_by_element_size {
my $package = get_package_by_element_size(shift);
my @array;
tie @array, $package if $package;
return \@array;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Chromosome.pm view on Meta::CPAN
package AI::Genetic::Pro::Chromosome;
$AI::Genetic::Pro::Chromosome::VERSION = '1.009';
use warnings;
use strict;
use List::Util qw(shuffle first);
use List::MoreUtils qw(first_index);
use Tie::Array::Packed;
#use Math::Random qw(random_uniform_integer);
#=======================================================================
sub new {
my ($class, $data, $type, $package, $length) = @_;
my @genes;
tie @genes, $package if $package;
if($type eq q/bitvector/){
#@genes = random_uniform_integer(scalar @$data, 0, 1); # this is fastest, but uses more memory
@genes = map { rand > 0.5 ? 1 : 0 } 0..$length; # this is faster
#@genes = split(q//, unpack("b*", rand 99999), $#$data + 1); # slow
}elsif($type eq q/combination/){
lib/AI/Genetic/Pro/Chromosome.pm view on Meta::CPAN
@genes = shuffle 0..$length;
}elsif($type eq q/rangevector/){
@genes = map { $_->[1] + int rand($_->[2] - $_->[1] + 1) } @$data[0..$length];
}else{
@genes = map { 1 + int(rand( $#{ $data->[$_] })) } 0..$length;
}
return bless \@genes, $class;
}
#=======================================================================
sub new_from_data {
my ($class, $data, $type, $package, $values, $fix_range) = @_;
die qq/\nToo many elements in the injected chromosome of type "$type": @$values\n/ if $#$values > $#$data;
my @genes;
tie @genes, $package if $package;
if($type eq q/bitvector/){
die qq/\nInproper value in the injected chromosome of type "$type": @$values\n/
if first { not defined $_ or ($_ != 0 and $_ != 1) } @$values;
lib/AI/Genetic/Pro/Chromosome.pm view on Meta::CPAN
defined $_ and defined $values->[$idx] and $_ eq $values->[$idx]
} @{$data->[$idx]}; # pomijamy poczatkowy undef
die qq/\nInproper element in the injected chromosome of type "$type": @$values\n/ if $id == -1;
push @genes, $id;
}
}
return bless \@genes, $class;
}
#=======================================================================
sub clone
{
my ( $self ) = @_;
my $cln;
if( my $obj = tied( @$self ) ){
$cln = $obj->make_clone;
}else{
@$cln = @$self;
}
lib/AI/Genetic/Pro/Crossover/Distribution.pm view on Meta::CPAN
random_uniform_integer
random_normal
random_beta
random_binomial
random_chi_square
random_exponential
random_poisson
);
use List::MoreUtils qw(first_index);
#=======================================================================
sub new {
my ($class, $type, @params) = @_;
bless {
type => $type,
params => \@params,
}, $class;
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my $high = scalar @{$chromosomes->[0]};
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
lib/AI/Genetic/Pro/Crossover/OX.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::OX;
$AI::Genetic::Pro::Crossover::OX::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub save_fitness {
my ($self, $ga, $idx) = @_;
$ga->_fitness->{$idx} = $ga->fitness->($ga, $ga->chromosomes->[$idx]);
return $ga->chromosomes->[$idx];
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
lib/AI/Genetic/Pro/Crossover/PMX.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::PMX;
$AI::Genetic::Pro::Crossover::PMX::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(indexes);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub dup {
my ($ar) = @_;
my %seen;
my @dup = grep { if($seen{$_}){ 1 }else{ $seen{$_} = 1; 0} } @$ar;
return \@dup if @dup;
return;
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
lib/AI/Genetic/Pro/Crossover/Points.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::Points;
$AI::Genetic::Pro::Crossover::Points::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
lib/AI/Genetic/Pro/Crossover/PointsAdvanced.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::PointsAdvanced;
$AI::Genetic::Pro::Crossover::PointsAdvanced::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#use AI::Genetic::Pro::Array::PackTemplate;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
push @$chromosomes, $chromosomes->[$elders[0]];
lib/AI/Genetic/Pro/Crossover/PointsBasic.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::PointsBasic;
$AI::Genetic::Pro::Crossover::PointsBasic::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
lib/AI/Genetic/Pro/Crossover/PointsSimple.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::PointsSimple;
$AI::Genetic::Pro::Crossover::PointsSimple::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
use MCE::Util;
#-----------------------------------------------------------------------
$Storable::Deparse = 1;
$Storable::Eval = 1;
#-----------------------------------------------------------------------
__PACKAGE__->mk_accessors( qw(
_pop
_tpl
));
#=======================================================================
sub new {
my ( $cls, $obj, $tpl ) = @_;
my $self = bless $obj, $cls;
#-------------------------------------------------------------------
$self->_init_mce;
$self->_init_pop;
#-------------------------------------------------------------------
$AI::Genetic::Pro::Array::Type::Native = 1 if $self->native;
#-------------------------------------------------------------------
delete $tpl->{ $_ } for qw( -history -mce -population -workers );
$self->_tpl( $tpl );
#-------------------------------------------------------------------
return $self;
}
#=======================================================================
sub _init_pop {
my ( $self ) = @_;
my $pop = int( $self->population / $self->workers );
my $rst = $self->population % $self->workers;
my @pop = ( $pop ) x $self->workers;
$pop[ 0 ] += $rst;
$self->_pop( \@pop );
}
#=======================================================================
sub _calculate_fitness_all {
my ($self) = @_;
# Faster version. Thanks to Mario Roy :-)
my %fit = mce_map_s {
$_ => $self->fitness()->( $self, $self->chromosomes->[ $_ ] )
} 0, $#{ $self->chromosomes };
# The old one
#my %fit = mce_map {
# $_ => $self->fitness()->( $self, $self->chromosomes->[ $_ ] )
# } 0 .. $#{ $self->chromosomes };
$self->_fitness( \%fit );
return;
}
#=======================================================================
sub _init_mce {
my ( $self ) = @_;
#-------------------------------------------------------------------
$self->workers( MCE::Util::get_ncpu() ) unless $self->workers;
#-------------------------------------------------------------------
MCE::Map->init(
chunk_size => 1, # Thanks Roy :-)
#chunk_size => q[auto], # The old one
max_workers => $self->workers,
posix_exit => 1, # Thanks Roy :-)
);
#-------------------------------------------------------------------
return;
}
#=======================================================================
sub init {
my ( $self, $val ) = @_;
#-------------------------------------------------------------------
my $pop = $self->population;
$self->population( 1 );
$self->SUPER::init( $val );
$self->population( $pop );
#-------------------------------------------------------------------
my $one = shift @{ $self->chromosomes };
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
my $gal = AI::Genetic::Pro->new( %$arg );
$gal->init( $val );
@{ $gal->_state };
} @{ $self->_pop };
#-------------------------------------------------------------------
return $self->_adopt( \@lst );
}
#=======================================================================
sub _adopt {
my ( $self, $lst ) = @_;
if( my $typ = $self->_package ){
for my $idx ( 0 .. $#$lst ){
$lst->[ $idx ]->[ 0 ] = $typ->make_with_packed( $lst->[ $idx ]->[ 0 ] );
bless $lst->[ $idx ]->[ 0 ], q[AI::Genetic::Pro::Chromosome];
}
}
my ( @chr, %fit, @rhc, %tif );
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
push @rhc, $chr[ $i ];
$tif{ $#rhc } = $fit{ $i };
}
$self->_fitness ( \%tif );
$self->chromosomes( \@rhc );
return;
}
#=======================================================================
sub _chunks {
my ( $self ) = @_;
my $cnt = 0;
my @chk;
for my $idx ( 0 .. $#{ $self->_pop } ){
my $pos = 0;
my %tmp = map { $pos++ => $self->_fitness->{ $_ } } $cnt .. $cnt + $self->_pop->[ $idx ] -1 ;
my @tmp = splice @{ $self->chromosomes }, 0, $self->_pop->[ $idx ];
$cnt += @tmp;
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
push @chk, [
\@tmp,
\%tmp,
];
}
}
return \@chk;
}
#=======================================================================
sub evolve {
my ( $self, $generations ) = @_;
$generations ||= -1;
for(my $i = 0; $i != $generations; $i++){
# terminate ----------------------------------------------------
last if $self->terminate and $self->terminate->( $self );
# update generation --------------------------------------------
lib/AI/Genetic/Pro/Mutation/Bitvector.pm view on Meta::CPAN
package AI::Genetic::Pro::Mutation::Bitvector;
$AI::Genetic::Pro::Mutation::Bitvector::VERSION = '1.009';
use warnings;
use strict;
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
# main loop
for my $idx (0..$#$chromosomes){
lib/AI/Genetic/Pro/Mutation/Bitvector.pm view on Meta::CPAN
$chromosomes->[$idx]->[$id] = $chromosomes->[$idx]->[$id] ? 0 : 1;
}
# we need to change fitness
$_fitness->{$idx} = $fitness->($ga, $chromosomes->[$idx]);
}
return 1;
}
#=======================================================================
# too slow; mutation is too dangerous in this solution
sub run0 {
my ($self, $ga) = @_;
my $mutation = $ga->mutation; # this is declared here just for speed
foreach my $chromosome (@{$ga->{chromosomes}}){
if(rand() < $mutation){ tied(@$chromosome)->reverse; }
else{
for(0..$#$chromosome){
next if rand > $mutation;
$chromosome->[$_] = $chromosome->[$_] ? 0 : 1;
}
lib/AI/Genetic/Pro/Mutation/Combination.pm view on Meta::CPAN
package AI::Genetic::Pro::Mutation::Combination;
$AI::Genetic::Pro::Mutation::Combination::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my $inv = $mutation / 2;
# main loop
lib/AI/Genetic/Pro/Mutation/Listvector.pm view on Meta::CPAN
package AI::Genetic::Pro::Mutation::Listvector;
$AI::Genetic::Pro::Mutation::Listvector::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
# main loop
for my $idx (0..$#$chromosomes){
lib/AI/Genetic/Pro/Mutation/Rangevector.pm view on Meta::CPAN
package AI::Genetic::Pro::Mutation::Rangevector;
$AI::Genetic::Pro::Mutation::Rangevector::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
use Math::Random qw(random_uniform_integer);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
# main loop
for my $idx (0..$#$chromosomes){
lib/AI/Genetic/Pro/Mutation/Rangevector.pm view on Meta::CPAN
$chromosomes->[$idx]->[$id] = random_uniform_integer(1, @{$_translations->[$id]}[1..2]);
}
# we need to change fitness
$_fitness->{$idx} = $fitness->($ga, $chromosomes->[$idx]);
}
return 1;
}
#=======================================================================
sub run0 {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
# main loop
foreach my $chromosome (@{$ga->{chromosomes}}){
next if rand() <= $mutation;
if($ga->variable_length){
lib/AI/Genetic/Pro/Selection/Distribution.pm view on Meta::CPAN
random_uniform_integer
random_normal
random_beta
random_binomial
random_chi_square
random_exponential
random_poisson
);
use Carp 'croak';
#=======================================================================
sub new {
my ($class, $type, @params) = @_;
bless {
type => $type,
params => \@params,
}, $class;
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness, $chromosomes) = ($ga->_fitness, $ga->chromosomes);
croak "You must set a number of parents to use the Distribution strategy"
unless defined($ga->parents);
my $parents = $ga->parents;
my @parents;
my $high = scalar @$chromosomes;
#-------------------------------------------------------------------
if($self->{type} eq q/uniform/){
lib/AI/Genetic/Pro/Selection/Roulette.pm view on Meta::CPAN
package AI::Genetic::Pro::Selection::Roulette;
$AI::Genetic::Pro::Selection::Roulette::VERSION = '1.009';
use warnings;
use strict;
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use List::Util qw(sum min);
use List::MoreUtils qw(first_index);
use Carp 'croak';
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness) = ($ga->_fitness);
my (@parents, @elders);
#-------------------------------------------------------------------
my $count = $#{$ga->chromosomes};
my $const = min values %$fitness;
$const = $const < 0 ? abs($const) : 0;
my $total = sum( map { $_ < 0 ? $_ + $const : $_ } values %$fitness);
$total ||= 1;
lib/AI/Genetic/Pro/Selection/RouletteBasic.pm view on Meta::CPAN
package AI::Genetic::Pro::Selection::RouletteBasic;
$AI::Genetic::Pro::Selection::RouletteBasic::VERSION = '1.009';
use warnings;
use strict;
use List::Util qw(min);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use List::MoreUtils qw(first_index);
use Carp 'croak';
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness, $chromosomes) = ($ga->_fitness, $ga->chromosomes);
croak "You must set a number of parents to use the RouletteBasic strategy"
unless defined($ga->parents);
my $parents = $ga->parents;
my (@parents, @wheel);
my $const = min values %$fitness;
$const = $const < 0 ? abs($const) : 0;
my $total = 0;
lib/AI/Genetic/Pro/Selection/RouletteDistribution.pm view on Meta::CPAN
random_uniform
random_normal
random_beta
random_binomial
random_chi_square
random_exponential
random_poisson
);
use Carp 'croak';
#=======================================================================
sub new {
my ($class, $type, @params) = @_;
bless {
type => $type,
params => \@params,
}, $class;
}
#=======================================================================
sub roulette {
my ($total, $wheel) = @_;
my $rand = rand($total);
my $idx = first_index { $_->[1] > $rand } @$wheel;
if($idx == 0){ $idx = 1 }
elsif($idx == -1 ) { $idx = scalar @$wheel; }
return $wheel->[$idx-1]->[0];
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness, $chromosomes) = ($ga->_fitness, $ga->chromosomes);
croak "You must set a number of parents for the RouletteDistribution strategy"
unless defined($ga->parents);
my $parents = $ga->parents;
my $high = scalar @$chromosomes;
my (@parents, @wheel);
my $const = min values %$fitness;
$const = $const < 0 ? abs($const) : 0;
t/01_inject.t view on Meta::CPAN
use Test::More qw(no_plan);
use Struct::Compare;
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 1..BITS;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
t/02_cache.t view on Meta::CPAN
use warnings;
use FindBin qw($Bin);
use lib $Bin;
use Test::More qw(no_plan);
use Time::HiRes;
use AI::Genetic::Pro;
use constant BITS => 32;
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => sub { return; }, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 10, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 0, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
t/02_cache.t view on Meta::CPAN
$ga->init(BITS);
$ga->chromosomes( [ ] );
$ga->inject( [ [ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) ] ] );
my $start = [Time::HiRes::gettimeofday()];
$ga->as_value($ga->chromosomes->[0]) for 0..10000;
my $time0 =Time::HiRes::tv_interval($start);
$ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => sub { return; }, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 10, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 1, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
t/03_bitvectors_constant_length.t view on Meta::CPAN
use lib $Bin, $Bin.'../lib';
use Test::More qw(no_plan);
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 1..BITS;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
t/04_bitvectors_variable_length_I.t view on Meta::CPAN
use lib $Bin;
use Test::More qw(no_plan);
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 0..BITS-1;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
t/05_bitvectors_variable_length_II.t view on Meta::CPAN
use lib $Bin;
use Test::More qw(no_plan);
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 0..BITS-1;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
t/06_listvectors_constant_length.t view on Meta::CPAN
use AI::Genetic::Pro;
use constant SIZE => 8;
use constant MIN => -4;
use constant MAX => 4;
my @Win;
push @Win, MAX for 1..SIZE;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'listvector', # type of chromosomes
-population => 100, # population
t/07_listvectors_variable_length_I.t view on Meta::CPAN
use AI::Genetic::Pro;
use constant SIZE => 8;
use constant MIN => -4;
use constant MAX => 4;
my @Win;
push @Win, MAX for 1..SIZE;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'listvector', # type of chromosomes
-population => 100, # population
t/08_listvectors_variable_length_II.t view on Meta::CPAN
use AI::Genetic::Pro;
use constant SIZE => 8;
use constant MIN => -4;
use constant MAX => 4;
my @Win;
push @Win, MAX for 1..SIZE;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'listvector', # type of chromosomes
-population => 100, # population
t/09_rangevectors_constant_length.t view on Meta::CPAN
use AI::Genetic::Pro;
use constant SIZE => 8;
use constant MIN => -4;
use constant MAX => 4;
my @Win;
push @Win, MAX for 1..SIZE;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'rangevector', # type of chromosomes
-population => 100, # population
t/10_rangevectors_variable_length_I.t view on Meta::CPAN
use AI::Genetic::Pro;
use constant SIZE => 8;
use constant MIN => -4;
use constant MAX => 4;
my @Win;
push @Win, MAX for 1..SIZE;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'rangevector', # type of chromosomes
-population => 100, # population
( run in 1.091 second using v1.01-cache-2.11-cpan-a5abf4f5562 )