AI-Genetic-Pro
view release on metacpan or search on metacpan
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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);
lib/AI/Genetic/Pro.pm view on Meta::CPAN
$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;
}
#=======================================================================
lib/AI/Genetic/Pro.pm view on Meta::CPAN
#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);
}
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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;
}
#=======================================================================
lib/AI/Genetic/Pro.pm view on Meta::CPAN
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] = $_;
lib/AI/Genetic/Pro/Chromosome.pm view on Meta::CPAN
#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/){
#@genes = shuffle 0..$#{$data->[0]};
@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;
lib/AI/Genetic/Pro/Crossover/Distribution.pm view on Meta::CPAN
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my $len = scalar @elders;
my @seq;
if($self->{type} eq q/uniform/){
@seq = random_uniform_integer($high, 0, $#elders);
}elsif($self->{type} eq q/normal/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $len/2;
my $sd = defined $self->{params}->[1] ? $self->{params}->[1] : $len;
@seq = map { $_ % $len } random_normal($high, $av, $sd);
}elsif($self->{type} eq q/beta/){
my $aa = defined $self->{params}->[0] ? $self->{params}->[0] : $len;
my $bb = defined $self->{params}->[1] ? $self->{params}->[1] : $len;
@seq = map { int($_ * $len) } random_beta($high, $aa, $bb);
}elsif($self->{type} eq q/binomial/){
@seq = random_binomial($high, $#elders, rand);
}elsif($self->{type} eq q/chi_square/){
my $df = defined $self->{params}->[0] ? $self->{params}->[0] : $len;
@seq = map { $_ % $len } random_chi_square($high, $df);
}elsif($self->{type} eq q/exponential/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $len/2;
@seq = map { $_ % $len } random_exponential($high, $av);
}elsif($self->{type} eq q/poisson/){
my $mu = defined $self->{params}->[0] ? $self->{params}->[0] : $len/2;
@seq = map { $_ % $len } random_poisson($high, $mu) ;
}else{
die qq/Unknown distribution "$self->{type}" in "crossover"!\n/;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my ($min, $max) = (0, $#{$chromosomes->[0]} - 1);
if($ga->variable_length){
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
lib/AI/Genetic/Pro/Crossover/OX.pm view on Meta::CPAN
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
push @children, $chromosomes->[$elders[0]];
next;
}
my @points = sort { $a <=> $b } map { 1 + int(rand $#{$chromosomes->[0]}) } 0..1;
@elders = sort {
my @av = @{$a}[$points[0]..$points[1]];
my @bv = @{$b}[$points[0]..$points[1]];
for my $e(@av){
splice(@$b, (first_index { $_ == $e } @$b), 1);
}
splice @$b, $points[0], 0, @av;
for my $e(@bv){
splice(@$a, (first_index { $_ == $e } @$a), 1);
}
splice @$a, $points[0], 0, @bv;
0;
} map {
$chromosomes->[$_]->clone;
} @elders;
my %elders = map { $_ => $fitness->($ga, $elders[$_]) } 0..$#elders;
my $max = (sort { $elders{$a} <=> $elders{$b} } keys %elders)[-1];
$_fitness->{scalar(@children)} = $elders{$max};
push @children, $elders[$max];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
lib/AI/Genetic/Pro/Crossover/PMX.pm view on Meta::CPAN
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
push @children, $chromosomes->[$elders[0]];
next;
}
my @points = sort { $a <=> $b } map { 1 + int(rand $#{$chromosomes->[0]}) } 0..1;
@elders = sort {
my @av = @{$a}[$points[0]..$points[1]-1];
my @bv = splice @$b, $points[0], $points[1] - $points[0], @av;
splice @$a, $points[0], $points[1] - $points[0], @bv;
my %av; @av{@av} = @bv;
my %bv; @bv{@bv} = @av;
while(my $dup = dup($a)){
lib/AI/Genetic/Pro/Crossover/PMX.pm view on Meta::CPAN
}
while(my $dup = dup($b)){
foreach my $val (@$dup){
my ($ind) = grep { $_ < $points[0] or $_ >= $points[1] } indexes { $_ == $val } @$b;
$b->[$ind] = $av{$val};
}
}
0;
} map {
$chromosomes->[$_]->clone
} @elders;
my %elders = map { $_ => $fitness->($ga, $elders[$_]) } 0..$#elders;
my $max = (sort { $elders{$a} <=> $elders{$b} } keys %elders)[-1];
$_fitness->{scalar(@children)} = $elders{$max};
push @children, $elders[$max];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
lib/AI/Genetic/Pro/Crossover/Points.pm view on Meta::CPAN
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
my %elders = map { $_ => $fitness->($ga, $elders[$_]) } 0..$#elders;
my $maximum = (sort { $elders{$a} <=> $elders{$b} } keys %elders)[-1];
$_fitness->{scalar(@children)} = $elders{$maximum};
push @children, $elders[$maximum];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/PointsAdvanced.pm view on Meta::CPAN
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
push @$chromosomes, @elders;
}
#-------------------------------------------------------------------
# wybieranie potomkow ze zbioru starych i nowych osobnikow
@$chromosomes = sort { $fitness->($ga, $a) <=> $fitness->($ga, $b) } @$chromosomes;
splice @$chromosomes, 0, scalar(@$chromosomes) - $ga->population;
%$_fitness = map { $_ => $fitness->($ga, $chromosomes->[$_]) } 0..$#$chromosomes;
#-------------------------------------------------------------------
return $chromosomes;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/PointsBasic.pm view on Meta::CPAN
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
my $idx = int rand @elders;
$_fitness->{scalar(@children)} = $fitness->($ga, $elders[$idx]);
push @children, $elders[ $idx ];
lib/AI/Genetic/Pro/Crossover/PointsSimple.pm view on Meta::CPAN
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
push @children, @elders;
}
#-------------------------------------------------------------------
# wybieranie potomkow ze zbioru nowych osobnikow
@children = sort { $fitness->($ga, $a) <=> $fitness->($ga, $b) } @children;
splice @children, 0, scalar(@children) - scalar(@$chromosomes);
%$_fitness = map { $_ => $fitness->($ga, $children[$_]) } 0..$#children;
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
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 ) = @_;
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
#-------------------------------------------------------------------
my $pop = $self->population;
$self->population( 1 );
$self->SUPER::init( $val );
$self->population( $pop );
#-------------------------------------------------------------------
my $one = shift @{ $self->chromosomes };
my $tpl = $self->_tpl;
my @lst = mce_map {
my $arg = clone( $tpl );
$arg->{ -population } = $_;
my $gal = AI::Genetic::Pro->new( %$arg );
$gal->init( $val );
@{ $gal->_state };
} @{ $self->_pop };
#-------------------------------------------------------------------
return $self->_adopt( \@lst );
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
}
#=======================================================================
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;
if( $self->_package ){
push @chk, [
[ map { ${ tied( @$_ ) } } @tmp ],
\%tmp,
];
}else{
push @chk, [
\@tmp,
\%tmp,
];
}
}
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
# terminate ----------------------------------------------------
last if $self->terminate and $self->terminate->( $self );
# update generation --------------------------------------------
$self->generation($self->generation + 1);
# update history -----------------------------------------------
$self->_save_history;
my $tpl = $self->_tpl;
my @lst = mce_map {
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
my $ary = $_;
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
my $arg = clone( $tpl );
$arg->{ -population } = 1;
my $gal = AI::Genetic::Pro->new( %$arg );
$gal->init( 1 );
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if( my $typ = $self->_package ){
for my $idx ( 0 .. $#{ $ary->[ 0 ] } ){
lib/AI/Genetic/Pro/Selection/Distribution.pm view on Meta::CPAN
my $high = scalar @$chromosomes;
#-------------------------------------------------------------------
if($self->{type} eq q/uniform/){
push @parents,
pack 'I*', random_uniform_integer($parents, 0, $#$chromosomes)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/normal/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
my $sd = defined $self->{params}->[1] ? $self->{params}->[1] : $#$chromosomes;
push @parents,
pack 'I*', map { int $_ % $high } random_normal($parents, $av, $sd)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/beta/){
my $aa = defined $self->{params}->[0] ? $self->{params}->[0] : $parents;
my $bb = defined $self->{params}->[1] ? $self->{params}->[1] : $parents;
push @parents,
pack 'I*', map { int($_ * $high) } random_beta($parents, $aa, $bb)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/binomial/){
push @parents,
pack 'I*', random_binomial($parents, $#$chromosomes, rand)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/chi_square/){
my $df = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes;
push @parents,
pack 'I*', map { int $_ % $high } random_chi_square($parents, $df)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/exponential/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*', map { int $_ % $high } random_exponential($parents, $av)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/poisson/){
my $mu = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*', map { int $_ % $high } random_poisson($parents, $mu)
for 0..$#$chromosomes;
}else{
die qq/Unknown distribution "$self->{type}" in "selection"!\n/;
}
#-------------------------------------------------------------------
return \@parents;
}
#=======================================================================
lib/AI/Genetic/Pro/Selection/Roulette.pm view on Meta::CPAN
#=======================================================================
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;
# elders
for my $idx (0..$count){
push @elders, $idx for 1..int((($fitness->{$idx} + $const) / $total) * $count);
}
if((my $add = $count - scalar @elders) > 0){
my $idx = $elders[rand @elders];
push @elders, int rand($count) for 0..$add;
lib/AI/Genetic/Pro/Selection/RouletteDistribution.pm view on Meta::CPAN
my $total = 0;
#-------------------------------------------------------------------
foreach my $key (keys %$fitness){
$total += $fitness->{$key} + $const;
push @wheel, [ $key, $total ];
}
#-------------------------------------------------------------------
if($self->{type} eq q/uniform/){
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
random_uniform($parents, 0, $total)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/normal/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
my $sd = defined $self->{params}->[1] ? $self->{params}->[1] : $#$chromosomes;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_normal($parents, $av, $sd)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/beta/){
my $aa = defined $self->{params}->[0] ? $self->{params}->[0] : $parents;
my $bb = defined $self->{params}->[1] ? $self->{params}->[1] : $parents;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int($_ * $high) } random_beta($parents, $aa, $bb)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/binomial/){
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
random_binomial($parents, $#$chromosomes, rand)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/chi_square/){
my $df = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_chi_square($parents, $df)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/exponential/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_exponential($parents, $av)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/poisson/){
my $mu = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_poisson($parents, $mu)
for 0..$#$chromosomes;
}else{
die qq/Unknown distribution "$self->{type}" in "selection"!\n/;
}
#-------------------------------------------------------------------
return \@parents;
}
#=======================================================================
( run in 0.648 second using v1.01-cache-2.11-cpan-49f99fa48dc )