I think that you are checking twice as many edges as you need to.

In your reversed edge test you are checking for {$p2}{$p1} 

      unless ( ($p1 == $p2) || $found->{$p2}->{$p1} ) {

[download]

But you are also setting the found edges with the pairings reversed. 

        $found->{$p2}->{$p1} = 1;

[download]

Which means that you are never detecting a reversed pair. Changing the setting code to 

        $found->{$p1}->{$p2} = 1;

[download]

means that when that pair comes up reversed, your test (as is) will detect them.

That step alone cuts the number of edges in half (as you intended).

You can save a little more there by using a hash instead of a hash ref, and concatenating the pairs so you use a single level hash, rather than a hash of zillions of little hashes. Ie. 

      my %found; ## instead of my $found = {};
...
      unless ( ($p1 == $p2) || $found{ "$p2|$p1" } ) {
...
        $found->{ "$p1|$p2" } = 1;

[download]

Less indirection and less for the garbage collector to do.

Similar saving can be gained by using arrays rather than array references elsewhere, particularly in the building and passing and unwrapping of the paramaters to the SegmentIntersection() sub. You use many levels of indirection build an array ref to an array of arrays, then pass the array ref in to the sub where you have then to unwrap all the nesting and copy them to local vars. Removing several layers of indirection gained several percent performance--and made the code clearer.

Finally, little more can be gained by avoiding copying the parameters in the Determinant() sub. Also using integer math there, assuming that all your coordinates are less than 65536, this may gain a little.

<I am getting different results, but I beleive this is because you were producing reversed duplicates.

Assuming you agree that these results are correct, then the the following code runs in around 1/5th the time of your original. 

#!/usr/bin/perl
use YAML qw(Load);
use Data::Dumper;
use Carp;
use Benchmark;
use strict;

my $precision = 7;
my $delta = 10 ** (-$precision);

my $points; # hash ref holding the raw data {'1' => [X,Y], '2' => [X,Y
+], ...}

{
  local $/;
  open(my $fh, "dump_301.dat") or die "Unable to open file: $!\n";
  $points = Load( <$fh> );
  croak($@) if $@;
  close($fh);
}

my $start_pairs = Benchmark->new;
my $edges = find_unique_edges($points);
print "Unique edges ", scalar(@{$edges}), "\n";
print "Pairs parsed in :", timestr(timediff(Benchmark->new, $start_pai
+rs)), "\n";

my $start_intersects = Benchmark->new;
my $neighborEdges = find_unintersected_edges($edges);
print "Unintersected edges ", scalar(keys %{$neighborEdges}), "\n";
print "Intersects parsed in :", timestr(timediff(Benchmark->new, $star
+t_intersects)), "\n";

sub find_unique_edges {
    my $MAP = shift;
    my @edges; # returnable data structure
    my $start_distance = Benchmark->new;
    my %found;

    # p1 is starting or anchor point of the line segment
    foreach my $p1 ( @{ $points } ) {
        # p2 is end point of the line segment
        foreach my $p2 ( @{ $points } ) {

            # We don't need to caculate if anchor and end are the same
            # or we have already seen these two pairs [reversed] befor
+e
            unless( $p1 == $p2 or $found{ "$p2|$p1" } ) {

                my $edge = sqrt(
                    ( $p1->[0] - $p2->[0] ) **2 +
                    ( $p1->[1] - $p2->[1] ) **2
                );
                push @edges, [ $edge, $p1->[0], $p1->[1], $p2->[0], $p
+2->[1] ];
                $found{ "$p1|$p2" } = 1;
            }
        }
    }
    return \@edges;
}

sub find_unintersected_edges {
    my $PAIRS = shift;
    my $neighborEdges; # returnable data structure
    my $neighboorCNT = 1;
    foreach my $aref ( sort {$a->[0] <=> $b->[0] } @{$PAIRS}) {

        my $neighbor = 1;
        my @line_1_ref;
        push @line_1_ref, [ $aref->[ 1 ],$aref->[ 2 ] ]; # line 1 poin
+t A X,Y
        push @line_1_ref, [ $aref->[ 3 ],$aref->[ 4 ] ]; # line 1 poin
+t B X,Y

        for( my $n=1; $n <= $neighboorCNT; $n++ ) {
            if( $neighborEdges->{ $n } ) {
                my @points;
                push @points, @line_1_ref; # line 1 points
                push @points, [ $neighborEdges->{ $n }[ 1 ], $neighbor
+Edges->{ $n }[ 2 ] ]; # line 2 point A X,Y
                push @points, [ $neighborEdges->{ $n }[ 3 ], $neighbor
+Edges->{ $n }[ 4 ] ]; # line 2 point B X,Y
                # If a intersect is found, set false and quit checking
                if( SegmentIntersection( @points ) ) {
                    $neighbor = 0;
                    last;
                }
            }
        }
        if( $neighbor ) {
            $neighborEdges->{ $neighboorCNT } = $aref;
            $neighboorCNT++;
        }
    }
    return $neighborEdges ;
}

sub SegmentIntersection {
    my @p1 = @{ $_[0] }; # p1,p2 = segment 1
    my @p2 = @{ $_[1] };
    my @p3 = @{ $_[2] }; # p3,p4 = segment 2
    my @p4 = @{ $_[3] };

    my $d  = Determinant( $p2[0] - $p1[0], $p3[0] - $p4[0], $p2[1] - $
+p1[1], $p3[1] - $p4[1] );
    if( abs( $d ) < $delta ) {
        return 0; # parallel
    }
    my $n1 = Determinant( $p3[0] - $p1[0], $p3[0] - $p4[0], $p3[1] - $
+p1[1], $p3[1] - $p4[1] );
    my $n2 = Determinant( $p2[0] - $p1[0], $p3[0] - $p1[0], $p2[1] - $
+p1[1], $p3[1] - $p1[1] );
    if( !( $n1/$d < 1 and $n2/$d < 1 and $n1/$d > 0 and $n2/$d > 0 ) )
+ {
        return 0;
    }
    return 1;
}
sub Determinant {
    use integer;
    return $_[0] * $_[1] - $_[2] * $_[3];
}
__END__
P:\test>480481.pl
"my" variable $edges masks earlier declaration in same scope at P:\tes
+t\480481.pl line 25.
"my" variable $neighborEdges masks earlier declaration in same scope a
+t P:\test\480481.pl line 30.
Unique edges 90300
Pairs parsed in : 1 wallclock secs ( 1.72 usr +  0.02 sys =  1.73 CPU)
Unintersected edges 1778
Intersects parsed in :786 wallclock secs (763.19 usr +  0.55 sys = 763
+.74 CPU)

__second__
P:\test>480481.pl
Unique edges 90300
Pairs parsed in : 2 wallclock secs ( 1.77 usr +  0.02 sys =  1.78 CPU)
Unintersected edges 3299
Intersects parsed in :729 wallclock secs (711.84 usr +  0.86 sys = 712
+.70 CPU)

__third__
P:\test>480481.pl
Unique edges 45150
Pairs parsed in : 1 wallclock secs ( 1.28 usr +  0.03 sys =  1.31 CPU)
Unintersected edges 1699
Intersects parsed in :223 wallclock secs (217.66 usr +  0.22 sys = 217
+.87 CPU)

__fourth__
P:\test>480481.pl
Unique edges 45150
Pairs parsed in : 2 wallclock secs ( 1.27 usr +  0.03 sys =  1.30 CPU)
Unintersected edges 1699
Intersects parsed in :191 wallclock secs (186.78 usr +  0.22 sys = 187
+.00 CPU)

__fifth__
P:\test>480481.pl
Unique edges 45150
Pairs parsed in : 1 wallclock secs ( 1.25 usr +  0.05 sys =  1.30 CPU)
Unintersected edges 1699
Intersects parsed in :191 wallclock secs (186.95 usr +  0.11 sys = 187
+.06 CPU)

__sixth__
P:\test>480481.pl
Unique edges 45150
Pairs parsed in : 2 wallclock secs ( 1.30 usr +  0.03 sys =  1.33 CPU)
Unintersected edges 1699
Intersects parsed in :177 wallclock secs (173.06 usr +  0.23 sys = 173
+.30 CPU)

[download]
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?
"Science is about questioning the status quo. Questioning authority".
The "good enough" maybe good enough for the now, and perfection maybe unobtainable, but that should not preclude us from striving for perfection, when time, circumstance or desire allow.

In reply to Re: Millions of line segment intersection calcs: Looking for speed tips (80% saved) by BrowserUk
in thread Millions of line segment intersection calcs: Looking for speed tips by drewhead

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.