Christian888 has asked for the wisdom of the Perl Monks concerning the following question:

I'm new to perl and to try it out a bit more seriously I took on an AI genetic algorythm problem (details of the problem here: http://www.ai-junkie.com/ga/intro/gat1.html). I coded the same problem in java some time ago, and was initially supprised that java was faster then perl, but thanks to help I got here I eventually developed a rasonably fast Perl script (attached here, but see also http://www.perlmonks.org/?node_id=876119). I developed it as a purely procedural solution. The next thing for me, of course, was to try out OO Perl. I rewrote the code, this time using objects, expecting it to work measurabely slower. To my great suprise the OO version seems to work faster despite having more lines of code and additional complexity. Can anyone explain why? Also it seems that the OO version accellerates, which I found even more bizzare. If you run the code attached here it becomes obvious what I mean by accellerates. Thanks again, Christian

Sorry for lengthy listings...

***********************

Here is the Procedural Perl version

use strict;
use warnings;
use List::Util qw[ sum ];
use Time::HiRes qw[ time ];

srand(100);

my $total_time = time();
my $target          = 379;
my $population_size = 100;
my $chromosome_size = 100;
my $mutation_rate   = 0.1;
my $crossover_rate  = 0.7;
my @population      = ();
my @phenotypes      = ();
my @results         = ();
my %genome          = (
    '0001' => '1',
    '0010' => '2',
    '0011' => '3',
    '0100' => '4',
    '0101' => '5',
    '0110' => '6',
    '0111' => '7',
    '1000' => '8',
    '1001' => '9',
    '1010' => '+',
    '1011' => '-',
    '1100' => '*',
    '1101' => '/'
);


my $gene_length = get_gene_length( \%genome );
my $duration;
my $generation_counter = 1;
my $winner;

do {
    my $generation_time = time();
    @population = @{ regenrate_population( \@population ) };
    $winner     = check_for_winner( \@population );
    printf( "Generation $generation_counter took %.3f seconds to compl
+ete\n",
        time() - $generation_time );
    $generation_counter++;
} until ($winner);

print("Solution reached in generation: $generation_counter \n");
print("The chromosome: @{$winner->{chromosome}} \n");
print( $winner->{phenotype} . " = " . $winner->{result} . " \n" );
printf( "Total time to reach solution %.3f seconds \n",        time() 
+- $total_time );

sub regenrate_population {
    my $old_population = shift(@_);
    my $new_population = [];
    if ( $old_population->[0] ) {
        my $population_fitness_score=get_population_fitness_score($old
+_population);
        for my $individual ( 0 .. ($population_size) ) {
            my $chromosome1 = get_nonrandom_chromosome($old_population
+,$population_fitness_score);
            my $chromosome2 = get_nonrandom_chromosome($old_population
+,$population_fitness_score);
            $new_population->[$individual]->{chromosome} =
              get_child( $chromosome1, $chromosome2 );
            $new_population->[$individual]->{phenotype} =
              get_phenotype( $new_population->[$individual]->{chromoso
+me} );
            $new_population->[$individual]->{result} =
              get_result( $new_population->[$individual]->{phenotype} 
+);
            $new_population->[$individual]->{fitness_score} =
              get_fitness_score( $new_population->[$individual]->{resu
+lt} );
        }
    }
    else {
        for my $individual ( 0 .. $population_size ) {
            for my $nucleotide ( 0 .. $chromosome_size ) {
                $new_population->[$individual]->{chromosome}->[$nucleo
+tide] =
                  int( rand(1) + 0.5 );
            }
            $new_population->[$individual]->{phenotype} =
              get_phenotype( $new_population->[$individual]->{chromoso
+me} );
            $new_population->[$individual]->{result} =
              get_result( $new_population->[$individual]->{phenotype} 
+);
            $new_population->[$individual]->{fitness_score} =
              get_fitness_score( $new_population->[$individual]->{resu
+lt} );

        }

    }
    return ($new_population);
}

sub check_for_winner {
    my $winner;
    my $population = shift(@_);
    foreach my $individual (@$population) {
        if ( $individual->{result} == $target ) {
            $winner = $individual;
            last;
        }
    }
    return ($winner);
}

sub get_nonrandom_chromosome {
    my $population=shift(@_);
    my $population_fitness_score = shift(@_);
    my $rulet_position           = rand($population_fitness_score);
    my $temp_score               = 0;
    my $nonrandom_chromosome;
    foreach my $individual (@$population) {
        $temp_score += $individual->{fitness_score};
        if ( $temp_score > $rulet_position ) {
            $nonrandom_chromosome = $individual->{chromosome};
            last;
        }
    }
    return ($nonrandom_chromosome);
}

sub get_child {
    my $chromosome1 = shift(@_);
    my $chromosome2 = shift(@_);
    my $new_chromosome;
    if ( rand(1) < $crossover_rate ) {
        my $crossover_point = int( rand($chromosome_size) );
        $new_chromosome = [
            @$chromosome1[ 0 .. $crossover_point ],
            @$chromosome2[ ( $crossover_point + 1 ) .. ($chromosome_si
+ze) ]
        ];
    }
    else {
        if ( rand(1) > 0.5 ) {
            $new_chromosome = $chromosome1;
        }
        else {
            $new_chromosome = $chromosome2;
        }
    }
    if ( rand(1) < $mutation_rate ) {
        my $nucleotide_pos = int( rand($chromosome_size) );
        if ( $$new_chromosome[$nucleotide_pos] ) {
            $$new_chromosome[$nucleotide_pos] = 0;
        }
        else {
            $$new_chromosome[$nucleotide_pos] = 1;
        }
    }
    return ($new_chromosome);
}

sub get_population_fitness_score {
    my $population               = shift(@_);
    my $population_fitness_score =
      sum( map { $_->{fitness_score} } (@$population) );
    return ($population_fitness_score);
}

sub get_result {
    my $phenotype = shift(@_);
    my $result    =  eval($phenotype) ;
    return ($result);
}

sub get_fitness_score {

    my $result        = shift(@_);
    my $fitness_score =
      ( $target / ( $target + abs( $target - $result ) ) ) * 3;
    return ($fitness_score);
}

sub get_phenotype {
    my $chromosome          = shift(@_);
    my @phenotype           = ();
    my @expressed_phenotype = ();
    my @nucleotides         = @$chromosome;
    my @gene                = ();
    my $pattern             = q(\d);

    foreach my $nucleotide (@nucleotides) {

        if ( scalar(@gene) >= $gene_length ) {
            my $gene = join( "", @gene );
            @gene = ($nucleotide);
            if ( defined( $genome{$gene} ) ) {
                push( @phenotype, $genome{$gene} );
            }
        }
        else {
            push( @gene, $nucleotide );
        }

    }

    foreach my $item (@phenotype) {
        if ( $item =~ m/$pattern/ ) {
            push( @expressed_phenotype, $item );
            if ( $pattern eq q(\d) ) {
                $pattern = q(\D);
            }
            else {
                $pattern = q(\d);
            }
        }
    }

    if ( $expressed_phenotype[$#expressed_phenotype] =~ m/\D/ ) {
        pop(@expressed_phenotype);
    }
    return ( join( "", @expressed_phenotype ) );
}

sub get_gene_length {
    my $genome = shift(@_);
    my @gls    = ();
    foreach my $key ( keys(%$genome) ) {
        push( @gls, length($key) );
    }
    @gls = sort(@gls);
    if ( $gls[0] != $gls[$#gls] ) {
        die("Invalid genotype");
    }
    return ( $gls[0] );
}

[download]

****************************************

Here is the OO version - all classess are in the same file

use strict;
use warnings;
use Time::HiRes qw[ time ];

srand(308);

my $total_time      = time();
my $target          = 392;
my $population_size = 100;
my $chromosome_size = 100;
my $mutation_rate   = 0.1;
my $crossover_rate  = 0.7;

my $genome     = Genome->new();
my $population = Population->new( $population_size, $chromosome_size )
+;
my $winner     = $population->check_for_winner();

my $duration;
my $generation_counter = 1;

until ($winner) {
    my $generation_time = time();
    $winner =      $population->regenerate( $crossover_rate, $mutation
+_rate, $genome, $target );
    printf( "Generation $generation_counter took %.3f seconds to compl
+ete\n",time() - $generation_time );
    $generation_counter++;
}

print("Solution reached in generation: $generation_counter \n");
print("The chromosome: @{$winner->{nucleotides}} \n");
print( $winner->{phenotype} . " = " . $winner->{result} . " \n" );
printf( "Total time to reach solution %.3f seconds \n", time() - $tota
+l_time );

######################################################################
+#####################################################
package Population;
use List::Util qw[ sum ];

sub new {
    die unless ( scalar(@_) == 3 );
    my ( $class, $population_size, $chromosome_size ) = @_;
    my $self = {
        chromosomes => [map { Chromosome->new($chromosome_size) } ( 1 
+.. $population_size )    ]
    };
    $self->{fitness_score} = get_population_fitness_score($self);
    bless( $self, $class );
    return ($self);

}

sub regenerate {
    die unless ( scalar(@_) == 5 );
    my ( $population, $crossover_rate, $mutation_rate, $genome, $targe
+t ) = @_;
    my ($population_size) = scalar( @{ $population->{chromosomes} } );
    my ( @new_chromosomes, $fitness_score );
    my ($new_chromosome_count) = 1;
    while ( $new_chromosome_count < $population_size ) {
        my ($chromosome1)    = get_nonrandom_chromosome($population);
        my ($chromosome2)    = get_nonrandom_chromosome($population);
        my ($new_chromosome) =
          Chromosome->new_from( $chromosome1, $chromosome2, $crossover
+_rate,
            $mutation_rate, $genome, $target );
        push( @new_chromosomes, $new_chromosome );
        $new_chromosome_count++;

        #print("$new_chromosome_count ");
    }
    @{ $population->{chromosomes} } = @new_chromosomes;
    $population->{fitness_score} = get_population_fitness_score($popul
+ation);
    return ( check_for_winner($population) );
}

sub get_nonrandom_chromosome {
    my $population     = shift(@_);
    my $rulet_position = rand( $population->{fitness_score} );
    my $temp_score     = 0;
    my $nonrandom_chromosome;
    foreach my $individual ( @{ $population->{chromosomes} } ) {
        $temp_score += $individual->{fitness_score};
        if ( $temp_score > $rulet_position ) {
            $nonrandom_chromosome = $individual;
            last;
        }
    }
    return ($nonrandom_chromosome);
}

sub check_for_winner {
    die unless ( scalar(@_) == 1 );
    my $population = shift(@_);
    my $winner;

    foreach my $individual ( @{ $population->{chromosomes} } ) {
        if ( $individual->{result} == $target ) {
            $winner = $individual;
            last;
        }
    }
    return ($winner);
}

sub get_population_fitness_score {
    my $population               = shift(@_);
    my $population_fitness_score =
      sum( map { $_->{fitness_score} } @{ $population->{chromosomes} }
+ );
    return ($population_fitness_score);
}

######################################################################
+#####################################################
package Chromosome;

sub new {
    die unless ( scalar(@_) == 2 );
    my ( $class, $chromosome_size ) = @_;

    my $self = {
        nucleotides   => [],
        phenotype     => undef,
        result        => undef,
        fitness_score => undef
    };

    $chromosome_size = 100 unless ($chromosome_size);
    for my $nucleotide ( 0 .. ( $chromosome_size - 1 ) ) {
        $self->{nucleotides}->[$nucleotide] = int( rand(1) + 0.5 );
    }

    $self->{phenotype}     = get_phenotype( $self, $genome );
    $self->{result}        = get_result($self);
    $self->{fitness_score} = get_fitness_score( $self, $target );

    bless( $self, $class );
    return ($self);

}

sub new_from {
    die unless ( scalar(@_) == 7 );
    my ( $class, $chromosome1, $chromosome2, $crossover_rate, $mutatio
+n_rate,
        $genome, $target )
      = @_;
    my ($self) = {
        nucleotides => [],
        phenotype   => undef,
        result      => undef
    };

    my ($chromosome_size) = scalar( @{ $chromosome1->{nucleotides} } )
+;

    die
      unless ( $chromosome_size == scalar( @{ $chromosome2->{nucleotid
+es} } ) );

    my @new_nucleotides;
    if ( rand(1) < $crossover_rate ) {
        my $crossover_point = int( rand($chromosome_size) );
        @new_nucleotides = (
            @{$chromosome1->{nucleotides}}[ 0 .. $crossover_point ],
            @{$chromosome2->{nucleotides}}[ ( $crossover_point + 1 ) .
+. ($chromosome_size-1) ]
        );
    }
    else {
        if ( rand(1) > 0.5 ) {
            @new_nucleotides = @{ $chromosome1->{nucleotides} };
        }
        else {
            @new_nucleotides = @{ $chromosome2->{nucleotides} };
        }
    }
    if ( rand(1) < $mutation_rate ) {
        my $nucleotide_pos = int( rand($chromosome_size) );
        if ( $new_nucleotides[$nucleotide_pos] ) {
            $new_nucleotides[$nucleotide_pos] = 0;
        }
        else {
            $new_nucleotides[$nucleotide_pos] = 1;
        }
    }

    $self->{nucleotides}   = \@new_nucleotides;
    $self->{phenotype}     = get_phenotype( $self, $genome );
    $self->{result}        = get_result($self);
    $self->{fitness_score} = get_fitness_score( $self, $target );

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

sub get_phenotype {
    die unless ( scalar(@_) == 2 );
    my ( $chromosome, $genome ) = @_;
    my @phenotype           = ();
    my @expressed_phenotype = ();
    my @nucleotides         = @{ $chromosome->{nucleotides} };
    my @gene                = ();
    my $pattern             = q(\d);

    foreach my $nucleotide (@nucleotides) {

        if ( scalar(@gene) >= $genome->{gene_length} ) {
            my $gene = join( "", @gene );
            @gene = ($nucleotide);
            if ( $genome->{gene_codes}->{$gene} ) {
                push( @phenotype, $genome->{gene_codes}->{$gene} );
            }
        }
        else {
            push( @gene, $nucleotide );
        }

    }

    foreach my $item (@phenotype) {
        if ( $item =~ m/$pattern/ ) {
            push( @expressed_phenotype, $item );
            if ( $pattern eq q(\d) ) {
                $pattern = q(\D);
            }
            else {
                $pattern = q(\d);
            }
        }
    }

    if ( $expressed_phenotype[$#expressed_phenotype] =~ m/\D/ ) {
        pop(@expressed_phenotype);
    }
    return ( join( "", @expressed_phenotype ) );
}

sub get_result {
    die unless ( scalar(@_) == 1 );
    my ($chromosome) = @_;
    my $result = eval( $chromosome->{phenotype} );
    return ($result);
}

sub get_fitness_score {
    die unless ( scalar(@_) == 2 );
    my ( $chromosome, $target ) = @_;
    my $result        = $chromosome->{result};
    my $fitness_score =
      ( $target / ( $target + abs( $target - $result ) ) ) * 3;
    return ($fitness_score);
}

######################################################################
+#####################################################
package Genome;

sub new {
    my $self = {
        gene_codes  => {},
        gene_length => undef
    };
    my $class      = shift(@_);
    my $gene_codes = shift(@_);

    if ($gene_codes) {
        $self->{gene_codes} = $gene_codes;
        gene_length($self);
    }
    else {
        $self->{gene_codes} = {
            '0001' => '1',
            '0010' => '2',
            '0011' => '3',
            '0100' => '4',
            '0101' => '5',
            '0110' => '6',
            '0111' => '7',
            '1000' => '8',
            '1001' => '9',
            '1010' => '+',
            '1011' => '-',
            '1100' => '*',
            '1101' => '/'
        };
        $self->{gene_length} = 4;

    }

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

sub gene_length {
    my $self = shift(@_);
    die "Invalid Genome"
      unless ($self);
    if ( $self->{gene_length} ) {
        return ( $self->{gene_length} );
    }
    else {
        my @gls =
          sort( map { length($_) } ( keys( %{ $self->{gene_codes} } ) 
+) );
        die("Invalid Genome") unless ( $gls[0] == $gls[$#gls] );
        $self->{gene_length} = $gls[0];
        return ( $gls[0] );
    }
}

[download]

Replies are listed 'Best First'.
Re: Procedural Perl slower than OO Perl!!!
by ELISHEVA (Prior) on Dec 18, 2010 at 18:28 UTC

    For one, you are doing a lot less dereferencing. To set the properties on each chromosome in the non-OOP version you do a double dereference: $new_population->[$individual]->{propname}. There are four properties (chromosome, result, phenotype, fitness_score). This amounts to 4 * the number of chromosomes dereferences, or for a sample with 100 chromosomes, 400 double dereferences per regeneration. In the OOP version you build the chromosome and then push it on the array, resulting in a single dereference, i.e. 400 single dereferences. Although dereferences are cheap if you are doing millions of them as a result of several thousand regenerations, they do add up.

[reply]
[d/l]
Re: Procedural Perl slower than OO Perl!!! (Not!)
by BrowserUk (Patriarch) on Dec 18, 2010 at 20:31 UTC
    To my great suprise the OO version seems to work faster despite having more lines of code and additional complexity. Can anyone explain why?

    Given that the procedural code you've posted here is still an order of magnitude slower than this version, the difference in performance between the two versions you've posted comes down to differences in the algorithms, and the implementations of those algorithms, not to the relative performance of perl's function and method calls.

    The two posted versions do not even produce the same solution, so you are comparing apples with oranges and claiming the lemon juice produced tastes sweeter.

    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
      the difference in performance between the two versions you've posted comes down to differences in the algorithms

      Exactly. And really if he wants slow OO, he should use Moose.

      p.s. - This is my Christmas present to you BrowserUK ;)

      -stvn
[reply]

        Touché!

        (S'il veut vraiment, vraiment lent, il peut passer de son algorithme génétique à la force brutale de procédure. :)

        Merry Christmas stvn.

        Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
        "Science is about questioning the status quo. Questioning authority".
        In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
Re: Procedural Perl slower than OO Perl!!!
by Marshall (Canon) on Dec 18, 2010 at 22:33 UTC
    I also ran both versions as posted. Using: prompt>perl -d:Profile gene.pl. The profiler is a handy tool for performance analysis. Default output goes to a file, prof.out.

    The OO version did 22,144 function calls vs 30,339 for the procedural version. I could not get the code to produce the same results, even with fiddling with the starting params (srand seed, $target, etc). So there is no basis for doing an "apples to apples" comparison.

    I did not notice any "accelerate" behavior. The time for each iteration varies because of the random variables. Some iterations are faster than others, but otherwise I saw no pattern to the results. Note that the "clock time" can vary considerably depending upon whatever else besides your program is executing on the machine.

    Oh, to "hide" the code to make the post shorter, use <readmore></readmore> tags like I did below.

    click on next link for abbreviated prof.out results...

    Read more... (2 kB)
[reply]
[d/l]
[select]
Re: Procedural Perl slower than OO Perl!!!
by Anonymous Monk on Dec 18, 2010 at 17:39 UTC
    Maybe you're (unintentionally, but performantly) copying and moving around less data, because the reference you're using as an object has a built-in heap.
[reply]
Re: Procedural Perl slower than OO Perl!!!
by locked_user sundialsvc4 (Abbot) on Dec 20, 2010 at 01:29 UTC

    For whatever it may be worth, I still have a (prized...) copy of the First Edition (the FORTRAN edition) of Kernighan & Plauger’s The Elements of Programming Style, in which the following sage maxim first appeared:   Don’t “diddle” code to make it faster: find a better algorithm.

    And so, I very-earnestly offer the following opinion:   “if whatever-you-are-doing seems to be ‘human-visibly slow,’ find a better algorithm.”

    In other words, don’t be concerned about what language it is.   (Believe it or not, it is in fact a perfectly safe assumption that all language implementors do know what they are doing.)   If you find yourself saying ... “language-X is slower than language-Y”, it probably actually has nothing to do with either of the two languages, and everything to do with your choice of algorithm.

    I mean...   let’s face it ... when whatever-we-are-doing finally makes its way down to the hardware level (as, in fact, everything-we-are-doing eventually does do...), everything happens as “bezillions of operations-per-second.”   Therefore, if somehow we still see “a human-noticeable difference in speed,” it very-simply is not realistic to attribute this difference to some discrepancy in technical language-compiler implementations . . .

Re: Procedural Perl slower than OO Perl!!!
by Anonymous Monk on Dec 19, 2010 at 04:40 UTC
    Want speed? Code in assembly.
[reply]

Back to Seekers of Perl Wisdom