use strict;
use warnings;
use List::Util qw(max min);
use Time::HiRes qw(time);

# this builds a structure that is usually retrieved from disk.
# in this example we will use this structure again and again,
# but in the real program we obviously retrieve a fresh structure
# at each iteration

my $simulation_h = {};
for ( 1 .. 70000 ) {
    my $random_start  = int( rand(5235641) );
    my $random_length = int( rand(40000) );
    push @{ $simulation_h->{$random_start} }, $random_length;
}

my $zone_o = {
    _chromosome_length => 5235641,
    _legal_range       => [ { FROM => 100000, TO => 200000 } ]
};

my $start_time = time;
scenario();
print "total loop time: " . ( time - $start_time ) . " seconds\n";

sub scenario {
    for ( my $i = 0 ; $i < 50 ; $i++ ) {
        print "i=$i time=" . ( time - $start_time ) . " seconds\n";

        # originally there was a retreive of $simulation_h from disk h
+ere

        # iterate genes
        foreach my $gene_from ( keys %{$simulation_h} ) {

            foreach my $gene_length ( @{ $simulation_h->{$gene_from} }
+ ) {

#                next;
                
                my $temp_gene_to_legal_range =
                  gene_to_legal_range( $gene_from, $gene_length,
                    $zone_o->{_chromosome_length} );

#                next;
                #
                is_contained(
                    $temp_gene_to_legal_range,
                    $zone_o->{_legal_range},
                    $zone_o->{_chromosome_length}
                );

            }
        }
    }
}

sub gene_to_legal_range($$$) {
#       return [];
    my ( $gene_from, $gene_length, $legal_length ) = @_;

    my $ret;
    my $gene_to = ( ( $gene_from + $gene_length - 1 ) % ($legal_length
+) ) + 1;

    if ( $gene_to < $gene_from ) {

        # split
        # low range first
        $ret = [
            { FROM => 0,          TO => $gene_to },
            { FROM => $gene_from, TO => $legal_length }
        ];
    }
    else {

        # single
        $ret = [ { FROM => $gene_from, TO => $gene_to } ];
    }

    return $ret;
}

sub is_contained ($$$) {
    my ( $some_legal_range, $gene_legal_range, $legal_length ) = @_;

    if ( legal_range_length($some_legal_range) == 0 ) {
        return 0;
    }
    my $intersection_legal_range =
      intersect_legal_ranges( $some_legal_range, $gene_legal_range,
        $legal_length );
    if ( legal_range_length($intersection_legal_range) ==
        legal_range_length($some_legal_range) )
    {
        return 1;
    }
    return 0;
}

sub legal_range_length($) {
    my ($legal_range_a) = @_;
    my $length = 0;
    foreach my $simple_range_h ( @{$legal_range_a} ) {
        $length += ( $simple_range_h->{TO} - $simple_range_h->{FROM} )
+;
    }
    return $length;
}

sub intersect_legal_ranges($$$) {
    my ( $legal_range_1, $legal_range_2, $legal_length ) = @_;

    my $intersections_a = [];
    for ( my $i = 0 ; $i < scalar( @{$legal_range_1} ) ; $i++ ) {
        for ( my $j = 0 ; $j < scalar( @{$legal_range_2} ) ; $j++ ) {
            my $intersect_h = intersect_simple_ranges( ${$legal_range_
+1}[$i],
                ${$legal_range_2}[$j] );
            push @{$intersections_a}, $intersect_h;
        }
    }
    $intersections_a = flatten_simple_ranges( $intersections_a, $legal
+_length );
}

#
sub intersect_simple_ranges($$) {
    my ( $simple_range_1, $simple_range_2 ) = @_;
    my $from = max( $simple_range_1->{FROM}, $simple_range_2->{FROM} )
+;
    my $to = min( $simple_range_1->{TO}, $simple_range_2->{TO} );
    if ( $from >= $to ) {

        # empty range
        return undef;
    }
    else {
        return { FROM => $from, TO => $to };
    }
}

# get an array of simple ranges representing a single legal range
# reurn a legal range (assuming each of the given ranges is simple and
+ legal)
sub flatten_simple_ranges($$) {
    my ( $simple_range_a, $legal_length ) = @_;

    my $legal_range = [];
    my $last_to     = undef;

    # filter out undef
    $simple_range_a = [ grep { $_ } @{$simple_range_a} ];

    # sort by from
    $simple_range_a = [ sort { $a->{FROM} <=> $b->{FROM} } @{$simple_r
+ange_a} ];

    for ( my $i = 0 ; $i < scalar( @{$simple_range_a} ) ; $i++ ) {
        my $from = ${$simple_range_a}[$i]->{FROM};
        my $to   = ${$simple_range_a}[$i]->{TO};

        # check if first range to process
        if ( !defined $last_to ) {
            push @{$legal_range}, { FROM => $from, TO => $to };
            $last_to = $to;
        }
        elsif ( $from <= $last_to && $to > $last_to ) {

            # range overlap and longer, extend range
            my $last_h = pop @{$legal_range};
            $last_h->{TO} = $to;
            push @{$legal_range}, $last_h;
            $last_to = $to;

        }
        elsif ( $from <= $last_to ) {

            # range overlap but contained, do nothing
        }

        else {

            # non overlap ($from > $last_to)
            # start new range
            push @{$legal_range}, { FROM => $from, TO => $to };
            $last_to = $to;
        }
    }

    return $legal_range;

}

[download]
all commented parts commented (i.e. full loop): total loop time: 63.6951129436493 seconds
with the second next uncommented: total loop time: 15.1547348499298 seconds with the second next uncommented and return []; in sub gene_to_legal_range also uncommented: total loop time: 6.83389496803284 seconds
with the first next uncommented: total loop time: 4.58600687980652 seconds

In reply to Re^2: Some code optimization by roibrodo
in thread Some code optimization by roibrodo

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.