view release on metacpan or  search on metacpan

AI/Gene/Simple.pm  view on Meta::CPAN

    next if $pos1 == $pos2;
    my $len1 = !defined($_[3]) ? 1 : ($_[3] || int rand $glen);
    my $len2 = !defined($_[4]) ? 1 : ($_[4] || int rand $glen);

    if ($pos1 > $pos2) { # ensure $pos1 comes first
      ($pos1, $pos2) = ($pos2, $pos1);
      ($len1, $len2) = ($len2, $len1);
    }

    if ( ($pos1 + $len1) > $pos2 # ensure no overlaps
	 or ($pos2 + $len2) > $glen
	 or $pos1 >= $glen ) {
      next;
    }

    my @chunk1 = splice(@{$self->[0]}, $pos1, $len1,
			splice(@{$self->[0]}, $pos2, $len2) );
    splice @{$self->[0]}, $pos2 + $len2 - $len1,0, @chunk1;
    $rt++;
  }
  return $rt;
}

##
# takes a sequence, removes it, then inserts it at another position
# odd things might occur if posn to replace to lies within area taken from
# 0: number to perform
# 1: posn to get from   (undef for rand)
# 2: posn to put        (undef for rand)
# 3: length of sequence (undef for 1, 0 for rand)

sub mutate_shuffle {
  my $self = shift;
  my $num = +$_[0] || 1;
  my $rt = 0;
  
  for (1..$num) {
    my $glen = scalar @{$self->[0]};
    my $pos1 = defined($_[1]) ? $_[1] : int rand $glen;
    my $pos2 = defined($_[2]) ? $_[2] : int rand $glen;
    my $len = !defined($_[3]) ? 1 : ($_[3] || int rand $glen);

    next if ($pos1 +$len > $glen                      # outside gene
	     or $pos2 >= $glen                        # outside gene
	     or ($pos2 < ($pos1 + $len) and $pos2 > $pos1)); # overlap

    if ($pos1 < $pos2) {
      splice (@{$self->[0]}, $pos2-$len, 0, 
	      splice(@{$self->[0]}, $pos1, $len) );
    }
    else {
      splice(@{$self->[0]}, $pos2, 0,
	     splice(@{$self->[0]}, $pos1, $len) );
    }
    $rt++;
  }
  return $rt;
}

# These are intended to be overriden, simple versions are
# provided for the sake of testing.

# Generates things to make up genes
# can be called with a token type to produce, or with none.
# if called with a token type, it will also be passed the original
# token as the second argument.
# should return a two element list of the token type followed by the token itself.

sub generate_token {
  my $self = shift;
  my $token_type = $_[0];
  my $letter = ('a'..'z')[rand 25];
  unless ($token_type) {
    return $letter;
  }
  return $token_type;
}

## You might also want to have methods like the following,
# they will not be called by the 'sequence' methods.

# Default constructor
sub new {
  my $gene = [[]]; # leave space for other info
  return bless $gene, ref $_[0] || $_[0];
}

# remember that clone method may require deep copying depending on
# your specific needs

sub clone {
  my $self = shift;
  my $new = [];
  $new->[0] = [@{$self->[0]}];
  return bless $new, ref $self;
}

# You need some way to use the gene you've made and mutated, but
# this will let you have a look, if it starts being odd.

sub render_gene {
  my $self = shift;
  my $return =  "$self\n";
  $return .= (join ',', @{$self->[0]}). "\n";
  return $return;
}

# used for testing

sub _test_dump {
  my $self = shift;
  my $rt = (join('',@{$self->[0]}));
  return $rt;
}
1;

__END__;

=pod

=head1 NAME

 AI::Gene::Simple

=head1 SYNOPSIS

A base class for storing and mutating genetic sequences.

 package Somegene;
 use AI::Gene::Simple;
 our @ISA = qw (AI::Gene::Simple);

 sub generate_token {
   my $self = shift;
   my $prev = $_[0] ? $_[0] + (1-rand(1)) : rand(1)*10;
   return $prev;
 }

 sub calculate {
   my $self = shift;
   my $x = $_[0];
   my $rt=0;
   for (0..(scalar(@{$self->[0]}) -1)) {
     $rt += $self->[0][$_] * ($x ** $_);
   }
   return $rt;
 }

 sub seed {
   my $self = shift;
   $self->[0][$_] = rand(1) * 10 for (0..$_[0]);
   return $self;
 }

 # ... then elsewhere

 package main;

 my $gene = Somegene->new;
 $gene->seed(5);
 print $gene->calculate(2), "\n";
 $gene->mutate_minor;
 print $gene->calculate(2), "\n";
 $gene->mutate_major;
 print $gene->calculate(2), "\n";

=head1 DESCRIPTION

This is a class which provides generic methods for the
creation and mutation of genetic sequences.  Various mutations