AI-Genetic-Pro
18 results

 view release on metacpan or  search on metacpan

lib/AI/Genetic/Pro.pm  view on Meta::CPAN 

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!/)

lib/AI/Genetic/Pro.pm  view on Meta::CPAN 

	
	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 ) = @_;

lib/AI/Genetic/Pro/Chromosome.pm  view on Meta::CPAN 

		#@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;

	my @genes;	
	tie @genes, $package if $package;

lib/AI/Genetic/Pro/Chromosome.pm  view on Meta::CPAN 

		for my $idx(0..$#$values){
			my $id = first_index { 
				not defined $values->[$idx] and not defined $_ or 
				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;
	}
	
	return bless( $cln );
	
	#my $genes = tied(@{$self})->make_clone;
	#return bless($genes);
}

#=======================================================================
1;

lib/AI/Genetic/Pro/Crossover/Distribution.pm  view on Meta::CPAN 

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

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) = @_;

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;
}
#=======================================================================

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;

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;

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;

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;

lib/AI/Genetic/Pro/MCE.pm  view on Meta::CPAN 

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

lib/AI/Genetic/Pro/MCE.pm  view on Meta::CPAN 

	#-------------------------------------------------------------------
	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 );
	for my $sth ( @$lst ){
		push @chr, $sth->[ 0 ];
		$fit{ $#chr } = $sth->[ 1 ];
	}
	
	#@$lst = ( );

lib/AI/Genetic/Pro/MCE.pm  view on Meta::CPAN 

			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 ] } ){
					$ary->[ 0 ][ $idx ] = $typ->make_with_packed( $ary->[ 0 ][ $idx ] );
					bless $ary->[ 0 ][ $idx ], q[AI::Genetic::Pro::Chromosome];
				}	
			}
			#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
			$gal->population ( scalar( @{ $ary->[ 0 ] } ) );
			$gal->chromosomes( $ary->[ 0 ] );
			$gal->_fitness	 ( $ary->[ 1 ] );
			$gal->strict	 ( 0 );
			#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
			$gal->evolve	 ( 1 );
			#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

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

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;

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

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

lib/AI/Genetic/Pro/Selection/Distribution.pm  view on Meta::CPAN 

	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"

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;

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;

lib/AI/Genetic/Pro/Selection/RouletteDistribution.pm  view on Meta::CPAN 

	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 }



( run in 1.933 second using v1.01-cache-2.11-cpan-de7293f3b23 )