In general many efficient so called "clipping" algorithms depend on calculating "bounding boxes".

This - the smallest surrounding rectangular - allows eliminating many impossible candidates.

The rules are:

• Bounding boxes don't intersect => Polygons don't intersect
• Bounding boxes can only intersect if both x and y intervals intersect.
• Two intervals a (= [a0,a1] ) and b only intersect iff a0 <= b1 and b0 <= a1

Thus storing the bounding-boxes in an ordered structure° helps efficiently eliminating impossible combinations.

But I suppose you are better off using an already available graphic lib.

HTH! :)

update

°) see also Spatial_index#Spatial_index and for instance Quadtree

Very simple way is that obtain all points in 1st polygon and check which point is inside of 2nd polygon. but this algorithm is not that good performance and stupid way I think.

This algorithm will give wrong results for e.g. the following two polygons, where two rectangles intersect each other but not a single of its vertices lies within the other rectangle.

   +-+
   | |
+--+-+--+
|  | |  |
+--+-+--+
   | |
   +-+
[download]

A better and easy-to-implement check would be whether any two edges of the polygons intersect. Of course, you also need to take into account that polygons might share one or more vertices, or a vertex might sit exactly on an edge of another polygon.

For performance, follow the hint by Lanx to start with the bounding boxes (waaay faster than calculating surrounding circles, sorry, hippo). This will easily eliminate polygons which don't overlap, and also provide some polygons which must overlap. Looking at my example above, if the two rectangles are bounding boxes of arbitrary polygons, then these polygons overlap.

But for sure this isn't complete. For some types of polygons, a strategy could be to cut the polygons into pieces (that's what Math::Polygon::Tree does, and it uses Math::Geometry::Planar::GPC for the hard work) and then repeat checking whether the bounding boxes overlap. Below are some border cases to check any algorithm - but maybe you know that you don't have any of these:

+----------+     +------+     +------+
|          |     |      |     |      |
|  +-------+     |      |     |      |
|  |             |      |     |      |
|  |  +--+       |      |     |      |
|  |  |  |       |      |     |      |
|  |  +--+       |      |     | +--+ |
|  |             |      |     | |  | |
|  +-------+     +-+--+-+     +-+--+-+
|          |       |  |        
+----------+       +--+
[download]

but that example performance is really bad

This will run in less than half the time:

while (my $polygon1 = shift @polygon) {
    foreach my $polygons2(@polygon){
        # Comparison code here
    }
}
[download]

Additionally, I'd probably create an array of the smallest circles which enclose all the vertices of each polygon before starting the main loop. If the two circles don't overlap (an easy calc) then the two polygons won't either. That will reduce the number of more expensive calcs required.

Good points.

But I'm not sure if the minimum circle is more efficient than a minimum bounding box.

(I bet it's not)

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery FootballPerl is like chess, only without the dice}

The minimum circle is more expensive to compute (for an irregular polygon) but that's O(n). Since the circle is smaller it will be no worse and maybe a good bit better for weeding out non-overlaps and the bonus that brings will depend entirely on the dataset being examined. Without seeing sample data, would you take the O(n) hit for an O(n²) gain? I probably would.

(I bet it's not)

It's a gamble either way. :-)

combine(merge) polygons -- deja vu? Maybe look into modifying C (eventually, Fortran) wrapper in my answer there, to return a boolean result for intersection. Considering observed speed vs. GPC-based solution, it may be OK to have pure Perl looping over original array, as in OP, and calling this function, eliminating failed (i.e. "merged" -- ??) polygons while doing so.

Hello dideod.yang,

I am not very familiar with polygons but if I understand your question correctly the Math::Polygon::Tree module does exactly what you want.

Let me know if this works for you.

BR / Thanos

> does exactly what you want.

From my understanding this only solves the 2 polygon case and doesn't pre-filter impossible combinations.

update

though the OP did indeed also ask about the 2 polygon case. sorry this post is hard to interpret.

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery FootballPerl is like chess, only without the dice}

How can I generate an example polygon collection? (i.e., what does "10000 EA" mean?)

I wouldn't be surprised if searching for overlapping polygons in a database of indexed polygons would be fast. If you had an example of "not that good performance and stupid way", I could see if a database search would indeed be better and "less stupid".

How do you represent polygons in a database, such that searching for overlaps becomes "fast"?

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery FootballPerl is like chess, only without the dice}

To illustrate polygon (a standard postgresql data type), polygon-comparison (here: overlap), and polygon-indexing (with which my practical experience is pretty much zero - caveat emptor!), I lifted some sql from the standard regression tests in the postgres source tree ( src/test/regress/sql/polygon.sql ), and messed about with it a bit, and added comments:

Note: the postgres polygon overlap operator is &&

#!/bin/bash

echo "
drop   table if exists quad_poly_tbl ;
create table           quad_poly_tbl (id int, p polygon);
insert into quad_poly_tbl
  select (x - 1) * 100 + y, polygon(circle(point(x * 10, y * 10), 1 + 
+(x + y) % 10))
  from generate_series(1, 100) x, generate_series(1, 100) y ;
insert into quad_poly_tbl
  select i, polygon '((200, 300),(210, 310),(230, 290))'
  from generate_series(10001, 11000) AS i ;

analyze quad_poly_tbl;

-- search for overlap with this polygon:
select * from quad_poly_tbl where p && '((22,640),(23.0717967697245,64
+4),(26,646.928203230275),(30,648),(34,646.928203230275),(36.928203230
+2755,644),(38,640))'::polygon ;

--> Time: 1.382 ms  -- Seq Scan on quad_poly_tbl (3 MB)

-- now add index:
create index quad_poly_tbl_idx ON quad_poly_tbl USING spgist(p);

-- search again for overlap with this polygon but now WITH the polygon
+-index present:
select * from quad_poly_tbl where p && '((22,640),(23.0717967697245,64
+4),(26,646.928203230275),(30,648),(34,646.928203230275),(36.928203230
+2755,644),(38,640))'::polygon ;

--> Time: 0.271 ms  -- Bitmap Index Scan on quad_poly_tbl_idx (1 MB)

" | psql -qa
[download]

So the difference between seqscan and polygon-index in this test (searching for 6 matching rows in a table of 11000 rows) is:

--> Time: 1.382 ms  -- Seq Scan on quad_poly_tbl (3 MB)
--> Time: 0.271 ms  -- Bitmap Index Scan on quad_poly_tbl_idx (1 MB)
[download]

For the OP's question, of course, loading data into the database, etc., should be taken into account.

#!/usr/bin/env perl

use Carp;
use strict;
use warnings;
use Data::Dumper;
use Machine::Epsilon; # imports machine_epsilon()automatically
# contains_polygon_rough

    my $shapes = [
        [[0,0],[0,2],[2,2],[2,0],[0,0]],
        [[0,0],[3,0],[3,1],[0,1],[0,0]],
        [[3,0],[3,2],[4,2],[4,0],[3,0]],
        [[0,2],[0,3],[1,3],[1,2],[0,2]],
        [[100,100],[100,102],[102,102],[102,100],[100,100]],
    ];



my $borg = borg->new; ## try to assimilate polys into clusters contain
+ed in the borg

foreach my $shape ( @$shapes )
{
    my $poly = poly->new( $shape );
    $borg->integrate_poly_into_matching_clusters(  $poly );
}



my $cluster_count = scalar( @{$borg->{clusters}});
print "Cluster count =  $cluster_count\n";
foreach my $cluster ( @{$borg->{clusters}} )
{
    my $poly_count = scalar( @{$cluster->{polys}} );
    print "Cluster contains $poly_count polys\n";
}

## display the shapes that are within a cluster containing only a sing
+le poly
foreach my $solo (  @{$borg->solo_clusters()}  )
{
    $solo->{polys}[0]->display();
}



## sort all the shapes by sum(x),sum(y)


######################################################################
+#####################
## https://www.safaribooksonline.com/library/view/mastering-algorithms
+-with/1565923987/ch10.html
package line;
use Data::Dumper; use strict;use warnings; 
use Machine::Epsilon; # imports machine_epsilon()automatically

sub new 
{
    my ( $class, $p )  = @_;
    my $self =  bless {
     two_points => []
    }, $class;
    
    $self->{two_points} = [ $p->[0][0], $p->[0][1], $p->[1][0], $p->[1
+][1] ];
    return $self;
}

## from https://www.perlmonks.org/bare/?node_id=253974
sub intersectLines {
    #working subroutine. thanks to the original poster.
        my( $ax, $ay, $bx, $by, $cx, $cy, $dx, $dy )= @_;
        my $ret = 0;
        my @rval=0;
        
        my $d1=($ax-$bx)*($cy-$dy);
        my $d2=($ay-$by)*($cx-$dx);
        
        my $dp = $d1 - $d2;
        my $dq = $d2 - $d1;
        
        if($dp!=0 && $dq!=0) 
        {
           my $p = ( ($by-$dy)*($cx-$dx) - ($bx-$dx)*($cy-$dy) ) / $dp
+;   
    + 
           my $q = ( ($dy-$by)*($ax-$bx) - ($dx-$bx)*($ay-$by) ) / $dq
+;
          if($p>0 && $p<=1 && $q>0 && $q<=1) {    
             my $px= $p*$ax + (1-$p)*$bx;
             my $py= $p*$ay + (1-$p)*$by;
             @rval=($px, $py);
             print "$px, $py\n";
             $ret =1;
          }
       }
       return $ret;
    }


sub intersects 
{   ## with another line
    my ( $self, $other_line ) = @_;

   my $ret2 = intersectLines( @{$self->{two_points} }, @{$other_line->
+{two_points} } );
   return $ret2;
}

1;


######################################################################
+#####################
package poly;
use Data::Dumper; use strict;use warnings; 
sub new 
{
    my ( $class, $p )  = @_;
    my $self = bless {
     lines => [],
    }, $class;

    ## populate poly from array of array of points
    croak("poly requires at least 3 edges") unless (scalar(@$p)>=3);
    for ( my $i=1; $i< scalar(@$p) ; $i++ )
    {
        push @{$self->{lines}}, line->new( [ $p->[$i-1], $p->[$i] ] );
    }

    return $self;
}

sub touches 
{
    my ( $self, $poly ) = @_;
    foreach my $other_line ( @{ $poly->{lines} }  )
    {
        foreach my $line ( @{ $self->{lines} } ) 
        {
            return 1 if $line->intersects( $other_line );
        }
    }
    return;
}

sub display 
{
    my ( $self ) = @_;
    print Dumper $self->{lines};
}

1;


######################################################################
+#####################
package cluster; ## a shape(s) cluster 

sub new 
{
    my ( $class, $p )  = @_;
    return bless {
     polys => [$p],
    }, $class;
}
sub is_solo
{
    my ( $self ) = @_;
    return  scalar( @{ $self->{polys} } ) == 1 ; ## return 1 iff singl
+e element
}

sub touches_edge_from 
{
    my ( $self, $poly ) = @_; ## returns 1 iff a line from the poly ma
+tches any line in the cluster
    foreach my $my_poly ( @{$self->{polys}} )
    {
        return 1 if $poly->touches( $my_poly );
    }
    return;

}
1;


######################################################################
+#####################
package borg; ## you will be assimilated

sub new 
{
    my ( $class, $p )  = @_;
    return bless {
     clusters => [] || $p,
    }, $class;
}

sub solo_clusters
{
    my ( $self ) = @_;
    my $res = [];
    foreach my $cluster ( @{$self->{clusters}} )
    {
        push @$res, $cluster if $cluster->is_solo;
    }
    return $res;
}

sub integrate_poly_into_matching_clusters
{
    my ( $self, $poly ) = @_;
    
    my $matched = 0; my $clusters_to_merge = {};

    if ( $self->{clusters} )
    {
        for ( my $i=0; $i<  @{$self->{clusters} }; $i++ )
        {
            print "Checking whether shape touches cluster $i\n";
            if ($self->{clusters}[$i]->touches_edge_from( $poly ) )
            {
                $clusters_to_merge->{$i}++ ; ## mark index for merge
                if ($matched==0) ## if this is the first match then ad
+d this poly into the cluster
                {
                    
                    push @{ $self->{clusters}[$i]{polys} }, $poly; 
                    ## nb - still need to check all the other clusters
+ for a match
                    ##  to look for merge opportunities
                }
                $matched++;
            }
        }
        ## merge clusters if needed
        print "shape touches $matched clusters\n";
        if ( $matched > 1 ) ## if == 1 then the shape only touches on 
+the cluster it was add into already
        {
            my $merged = []; my $new_cluster = cluster->new();
            for ( my $i=0; $i<  @{$self->{clusters}}; $i++ )
            {
                if ( defined $clusters_to_merge->{$i}  )
                {
                    ## add all the polys from this cluster to the merg
+ed one 
                    push @{ $new_cluster->{polys} }, @{ $self->{cluste
+rs}[$i]{polys} } ;
                }
                else ## otherwise keep the cluster as it is  
                {
                    push @$merged, $self->{clusters}[$i]; 
                }
            }
            
            $self->{clusters} = [ @$merged, $new_cluster ];
        }
    }
    if  ($matched == 0)
    {
        print "Creating a new cluster\n";
        push @{$self->{clusters}}, cluster->new( $poly ) ; ## if no ma
+tch found then we need a new cluster
    } 
    
    return;
}


1;
[download]

I hadn't tested the original code beyond a couple of trivial cases and though that it would be a good opportunity to try out WebPerl. So I hacked together the following.

NB - I think that my original line intersection code taken from the text may be problematic. I found a replacement that I've used here from another PM node that looks to work better.

This code seems to be working and runs in the browser - click on the canvas to draw polys then click the button to remove any that have overlaps.

With regard to WebPerl - it's quite a peculiar delight to be coding browser code in Perl - I highly recommend having a play with it and I look forward to seeing it evolve.

- NB - Had to remove the script src webperl.js js inclusion line from the code to allow to be posted here

<!doctype html>
<html lang="en-us">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title>WebPerl </title>



<!-- Please see the documentation at http://webperl.zero-g.net/using.h
+tml -->

<!-- Example 2: Accessing JavaScript -->
<script type="text/perl">
use warnings;
use strict;
use WebPerl qw/js/;
use Data::Dumper;
## Playing with the HTML5 Canvas 
## See https://www.html5canvastutorials.com/

my $c = js('document')->getElementById('myCanvas');
my $EPSILON = js('Number.EPSILON');

my $new_shape = {
    status => 0,
    points => [],
    lines => [],
};
my $shapes = [];

js('document')->getElementById('my_button')
    ->addEventListener("click", sub {
        print "You clicked 'the button - launching the Borg'\n";
        my $borg = borg->new;
        foreach my $shape ( @$shapes )
        {
            
            $borg->integrate_poly_into_matching_clusters(  $shape );
            
        }
        print "Done\n";
        my $ctx = $c->getContext("2d");
        $ctx->beginPath(); ## to clear all the objects in the context 
        $ctx->save();
        $ctx->clearRect(0,0, $c->{width}, $c->{height} );

        foreach my $solo (  @{$borg->solo_clusters()}  )
        {
            
            print "Got a solo\n";
            $solo->{polys}[0]->draw($ctx, '#ff0000');
        }
        $shapes = [];
        #sleep(5);
        #redraw_canvas();

    } );


######## MOUSE HANDLERS ###########################

$c->addEventListener('click', sub { 
    my ($evt) = @_;  
   my $rect = $c->getBoundingClientRect();
   my $i = scalar( @{ $new_shape->{points} } );

    #print "i=$i\n";
    if ($new_shape->{status} == 0 )
    {
        print "Starting to draw a shape\n";
        $new_shape->{status} = 1;
        $new_shape->{points} = [];
    } 
    else 
    {
        if ( $i>0)   ## more than 1 point so we create a line to the l
+ast point
        {
            ## create a new line instance
            #print " $new_shape->{points}[$i-1][0] , $new_shape->{poin
+ts}[$i-1][1], $evt->{clientX} - $rect->{left},$evt->{clientY} - $rect
+->{top} \n";
            push @{ $new_shape->{lines} }, line->new( $c->getContext('
+2d'), [  [$new_shape->{points}[$i-1][0] , $new_shape->{points}[$i-1][
+1] ], [$evt->{clientX} - $rect->{left},$evt->{clientY} - $rect->{top}
+] ] );
            if ( $i>1 ) ## check if we selected the starting point and
+ if so close the shape
            {
                if (  $new_shape->{points}[$i-1][0] == $new_shape->{po
+ints}[0][0] && $new_shape->{points}[$i-1][1] == $new_shape->{points}[
+0][1]  ) ## close the poly 
                {
                    #print "closing shape\n";
                    ## CONVERT new_shape to poly and reset
                    create_shape_object_from_new_shape();
                    return !0;
                }        
            }
        }
    }
    push @{$new_shape->{points}}, [$evt->{clientX} - $rect->{left},$ev
+t->{clientY} - $rect->{top} ];
},!0 );




$c->addEventListener('contextmenu', sub { ## right mouse - add 2 lines
+ to current pos and back to original starting point
    my ($evt) = @_;  

   my $rect = $c->getBoundingClientRect();
   my $i = scalar( @{ $new_shape->{points} } );
   if ( $i < 3 ) ## cancel shape if only a couple of points
   {
        redraw_canvas();
        return !0;
   }
    if ( $new_shape->{status} != 0 )
    {
        print "Closing shape \n";
        push @{ $new_shape->{lines} }, line->new( $c->getContext('2d')
+, [  [ $new_shape->{points}[$i-1][0] ,  $new_shape->{points}[$i-1][1]
+ ] ,   [ $evt->{clientX} - $rect->{left}, $evt->{clientY} - $rect->{t
+op}] ] );
        push @{ $new_shape->{lines} }, line->new( $c->getContext('2d')
+, [  [ $evt->{clientX} - $rect->{left}, $evt->{clientY} - $rect->{top
+}] ,   [ $new_shape->{points}[0][0]     , $new_shape->{points}[0][1] 
+ ] ] );

        ## CONVERT new_shape to poly and reset
        create_shape_object_from_new_shape();
    }
    return !0; ## something doesn't work here - want to return false b
+ut still showing contextmenu :/
},!1 );

sub redraw_canvas
{
    #print "clear recr = 0,0, $c->{width}, $c->{height}\n";
    my $ctx = $c->getContext("2d");
    $ctx->beginPath(); ## to clear all the objects in the context 
    $ctx->save();
    $ctx->clearRect(0,0, $c->{width}, $c->{height} );
    foreach my $poly ( @{$shapes} )
    {
        # print "drawing poly\n";
        $poly->draw( $ctx, '#00ff00' );
    }
    $new_shape->{status} = 0;
    $new_shape->{points} =  [];
    $new_shape->{lines} = [];   
    ## NB - new_shape should always be empty here !! 
    #print Dumper $new_shape;
    #print scalar(keys %WebPerl::CodeTable);

}

sub create_shape_object_from_new_shape
{
    #my ( $new_shape ) = @_;
    #print "create_shape_object_from_new_shape()\n";

    push @{$shapes}, poly->new( $new_shape->{lines} );
    $new_shape->{status} = 0;
    $new_shape->{points} =  [];
    $new_shape->{lines} = [];    
    redraw_canvas();
}


###########################
package line;
use Data::Dumper; use strict;use warnings; 



sub new 
{
    my ( $class, $ctx, $p )  = @_;
    
    my $self =  bless {
     two_points => [],
     
    }, $class;

    $self->{ctx} = $ctx;
    
    $self->{two_points} = [ $p->[0][0], $p->[0][1], $p->[1][0], $p->[1
+][1] ];
    $self->draw(  $ctx, '#0000ff' );
    return $self;
}

sub draw 
{
    my ( $self, $ctx, $color ) = @_;
    
    $self->{ctx} = $ctx;
   
    $color = '#ff0000' unless $color;
    $self->{ctx}->moveTo( $self->{two_points}[0], $self->{two_points}[
+1] );
    $self->{ctx}->lineTo(  $self->{two_points}[2], $self->{two_points}
+[3] );
    $self->{ctx}{strokeStyle} = $color;
    #print "Color = $color\n";
    $self->{ctx}{lineWidth} = 2;
    $self->{ctx}->stroke();
    return 1;
}

## from https://www.perlmonks.org/bare/?node_id=253974
sub intersectLines {
    #working subroutine. thanks to the original poster.
        my( $ax, $ay, $bx, $by, $cx, $cy, $dx, $dy )= @_;
        my $ret = 0;
        my @rval=0;
        
        my $d1=($ax-$bx)*($cy-$dy);
        my $d2=($ay-$by)*($cx-$dx);
        
        my $dp = $d1 - $d2;
        my $dq = $d2 - $d1;
        
        if($dp!=0 && $dq!=0) 
        {
           my $p = ( ($by-$dy)*($cx-$dx) - ($bx-$dx)*($cy-$dy) ) / $dp
+;   
    + 
           my $q = ( ($dy-$by)*($ax-$bx) - ($dx-$bx)*($ay-$by) ) / $dq
+;
          if($p>0 && $p<=1 && $q>0 && $q<=1) {    
             my $px= $p*$ax + (1-$p)*$bx;
             my $py= $p*$ay + (1-$p)*$by;
             @rval=($px, $py);
             print "$px, $py\n";
             $ret =1;
          }
       }
       return $ret;
    }


sub intersects 
{   ## with another line
    my ( $self, $other_line ) = @_;

   my $ret2 = intersectLines( @{$self->{two_points} }, @{$other_line->
+{two_points} } );
   return $ret2;
}

1;

######################################################################
+#####################
package poly;
use Data::Dumper; use strict;use warnings; 
sub new 
{
    my ( $class, $p )  = @_;
    my $self = bless {
     lines => [],
     color => '#00ff00',
    }, $class;

    ## populate poly from array of array ref of line instances 
    
    
    my $line_count = scalar( @{$p} );
    
    $self->{lines} = $p;
    return $self;
}

sub touches 
{
    my ( $self, $poly ) = @_;
    foreach my $other_line ( @{ $poly->{lines} }  )
    {
        foreach my $line ( @{ $self->{lines} } ) 
        {
            return 1 if $line->intersects( $other_line );
        }
    }
    return;
}

sub draw 
{
    my ( $self, $ctx, $color ) = @_;
    my $line_count = scalar( @{$self->{lines}} );
    foreach my $l ( @{$self->{lines}} )
    {
        $l->draw( $ctx, $color);
    }
    return 1;
}
1;

######################################################################
+#####################
package cluster; ## a shape(s) cluster 

sub new 
{
    my ( $class, $p )  = @_;
    return bless {
     polys => [$p],
    }, $class;
}
sub is_solo
{
    my ( $self ) = @_;
    if ( scalar( @{ $self->{polys} } ) == 1 )
    {
        return 1;
    }
    else 
    {
        return 0;
    }
}

sub touches_edge_from 
{
    my ( $self, $poly ) = @_; ## returns 1 iff a line from the poly ma
+tches any line in the cluster
    foreach my $my_poly ( @{$self->{polys}} )
    {
        return 1 if $poly->touches( $my_poly );
    }
    return;

}
1;


######################################################################
+#####################
package borg; ## you will be assimilated

sub new 
{
    my ( $class, $p )  = @_;
    return bless {
     clusters => [] || $p,
    }, $class;
}

sub solo_clusters
{
    my ( $self ) = @_;
    my $res = [];
    foreach my $cluster ( @{$self->{clusters}} )
    {
        push @$res, $cluster if $cluster->is_solo;
    }
    return $res;
}

sub integrate_poly_into_matching_clusters
{
    my ( $self, $poly ) = @_;
    
    my $matched = 0; my $clusters_to_merge = {};

    if ( $self->{clusters} )
    {
        for ( my $i=0; $i<  @{$self->{clusters} }; $i++ )
        {
            print "Checking whether shape touches cluster $i\n";
            if ($self->{clusters}[$i]->touches_edge_from( $poly ) )
            {
                $clusters_to_merge->{$i}++ ; ## mark index for merge
                if ($matched==0) ## if this is the first match then ad
+d this poly into the cluster
                {
                    
                    push @{ $self->{clusters}[$i]{polys} }, $poly; 
                    ## nb - still need to check all the other clusters
+ for a match
                    ##  to look for merge opportunities
                }
                $matched++;
            }
        }
        ## merge clusters if needed
        print "shape touches $matched clusters\n";
        if ( $matched > 1 ) ## if == 1 then the shape only touches on 
+the cluster it was add into already
        {
            my $merged = []; my $new_cluster = cluster->new();
            for ( my $i=0; $i<  @{$self->{clusters}}; $i++ )
            {
                if ( defined $clusters_to_merge->{$i}  )
                {
                    ## add all the polys from this cluster to the merg
+ed one 
                    push @{ $new_cluster->{polys} }, @{ $self->{cluste
+rs}[$i]{polys} } ;
                }
                else ## otherwise keep the cluster as it is  
                {
                    push @$merged, $self->{clusters}[$i]; 
                }
            }
            
            $self->{clusters} = [ @$merged, $new_cluster ];
        }
    }
    if  ($matched == 0)
    {
        print "Creating a new cluster\n";
        push @{$self->{clusters}}, cluster->new( $poly ) ; ## if no ma
+tch found then we need a new cluster
    } 
    
    return;
}

1;

</script>




<!-- CAPTURE STDOUT/ERR INSTEAD OF CONSOLE-->
<script>
window.addEventListener("load", function () {
    document.getElementById('output')
        .appendChild( Perl.makeOutputTextarea() );
});
</script>

</head>
<body>

<div id="output"></div>
<div id="buttons">
    <button id="my_button">Display only non-overlapping polys </button
+>
</div>
<div>Click on the canvas below to create lines and right-click to clos
+e the polygon</div>
<canvas style="border-style:solid; border-width:1px;" id="myCanvas" wi
+dth="1000" height="1000"></canvas>
</body>
</html>
[download]