File Coverage

blib/lib/AI/Genetic/Pro/Crossover/PMX.pm

Criterion	Covered	Total	%
statement	60	62	96.7
branch	9	10	90.0
condition			n/a
subroutine	8	8	100.0
pod	0	3	0.0
total	77	83	92.7

package AI::Genetic::Pro::Crossover::PMX;

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){
			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)){
    					foreach my $val (@$dup){
        					my ($ind) = grep { $_ < $points[0] or $_ >= $points[1] } indexes { $_ == $val } @$a;
        					$a->[$ind] = $bv{$val};
    					}
					}

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