AI-Gene-Sequence
view release on metacpan or search on metacpan
AI/Gene/Sequence.pm view on Meta::CPAN
my ($probs,$mut_keys) = _normalise( { map {$_ => 1}
qw(insert remove overwrite
duplicate minor major
switch shuffle reverse) } );
##
# calls mutation method at random
# 0: number of mutations to perform
# 1: ref to hash of probs to use (otherwise uses default mutations and probs)
sub mutate {
my $self = shift;
my $num_mutates = +$_[0] || 1;
my $rt = 0;
my ($hr_probs, $muts);
if (ref $_[1] eq 'HASH') { # use non standard mutations or probs
($hr_probs, $muts) = _normalise($_[1]);
}
else { # use standard mutations and probs
$hr_probs = $probs;
$muts = $mut_keys;
AI/Gene/Sequence.pm view on Meta::CPAN
next MUT_CYCLE;
}
}
return $rt;
}
##
# creates a normalised and cumulative prob distribution for the
# keys of the referenced hash
sub _normalise {
my $hr = $_[0];
my $h2 = {};
my $muts = [keys %{$hr}];
my $sum = 0;
foreach (values %{$hr}) {
$sum += $_;
}
if ($sum <= 0) {
die "Cannot randomly mutate with bad probability distribution";
}
AI/Gene/Sequence.pm view on Meta::CPAN
@{$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;
my $new = $self->[0];
substr($new, $pos, 0) = $token[0];
AI/Gene/Sequence.pm view on Meta::CPAN
}
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;
next if $pos >= $length; # outside of gene
my $new = $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
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;
my $new = $self->[0];
next if ($pos1 + $len) > $length;
AI/Gene/Sequence.pm view on Meta::CPAN
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);
my $pos1 = defined($_[1]) ? $_[1] : int rand $length;
my $pos2 = defined($_[2]) ? $_[2] : int rand $length;
AI/Gene/Sequence.pm view on Meta::CPAN
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;
my $len = !defined($_[2]) ? 1 : ($_[2] || int rand $length);
AI/Gene/Sequence.pm view on Meta::CPAN
$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]);
# still need to check for niceness, just in case
if ($token[0] eq $type) {
AI/Gene/Sequence.pm view on Meta::CPAN
$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];
substr($new, $pos, 1) = $token[0];
next unless $self->valid_gene($new, $pos);
AI/Gene/Sequence.pm view on Meta::CPAN
##
# 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);
my $len2 = !defined($_[4]) ? 1 : ($_[4] || int rand $length);
AI/Gene/Sequence.pm view on Meta::CPAN
}
##
# 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;
my $len = !defined($_[3]) ? 1 : ($_[3] || int rand $length);
AI/Gene/Sequence.pm view on Meta::CPAN
# 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) x2;
}
return ($token_type) x2;
}
# takes sting of token types to be checked for validity.
# If a mutation affects only one place, then the position of the
# mutation can be passed as a second argument.
sub valid_gene {1}
## 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 = ['',[]];
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 = [$self->[0]];
$new->[1] = [@{$self->[1]}];
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 .= $self->[0] . "\n";
$return .= (join ',', @{$self->[1]}). "\n";
return $return;
}
# used for testing
sub _test_dump {
my $self = shift;
my @rt = ($self->[0], join('',@{$self->[1]}));
return @rt;
}
1;
__END__;
=pod
AI/Gene/Sequence.pm view on Meta::CPAN
A base class for storing and mutating genetic sequences.
package Somegene;
use AI::Gene::Sequence;
our @ISA = qw(AI::Gene::Sequence);
my %things = ( a => [qw(a1 a2 a3 a4 a5)],
b => [qw(b1 b2 b3 b4 b5)],);
sub generate_token {
my $self = shift;
my ($type, $prev) = @_;
if ($type) {
$prev = ${ $things{$type} }[rand @{ $things{$type} }];
}
else {
$type = ('a','b')[rand 2];
$prev = ${$things{$type}}[rand @{$things{$type}}];
}
return ($type, $prev);
}
sub valid_gene {
my $self = shift;
return 0 if $_[0] =~ /(.)\1/;
return 1;
}
sub seed {
my $self = shift;
$self->[0] = 'ababab';
@{$self->[1]} = qw(A1 B1 A2 B2 A3 B3);
}
sub render {
my $self = shift;
return join(' ', @{$self->[1]});
}
# elsewhere
package main;
my $gene = Somegene->new;
$gene->seed;
print $gene->render, "\n";
AI/Gene/Simple.pm view on Meta::CPAN
my ($probs,$mut_keys) = _normalise( { map {$_ => 1}
qw(insert remove overwrite
duplicate minor major
switch shuffle reverse) } );
##
# calls mutation method at random
# 0: number of mutations to perform
# 1: ref to hash of probs to use (otherwise uses default mutations and probs)
sub mutate {
my $self = shift;
my $num_mutates = +$_[0] || 1;
my $rt = 0;
my ($hr_probs, $muts);
if (ref $_[1] eq 'HASH') { # use non standard mutations or probs
($hr_probs, $muts) = _normalise($_[1]);
}
else { # use standard mutations and probs
$hr_probs = $probs;
$muts = $mut_keys;
AI/Gene/Simple.pm view on Meta::CPAN
next MUT_CYCLE;
}
}
return $rt;
}
##
# creates a normalised and cumulative prob distribution for the
# keys of the referenced hash
sub _normalise {
my $hr = $_[0];
my $h2 = {};
my $muts = [keys %{$hr}];
my $sum = 0;
foreach (values %{$hr}) {
$sum += $_;
}
if ($sum <= 0) {
die "Cannot randomly mutate with bad probability distribution";
}
AI/Gene/Simple.pm view on Meta::CPAN
@{$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;
AI/Gene/Simple.pm view on Meta::CPAN
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;
next if ($pos1 + $length) > $glen;
next if $pos2 > $glen;
AI/Gene/Simple.pm view on Meta::CPAN
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;
my $pos2 = defined($_[2]) ? $_[2] : int rand $glen;
next if ( ($pos1 + $length) >= $glen
AI/Gene/Simple.pm view on Meta::CPAN
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);
next if ($pos >= $length
AI/Gene/Simple.pm view on Meta::CPAN
$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++;
AI/Gene/Simple.pm view on Meta::CPAN
##
# 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;
my $len1 = !defined($_[3]) ? 1 : ($_[3] || int rand $glen);
my $len2 = !defined($_[4]) ? 1 : ($_[4] || int rand $glen);
AI/Gene/Simple.pm view on Meta::CPAN
}
##
# 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);
AI/Gene/Simple.pm view on Meta::CPAN
# 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
AI/Gene/Simple.pm view on Meta::CPAN
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;
demo/Musicgene.pm view on Meta::CPAN
%EXPORT_TAGS = ();
@EXPORT_OK = qw();
}
our @EXPORT_OK;
our @chords = ([qw(A C G)], [qw(A C E)]); # type c
our @octaves = (3..10); # type o
our @notes = ('A'..'G', 'rest'); # type n
our @lengths = (qw(hn qn), ''); # type l
sub new {
my $class = shift;
my $self = ['',[]];
bless $self, ref($class) || $class;
$self->mutate_insert($_[0]) if $_[0];
return $self;
}
sub generate_token {
my $self = shift;
my ($type, $prev) = @_[0,1];
my @rt;
unless ($type) {
my $rand = rand;
if ($rand < .7) {$type = 'n'}
elsif ($rand < .8) {$type = 'l'}
elsif ($rand < .9) {$type = 'o'}
elsif ($rand < 1 ) {$type = 'c'}
else {die "$0: bad probability: $rand"}
demo/Musicgene.pm view on Meta::CPAN
SWITCH: for ($type) {
/n/ && do {$rt[1] = $notes[rand@notes]; last SWITCH};
/c/ && do {$rt[1] = $chords[rand@chords]; last SWITCH};
/l/ && do {$rt[1] = $lengths[rand@lengths]; last SWITCH};
/o/ && do {$rt[1] = $octaves[rand@octaves]; last SWITCH};
die "$0: unknown type: $type";
}
return @rt[0,1];
}
sub valid_gene {length($_[1]) < 50 ? 1 : 0};
sub write_file {
my $self = shift;
my $file_name = $_[0] or die "$0: No file passed to write_file";
my $opus = MIDI::Simple->new_score();
my $note_length = '';
foreach my $pos (0..(length $self->[0])) {
SWITCH: for (substr($self->[0], $pos, 1)) {
/l/ && do {$note_length = $self->[1][$pos] ;last SWITCH};
/n/ && do {$opus->n($note_length, $self->[1][$pos]) ;last SWITCH};
/o/ && do {$opus->noop('o'.$self->[1][$pos]) ;last SWITCH};
/c/ && do {$opus->n($note_length, @{$self->[1][$pos]}) ;last SWITCH};
demo/Musicgene.pm view on Meta::CPAN
remove =>.2,
duplicate =>.4,
minor =>.5,
major =>.6,
overwrite =>.7,
reverse =>.75,
switch =>.8,
shuffle =>1,
);
sub mutate {
my $self = shift;
my $num_mutates = +$_[0] || 1;
my $rt = 0;
my ($hr_probs, $muts);
if (ref $_[1] eq 'HASH') { # use non standard mutations or probs
$hr_probs = $self->_normalise($_[1]);
$muts = [keys %{$hr_probs}];
MUT_CYCLE: for (1..$num_mutates) {
my $rand = rand;
foreach my $mutation (@{$muts}) {
demo/Regexgene.pm view on Meta::CPAN
If called as an object method (C<$obj->new>), this decreases the depth
count by one from the invoking object. It also adds tokens to the regular
expression and uses the B<valid_gene> method to ensure we stay sane
from the start.
As can be seen, we use array offsets above $self->[1] to store information
which is specific to our implementation.
=cut
sub new {
my $gene = ['',[], ref($_[0]) ? $_[0]->[2]-1 : 3 ]; # limit recursion
bless $gene, ref($_[0]) || $_[0];
my $length = $_[1] || 5;
for (1..$length) {
my @token = $gene->generate_token();
my $new = $gene->[0] . $token[0];
redo unless $gene->valid_gene($new); # hmmmm, enter turing from the wings
$gene->[0] = $new;
push @{$gene->[1]}, $token[1];
}
demo/Regexgene.pm view on Meta::CPAN
}
=head2 clone
As we are going to allow nested sequences, then we need to make sure that
when we copy an object we create new versions of everthing, rather than
reusing pointers to data used by other objects.
=cut
sub clone {
my $self = shift;
my $new = bless [$self->[0], [], $self->[2]], ref($self);
@{$new->[1]} = map {ref($_) ? $_->clone : $_} @{$self->[1]}; # woohoo, recursive objects
return $new;
}
=head2 generate_token
This is where we really start needing to have our own implementation.
This method is used by AI::Gene::Sequence when it needs a new
demo/Regexgene.pm view on Meta::CPAN
did not have to.
If we are provided with a token type, we use that, otherwise we chose
one at random. We make sure that we return a two element list.
If we had wanted, when passed a type of 'g' along with a second
argument, we could have caused this method to mutate the nested
regex, instead, we just create a different one.
=cut
sub generate_token {
my $self = shift;
my $type = $_[0] || (qw(m t c r a g))[rand 6];
my @rt;
$rt[0] = $type;
SWITCH: for ($type) {
/^m/ && do {$rt[1] = $modifiers[rand@modifiers] ;last SWITCH}; # modifier
/^t/ && do {$rt[1] = $char_types[rand@char_types];last SWITCH}; # type
/^c/ && do {$rt[1] = $chars[rand@chars] ;last SWITCH}; # lone char
/^r/ && do {$rt[1] = $ranges[rand@ranges] ;last SWITCH}; # range
/^a/ && do {$rt[1] = '|' ;last SWITCH}; # altern
demo/Regexgene.pm view on Meta::CPAN
Note that we do not use the current version of the gene in $self->[0].
This is because it is the un-mutated version, if we do not accept the
mutation then $self will be left alone by our calling methods.
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
use them. This method retuns a non compiled regular expression and
calls itself recursively when it finds nested genes.
=cut
sub regex {
my $self = shift;
my $rt;
warn "$0: empty gene turned into empty regex" unless scalar @{$self->[1]};
foreach (@{$self->[1]}) {
$rt .= ref($_) ? '(?:'. $_->regex .')' : $_;
}
return $rt;
}
=head1 AUTHOR
demo/spamscan.pl view on Meta::CPAN
$score += grep {$_ =~ $rex} @spam; # we don't want spam
$score -= grep {$_ =~ $rex} @wanted; # but we do want our mail
if ($score > $best_yet) {
$regex = $child; # and so progress is made
$best_yet = $score;
print "\n* $best_yet ", $regex->regex, "\n";
}
print '.' unless ($temp++ % 80);
}
sub seed_match {
my $regex;
TWIDDLE: while (1) {
$regex = Regexgene->new(5);
my $rg = $regex->regex;
last TWIDDLE if $spam[rand@spam] =~ $rg;
}
return $regex;
}
# Stuff from my mailbox (Don't ask) and my spam trap
# Also is a new method, which creates the gene and seeds it and
# 'd' and 'g' methods, which return (stringified) versions of the
# sequence ($self->[0]) and gene (@{$self->[1]}) respectively.
package GTest;
our (@ISA);
use AI::Gene::Sequence;
@ISA = qw(AI::Gene::Sequence);
sub new {
my $class = shift;
my $self = ['',[]];
bless $self, $class;
$self->seed_gene;
return $self;
}
sub seed_gene {
my $self = shift;
$self->[0] = join('', 'a'..'j');
@{$self->[1]} = ('a'..'j');
return 1;
}
sub generate_token {
my $self = shift;
my ($type, $prev) = @_;
$type ||= 'n';
$prev = uc $type;
return ($type, $prev);
}
sub d {
my $self = shift;
return $self->[0];
}
sub g {
my $self = shift;
return join('', @{$self->[1]});
}
package main;
use Test;
# see above for a small package ( GTest ) used to test G::G::S
BEGIN {plan tests => 111, todo =>[]}
my $hammer = 30; # set big to bash at methods with randomness
# ready for a test.
# Also is a new method, which creates the gene and seeds it and
# a 'd' method, which returns a stringified version of $self->[0]
package GTestS;
our (@ISA);
use AI::Gene::Simple;
@ISA = qw(AI::Gene::Simple);
sub new {
my $class = shift;
my $self = [[]];
bless $self, $class;
$self->seed_gene;
return $self;
}
sub seed_gene {
my $self = shift;
@{$self->[0]} = ('a'..'j');
return 1;
}
sub generate_token {
my $self = shift;
my ($prev) = @_;
if ($prev) {
$prev = uc $prev;
}
else {
$prev = 'N';
}
return $prev;
}
sub d {
my $self = shift;
return join('',@{$self->[0]});
}
package main;
use Test;
# see above for a small package ( GTest ) used to test G::G::S
BEGIN {plan tests => 101, todo =>[]}
my $hammer = 30; # set big to bash at methods with randomness
( run in 0.281 second using v1.01-cache-2.11-cpan-4d50c553e7e )