File Coverage

blib/lib/Algorithm/Evolve/Util.pm

Criterion	Covered	Total	%
statement	55	89	61.8
branch	7	26	26.9
condition	8	22	36.3
subroutine	10	12	83.3
pod	8	8	100.0
total	88	157	56.0

package Algorithm::Evolve::Util;

use strict;
use base 'Exporter';
use List::Util qw/shuffle/;
use Carp qw/croak carp/;

our $VERSION = '0.03';
our $UNICODE_STRINGS = 0;

our %EXPORT_TAGS = (
    str => [qw/str_crossover str_mutate str_agreement str_random/],
    arr => [qw/arr_crossover arr_mutate arr_agreement arr_random/],
);
our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;

sub str_crossover {
    my ($s1, $s2, $n_point) = @_;

    $n_point ||= 2;
    my $len    = length($s1);

    croak "Can't do ${n_point}-point crossover on length $len string"
        if $n_point >= $len;

    ## this allows for duplication of indices. maybe a fixme

    my @points = sort { $a <=> $b } map { int(rand $len) } 1 .. $n_point;
    push @points, $len if $n_point % 2;

    for (0 .. @points/2 - 1) {
        my ($x, $y) = @points[2*$_, 2*$_+1];
        (substr($s1, $x, $y-$x+1), substr($s2, $x, $y-$x+1)) =
            (substr($s2, $x, $y-$x+1), substr($s1, $x, $y-$x+1));
    }

    return ($s1, $s2);
}

sub str_agreement {
    my ($s1, $s2) = @_;

    ## substr is safe for unicode; xor'ing characters is not. But
    ## xor is about 30 times faster on longish strings...

    if ($UNICODE_STRINGS) {
        my $tally = 0;
        for (0 .. length($s1)-1) {
            $tally++ if substr($s1, $_, 1) eq substr($s2, $_, 1);
        }
        return $tally;
    }

    my $xor = $s1 ^ $s2;
    return $xor =~ tr/\x0/\x0/;
}

sub str_mutate {
    my ($string, $n, $alphabet) = @_;

    $n        ||= 1;
    $alphabet ||= [0,1];

    croak "Invalid alphabet"
        unless ref $alphabet eq 'ARRAY' and @$alphabet > 1;

    my $len = length($string);
    my @mutate_indices = $n < 1
        ? map { rand() < $n ? $_ : () } 0 .. $len-1
        : (shuffle 0 .. $len-1)[ 0 .. int($n)-1 ];

    for my $idx (@mutate_indices) {
        my $char                 = substr($string, $idx, 1);
        my @different            = grep { $char ne $_ } @$alphabet;
        substr($string, $idx, 1) = $different[ int(rand @different) ];
    }

    return $string;
}

sub str_random {
    my ($length, $alphabet) = @_;

    $alphabet ||= [0,1];

    return join '', map { $alphabet->[ rand @$alphabet ] } 1 .. $length;
}

##########################################

sub arr_crossover {
    my ($a1_ref, $a2_ref, $n_point) = @_;

    $n_point ||= 2;
    my @a1     = @$a1_ref;
    my @a2     = @$a2_ref;
    my $len    = @a1;

    croak "Can't do ${n_point}-point crossover on length $len array"
        if $n_point >= $len;

    ## this allows for duplication of indices. maybe a fixme

    my @points = sort { $a <=> $b } map { int(rand $len) } 1 .. $n_point;
    push @points, $len-1 if $n_point % 2;

    for (0 .. @points/2 - 1) {
        my ($x, $y)   = @points[2*$_, 2*$_+1];
        my @tmp       = @a1[$x .. $y];
        @a1[$x .. $y] = @a2[$x .. $y];
        @a2[$x .. $y] = @tmp;
    }

    return (\@a1, \@a2);
}

sub arr_agreement {
    my ($a1, $a2) = @_;

    my $tally = 0;
    for (0 .. $#{$a1}) {
        $tally++ if $a1->[$_] eq $a2->[$_];
    }

    return $tally;
}

sub arr_mutate {
    my ($arr_ref, $n, $alphabet) = @_;

    $n        ||= 1;
    $alphabet ||= [0,1];
    my @arr     = @$arr_ref;

    croak "Invalid alphabet"
        unless ref $alphabet eq 'ARRAY' and @$alphabet > 1;

    my $len = scalar @arr;
    my @mutate_indices = $n < 1
        ? map { rand() < $n ? $_ : () } 0 .. $len-1
        : (shuffle 0 .. $len-1)[ 0 .. int($n)-1 ];

    for my $idx (@mutate_indices) {
        my $char      = $arr[$idx];
        my @different = grep { $char ne $_ } @$alphabet;
        $arr[$idx]    = $different[ int(rand @different) ];
    }

    return \@arr;
}

sub arr_random {
    my ($length, $alphabet) = @_;

    $alphabet ||= [0,1];

    return [ map { $alphabet->[ rand @$alphabet ] } 1 .. $length ];
}


##########################################
##########################################
##########################################
1;
__END__