AI-Gene-Sequence
view release on metacpan or search on metacpan
AI/Gene/Sequence.pm view on Meta::CPAN
else {
my $cum;
@{$h2}{ @{$muts} } = map {$cum +=$_; $cum / $sum} @{$hr}{ @{$muts} };
return ($h2, $muts);
}
}
##
# inserts one element into the sequence
# 0: number to perform ( or 1)
# 1: position to mutate (undef for random)
sub mutate_insert {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
my $pos = defined($_[1]) ? $_[1] : int rand $length;
next if $pos > $length; # further than 1 place after gene
my @token = $self->generate_token;
AI/Gene/Sequence.pm view on Meta::CPAN
$self->[0] = $new;
splice @{$self->[1]}, $pos, 0, $token[1];
$rt++;
}
return $rt;
}
##
# removes element(s) from sequence
# 0: number of times to perform
# 1: position to affect (undef for rand)
# 2: length to affect, undef => 1, 0 => random length
sub mutate_remove {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
my $len = !defined($_[2]) ? 1 : ($_[2] || int rand $length);
next if ($length - $len) <= 0;
my $pos = defined($_[1]) ? $_[1] : int rand $length;
AI/Gene/Sequence.pm view on Meta::CPAN
$self->[0] = $new;
splice @{$self->[1]}, $pos, $len;
$rt++;
}
return $rt;
}
##
# copies an element or run of elements into a random place in the gene
# 0: number to perform (or 1)
# 1: posn to copy from (undef for rand)
# 2: posn to splice in (undef for rand)
# 3: length (undef for 1, 0 for random)
sub mutate_duplicate {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
my $len = !defined($_[3]) ? 1 : ($_[3] || int rand $length);
my $pos1 = defined($_[1]) ? $_[1] : int rand $length;
my $pos2 = defined($_[2]) ? $_[2] : int rand $length;
AI/Gene/Sequence.pm view on Meta::CPAN
$self->[0] = $new;
splice @{$self->[1]}, $pos2, 0, @{$self->[1]}[$pos1..($pos1+$len-1)];
$rt++;
}
return $rt;
}
##
# Duplicates a sequence and writes it on top of some other position
# 0: num to perform (or 1)
# 1: pos to get from (undef for rand)
# 2: pos to start replacement (undef for rand)
# 3: length to operate on (undef => 1, 0 => rand)
sub mutate_overwrite {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $new = $self->[0];
my $length = length $self->[0];
my $len = !defined($_[3]) ? 1 : ($_[3] || int rand $length);
AI/Gene/Sequence.pm view on Meta::CPAN
@{$self->[1]}[$pos1..($pos1+$len-1)] );
$rt++;
}
return $rt;
}
##
# Takes a run of tokens and reverses their order, is a noop with 1 item
# 0: number to perform
# 1: posn to start from (undef for rand)
# 2: length (undef=>1, 0=>rand)
sub mutate_reverse {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
my $new = $self->[0];
my $pos = defined($_[1]) ? $_[1] : int rand $length;
AI/Gene/Sequence.pm view on Meta::CPAN
splice (@{$self->[1]}, $pos, $len,
reverse( @{$self->[1]}[$pos..($pos+$len-1)] ));
$rt++;
}
return $rt;
}
##
# Changes token into one of same type (ie. passes type to generate..)
# 0: number to perform
# 1: position to affect (undef for rand)
sub mutate_minor {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $pos = defined $_[1] ? $_[1] : int rand length $self->[0];
next if $pos >= length($self->[0]); # pos lies outside of gene
my $type = substr($self->[0], $pos, 1);
my @token = $self->generate_token($type, $self->[1][$pos]);
AI/Gene/Sequence.pm view on Meta::CPAN
$self->[1][$pos] = $token[1];
}
$rt++;
}
return $rt;
}
##
# Changes one token into some other token
# 0: number to perform
# 1: position to affect (undef for random)
sub mutate_major {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $pos = defined $_[1] ? $_[1] : int rand length $self->[0];
next if $pos >= length($self->[0]); # outside of gene
my @token = $self->generate_token();
my $new = $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
$self->[1][$pos] = $token[1];
$rt++;
}
return $rt;
}
##
# swaps over two sequences within the gene
# any sort of oddness can occur if regions overlap
# 0: number to perform
# 1: start of first sequence (undef for rand)
# 2: start of second sequence (undef for rand)
# 3: length of first sequence (undef for 1, 0 for rand)
# 4: length of second sequence (undef for 1, 0 for rand)
sub mutate_switch {
my $self = shift;
my $num = $_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
my $pos1 = defined $_[1] ? $_[1] : int rand $length;
my $pos2 = defined $_[2] ? $_[2] : int rand $length;
my $len1 = !defined($_[3]) ? 1 : ($_[3] || int rand $length);
AI/Gene/Sequence.pm view on Meta::CPAN
splice @{$self->[1]}, $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 $length = length $self->[0];
my $pos1 = defined($_[1]) ? $_[1] : int rand $length;
my $pos2 = defined($_[2]) ? $_[2] : int rand $length;
AI/Gene/Sequence.pm view on Meta::CPAN
single tokens only), if a length of 0 is requested, then a random
length is chosen.
Also, if a mutation is suggested but would result in an invalid
sequence, then the mutation will not be carried out.
If a mutation is attempted which could corrupt your gene (copying
from a region beyond the end of the gene for instance) then it
will be silently skipped. Mutation methods all return the number
of mutations carried out (not the number of tokens affected).
These methods all expect to be passed positive integers, undef or zero,
other values could (and likely will) do something unpredictable.
=over 4
=item C<mutate([num, ref to hash of probs & methods])>
This will call at random one of the other mutation methods.
It will repeat itself I<num> times. If passed a reference
to a hash as its second argument, it will use that to
decide which mutation to attempt.
AI/Gene/Sequence.pm view on Meta::CPAN
modify it under the same terms as Perl itself.
=head1 BUGS
This is very slow if you do not need to check that your mutations
create valid genes, but fast if you do, thems the breaks. There
is a AI::Gene::Simple class instead if this bothers you.
Some methods will do odd things if you pass them weird values,
so try not to do that. So long as you stick to passing
positive integers or C<undef> to the methods then they should
recover gracefully.
While it is easy and fun to write genetic and evolutionary
algorithms in perl, for most purposes, it will be much slower
than if they were implemented in another more suitable language.
There are some problems which do lend themselves to an approach
in perl and these are the ones where the time between mutations
will be large, for instance, when composing music where the
selection process is driven by human whims.
AI/Gene/Simple.pm view on Meta::CPAN
else {
my $cum;
@{$h2}{ @{$muts} } = map {$cum +=$_; $cum / $sum} @{$hr}{ @{$muts} };
return ($h2, $muts);
}
}
##
# inserts one element into the sequence
# 0: number to perform ( or 1)
# 1: position to mutate (undef for random)
sub mutate_insert {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $glen = scalar @{$self->[0]};
my $pos = defined($_[1]) ? $_[1] : int rand $glen;
next if $pos > $glen; # further than 1 place after gene
my $token = $self->generate_token;
splice @{$self->[0]}, $pos, 0, $token;
$rt++;
}
return $rt;
}
##
# removes element(s) from sequence
# 0: number of times to perform
# 1: position to affect (undef for rand)
# 2: length to affect, undef => 1, 0 => random length
sub mutate_remove {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $glen = scalar @{$self->[0]};
my $length = !defined($_[2]) ? 1 : ($_[2] || int rand $glen);
return $rt if ($glen - $length) <= 0;
my $pos = defined($_[1]) ? $_[1] : int rand $glen;
next if $pos >= $glen; # outside of gene
splice @{$self->[0]}, $pos, $length;
$rt++;
}
return $rt;
}
##
# copies an element or run of elements into a random place in the gene
# 0: number to perform (or 1)
# 1: posn to copy from (undef for rand)
# 2: posn to splice in (undef for rand)
# 3: length (undef for 1, 0 for random)
sub mutate_duplicate {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $glen = scalar @{$self->[0]};
my $length = !defined($_[3]) ? 1 : ($_[3] || int rand $glen);
my $pos1 = defined($_[1]) ? $_[1] : int rand $glen;
my $pos2 = defined($_[2]) ? $_[2] : int rand $glen;
AI/Gene/Simple.pm view on Meta::CPAN
next if $pos2 > $glen;
splice @{$self->[0]}, $pos2, 0, @{$self->[0]}[$pos1..($pos1+$length-1)];
$rt++;
}
return $rt;
}
##
# Duplicates a sequence and writes it on top of some other position
# 0: num to perform (or 1)
# 1: pos to get from (undef for rand)
# 2: pos to start replacement (undef for rand)
# 3: length to operate on (undef => 1, 0 => rand)
sub mutate_overwrite {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $glen = scalar @{$self->[0]};
my $length = !defined($_[3]) ? 1 : ($_[3] || int rand $glen);
my $pos1 = defined($_[1]) ? $_[1] : int rand $glen;
AI/Gene/Simple.pm view on Meta::CPAN
@{$self->[0]}[$pos1..($pos1+$length-1)] );
$rt++;
}
return $rt;
}
##
# Takes a run of tokens and reverses their order, is a noop with 1 item
# 0: number to perform
# 1: posn to start from (undef for rand)
# 2: length (undef=>1, 0=>rand)
sub mutate_reverse {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = scalar @{$self->[0]};
my $pos = defined($_[1]) ? $_[1] : int rand $length;
my $len = !defined($_[2]) ? 1 : ($_[2] || int rand $length);
AI/Gene/Simple.pm view on Meta::CPAN
splice (@{$self->[0]}, $pos, $len,
reverse( @{$self->[0]}[$pos..($pos+$len-1)] ));
$rt++;
}
return $rt;
}
##
# Changes token into one of same type (ie. passes type to generate..)
# 0: number to perform
# 1: position to affect (undef for rand)
sub mutate_minor {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $glen = scalar @{$self->[0]};
my $pos = defined $_[1] ? $_[1] : int rand $glen;
next if $pos >= $glen; # pos lies outside of gene
my $type = $self->[0][$pos];
my $token = $self->generate_token($type);
$self->[0][$pos] = $token;
$rt++;
}
return $rt;
}
##
# Changes one token into some other token
# 0: number to perform
# 1: position to affect (undef for random)
sub mutate_major {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $glen = scalar @{$self->[0]};
my $pos = defined $_[1] ? $_[1] : int rand $glen;
next if $pos >= $glen ; # outside of gene
my $token = $self->generate_token();
$self->[0][$pos] = $token;
$rt++;
}
return $rt;
}
##
# swaps over two sequences within the gene
# any sort of oddness can occur if regions overlap
# 0: number to perform
# 1: start of first sequence (undef for rand)
# 2: start of second sequence (undef for rand)
# 3: length of first sequence (undef for 1, 0 for rand)
# 4: length of second sequence (undef for 1, 0 for rand)
sub mutate_switch {
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 length $glen;
next if $pos1 == $pos2;
AI/Gene/Simple.pm view on Meta::CPAN
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;
AI/Gene/Simple.pm view on Meta::CPAN
=head1 COPYRIGHT
Copyright (c) 2000 Alex Gough <F<alex@rcon.org>>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 BUGS
Some methods will do odd things if you pass them weird values,
so try not to do that. So long as you stick to passing
positive integers or C<undef> to the methods then they should
recover gracefully.
While it is easy and fun to write genetic and evolutionary
algorithms in perl, for most purposes, it will be much slower
than if they were implemented in another more suitable language.
There are some problems which do lend themselves to an approach
in perl and these are the ones where the time between mutations
will be large, for instance, when composing music where the
selection process is driven by human whims.
demo/Musicgene.pm view on Meta::CPAN
else { # use standard mutations and probs
foreach (1..$num_mutates) {
my $rand = rand;
if ($rand < $probs{insert}) {
$rt += $self->mutate_insert(1);
}
elsif ($rand < $probs{remove}) {
$rt += $self->mutate_remove(1);
}
elsif ($rand < $probs{duplicate}) {
$rt += $self->mutate_duplicate(1,undef, undef,0); # random length
}
elsif ($rand < $probs{minor}) {
$rt += $self->mutate_minor(1);
}
elsif ($rand < $probs{major}) {
$rt += $self->mutate_major(1);
}
elsif ($rand < $probs{overwrite}) {
$rt += $self->mutate_overwrite(1,undef,undef,0);
}
elsif ($rand < $probs{switch}) {
$rt += $self->mutate_switch(1,undef,undef,0,0);
}
elsif ($rand < $probs{shuffle} ) {
$rt += $self->mutate_shuffle(1,undef,undef,0);
}
}
}
return $rt;
}
1;
demo/Regexgene.pm view on Meta::CPAN
That said, if you want to use $self->[0] then you can, but it would
be unwise to modify it here.
=cut
sub valid_gene {
my $self = shift;
my $gene = $_[0];
if ($gene =~ /mm|am|aa|^a|^m|a$/) {
return undef;
}
else {
return 1;
}
}
=head2
Having created a way to create, modify and verify our genetically
encoded regular expressions, we could do with some way to actually
$rt = $gene->mutate_remove(1,7); # outside of gene
ok($rt,0);
ok($gene->g eq 'defghij');
$rt = $gene->mutate_remove(1,5,5); # extends beyond gene
ok($rt,1);
ok($gene->g eq 'defgh');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_remove(1,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_insert\n";
my $gene = $main->clone;
my $rt = $gene->mutate_insert(1,0);
ok($rt,1);
ok($gene->g eq 'Nabcdefghij' and $gene->d eq 'nabcdefghij');
ok($gene->d, 'abcdefghij');
$gene = $main->clone;
$rt = $gene->mutate_overwrite(1,11,4); # area to copy lies outside gene
ok($rt,0);
ok($gene->g, 'abcdefghij');
ok($gene->d, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_overwrite(1,undef,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_reverse\n";
my $gene = $main->clone;
my $rt = $gene->mutate_reverse(1,0,2);
ok($rt,1);
ok($gene->d, 'bacdefghij');
ok($gene->g, 'abcdefghij');
$gene = $main->clone;
$rt = $gene->mutate_reverse(1,10,1); # starts outside gene
ok($rt,0);
ok($gene->d, 'abcdefghij');
ok($gene->g, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_reverse(1,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_duplicate\n";
my $gene = $main->clone;
my $rt = $gene->mutate_duplicate(1,0,0);
ok($rt,1);
ok($gene->g, 'aabcdefghij');
ok($rt,1);
ok($gene->g, 'abcdefghija');
$gene = $main->clone;
$rt = $gene->mutate_duplicate(1,0,10,10); # double the gene
ok($rt,1);
ok($gene->g, 'abcdefghijabcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_duplicate(1,undef,undef,0)';
}
ok($rt,0);
}
{ print "# mutate_switch\n";
my $gene = $main->clone;
my $rt = $gene->mutate_switch(1,0,9); # first and last
ok($rt,1);
ok($gene->g, 'jbcdefghia');
$gene = $main->clone;
ok($rt,0);
ok($gene->g, 'abcdefghij');
$gene = $main->clone;
$rt = $gene->mutate_switch(1,0,2,5,3); # overlap of sections
ok($rt,0);
ok($gene->g, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_switch(1,undef,undef,0,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_shuffle\n";
my $gene = $main->clone;
my $rt = $gene->mutate_shuffle(1,5,0); # from after to
ok($rt,1);
ok($rt,1);
ok($gene->g, 'fghabcdeij');
$gene = $main->clone;
$rt = $gene->mutate_shuffle(1,8,5,5); # extends beyond gene
ok($rt,0);
ok($gene->g, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_shuffle(1,undef,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate\n";
my $rt = 0;
# hammer with defaults
for (1..$hammer) {
my $gene = $main->clone;
$rt = $gene->mutate_remove(1,7); # outside of gene
ok($rt,0);
ok($gene->d eq 'defghij');
$rt = $gene->mutate_remove(1,5,5); # extends beyond gene
ok($rt,1);
ok($gene->d eq 'defgh');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_remove(1,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_insert\n";
my $gene = $main->clone;
my $rt = $gene->mutate_insert(1,0);
ok($rt,1);
ok($gene->d eq 'Nabcdefghij');
ok($rt,0);
ok($gene->d, 'abcdefghij');
$gene = $main->clone;
$rt = $gene->mutate_overwrite(1,11,4); # area to copy lies outside gene
ok($rt,0);
ok($gene->d, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_overwrite(1,undef,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_reverse\n";
my $gene = $main->clone;
my $rt = $gene->mutate_reverse(1,0,2);
ok($rt,1);
ok($gene->d, 'bacdefghij');
ok($rt,0);
ok($gene->d, 'abcdefghij');
$gene = $main->clone;
$rt = $gene->mutate_reverse(1,10,1); # starts outside gene
ok($rt,0);
ok($gene->d, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_reverse(1,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_duplicate\n";
my $gene = $main->clone;
my $rt = $gene->mutate_duplicate(1,0,0);
ok($rt,1);
ok($gene->d, 'aabcdefghij');
ok($rt,1);
ok($gene->d, 'abcdefghija');
$gene = $main->clone;
$rt = $gene->mutate_duplicate(1,0,10,10); # double the gene
ok($rt,1);
ok($gene->d, 'abcdefghijabcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_duplicate(1,undef,undef,0)';
}
ok($rt,0);
}
{ print "# mutate_switch\n";
my $gene = $main->clone;
my $rt = $gene->mutate_switch(1,0,9); # first and last
ok($rt,1);
ok($gene->d, 'jbcdefghia');
$gene = $main->clone;
ok($rt,0);
ok($gene->d, 'abcdefghij');
$gene = $main->clone;
$rt = $gene->mutate_switch(1,0,2,5,3); # overlap of sections
ok($rt,0);
ok($gene->d, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_switch(1,undef,undef,0,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate_shuffle\n";
my $gene = $main->clone;
my $rt = $gene->mutate_shuffle(1,5,0); # from after to
ok($rt,1);
ok($rt,1);
ok($gene->d, 'fghabcdeij');
$gene = $main->clone;
$rt = $gene->mutate_shuffle(1,8,5,5); # extends beyond gene
ok($rt,0);
ok($gene->d, 'abcdefghij');
# hammer randomness
$rt = 0;
for (1..$hammer) {
$gene = $main->clone;
eval '$gene->mutate_shuffle(1,undef,undef,0)';
$rt = 1 if $@;
}
ok($rt,0);
}
{ print "# mutate\n";
my $rt = 0;
# hammer with defaults
for (1..$hammer) {
my $gene = $main->clone;
( run in 2.441 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )