File Coverage

lib/Algorithm/Evolutionary/Op/Permutation.pm

Criterion	Covered	Total	%
statement	21	21	100.0
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	28	28	100.0

use strict;
use warnings;

=head1 NAME

Algorithm::Evolutionary::Op::Permutation - Per-mutation. Got it?

=head1 SYNOPSIS

  use Algorithm::Evolutionary::Op::Permutation;

  my $op = new Algorithm::Evolutionary::Op::Permutation ; #Create from scratch
  my $bit_chromosome =  new Algorithm::Evolutionary::Individual::BitString 10;
  $op->apply( $bit_chromosome );

  my $priority = 2;
  my $max_iterations = 100; # Less than 10!, absolute maximum number
			    # of permutations
  $op = new Algorithm::Evolutionary::Op::Permutation $priority, $max_iterations;

  my $xmlStr=<

  EOC
  my $ref = XMLin($xmlStr);

  my $op = Algorithm::Evolutionary::Op::->fromXML( $ref );
  print $op->asXML(), "\n*Arity ->", $op->arity(), "\n";

=head1 Base Class

L

=head1 DESCRIPTION

Class independent permutation operator; any individual that has the
    C<_str> instance variable (like
    L and
    L)  will have some
    of its elements swapped. Each string of length l has l!
    permutations; the C parameter should not be higher
    than that.

This kind of operator is used extensively in combinatorial
    optimization problems. See, for instance,
  @article{prins2004simple,
   title={{A simple and effective evolutionary algorithm for the vehicle routing problem}},
   author={Prins, C.},
   journal={Computers \& Operations Research},
   volume={31},
   number={12},
   pages={1985--2002},
   issn={0305-0548},
   year={2004},
   publisher={Elsevier}
  }

And, of course, L, where it is used in the
    evolutionary algorithms solutions.


=cut

package  Algorithm::Evolutionary::Op::Permutation;

use lib qw( ../../.. );

our ($VERSION) = ( '$Revision: 3.7 $ ' =~ /(\d+\.\d+)/ );

use Carp;
use Clone qw(clone);
use List::Util qw(shuffle);

use base 'Algorithm::Evolutionary::Op::Base';

#Class-wide constants
our $APPLIESTO =  'Algorithm::Evolutionary::Individual::String';
our $ARITY = 1;

=head1 METHODS

=head2 new( [$rate = 1][, $max_iterations = 10] )

Creates a new permutation operator; see
    L for details common to all
    operators. The chromosome will undergo a random number of at most
    C<$max_iterations>. By default, it equals 10.

=cut

sub new {
  my $class = shift;
  my $rate = shift || 1;

  my $self = Algorithm::Evolutionary::Op::Base::new( 'Algorithm::Evolutionary::Op::Permutation', $rate );
  return $self;
}


=head2 create

Creates a new mutation operator with an application priority, which
    defaults to 1.

Called create to distinguish from the classwide ctor, new. It just
makes simpler to create an Operator

=cut

sub create {
  my $class = shift;
  my $rate = shift || 1;

  my $self =  { rate => $rate,
	        max_iterations => shift || 10 };

  bless $self, $class;
  return $self;
}

=head2 apply( $chromosome )

Applies at most C permutations to a "Chromosome" that includes the C<_str>
    instance variable. The number of iterations will be random, so
    that applications of the operator on the same individual will
    create diverse offspring.

=cut

sub apply ($;$) {
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = clone($arg);
  croak "Incorrect type ".(ref $victim) if ! $self->check( $victim );
  my @arr = split("",$victim->{_str});
  my $how_many = 2+rand(@arr -1 ); # min two points
  my @points;
  my @indices = 0..$#arr;
  for (1..$how_many) {
    my $this_point = rand(@indices);
    push @points, $indices[$this_point];
    splice( @indices, $this_point, 1 );
  }
  my @copy_points;
  do {
    @copy_points = shuffle(@points );
  } while ( $copy_points[0] == $points[0] );
  while ( @points ) {
    my $this_point = shift @points;
    my $other_point = shift @copy_points ;
    substr( $victim->{'_str'}, $this_point, 1, $arr[$other_point]);
  }

#   my $p = new Algorithm::Permute( \@arr );
#   my $iterations = 1+rand($self->{'_max_iterations'}-1);
#   for (1..$iterations) {
#     @arr = $p->next;
#   }
#   if ( !@arr) {
#     croak "I broke \@arr $iterations ", $self->{'_max_iterations'}, " ", $victim->{'_str'},  "\n";
#   }
#   if ( join( "", @arr ) eq $arg->{'_str'} ) {
#     # Check for all equal
#     my %letters;
#     map( $letters{$_}=1, @arr );
#     if ( scalar keys %letters  > 1) {
#       $p->reset; # We are looking for anything different, after all
#       do {
# 	@arr = $p->next;
#       } until ( join( "", @arr ) ne $arg->{'_str'} );
# #      print "Vaya tela $iterations ", $self->{'_max_iterations'}, " ", $victim->{'_str'},  "\n";
#  #     print $victim->{'_str'}, "\n";
#     }
#   }
#   if ( !@arr) {
#     croak "Gosh $iterations ", $self->{'_max_iterations'}, " ", $victim->{'_str'},  "\n";
#   }
  return $victim;
}

=head2 SEE ALSO

Uses L, which is purported to be the fastest
    permutation library around. Might change it in the future to
    L, which is much more comprehensive.

=head1 Copyright

  This file is released under the GPL. See the LICENSE file included in this distribution,
  or go to http://www.fsf.org/licenses/gpl.txt

  CVS Info: $Date: 2013/01/09 07:22:50 $
  $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/Permutation.pm,v 3.7 2013/01/09 07:22:50 jmerelo Exp $
  $Author: jmerelo $
  $Revision: 3.7 $

=cut