 XP is just a number PerlMonks

### searching polygons not merged

by dideod.yang (Sexton)
 on Oct 27, 2018 at 14:43 UTC Need Help??

dideod.yang has asked for the wisdom of the Perl Monks concerning the following question:

Hi monks. I search the fastest way to search polygons not merged. I have polygons array at least 10000 EA. Of course I search CPAN. but CPAN didn't have modules I want. I search details on Math::Geometry::Planar or Math::Polygon::Calc.. but there are no my target.. 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.. Do you have any idea? also If I get some algorithm then how can I check all polygons. Basic way is using two foreach loop like below example. but that example performance is really bad. please give me nice idea.. thank you
```foreach my \$polygon1(@polygon){
foreach my \$polygons2(@polygon){
# algorithm checking polygons not merged or overlapped
}
}

Replies are listed 'Best First'.
Re: searching polygons not merged
by LanX (Archbishop) on Oct 27, 2018 at 15:42 UTC
You should describe the format of your polygon data, to avoid us guessing.

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! :)

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

##### update

Re: searching polygons not merged
by haj (Chaplain) on Oct 27, 2018 at 17:18 UTC
It seems you are looking for an easy solution to a not-so-easy problem - maybe this doesn't exist.
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.

```   +-+
| |
+--+-+--+
|  | |  |
+--+-+--+
| |
+-+

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:

```+----------+     +------+     +------+
|          |     |      |     |      |
|  +-------+     |      |     |      |
|  |             |      |     |      |
|  |  +--+       |      |     |      |
|  |  |  |       |      |     |      |
|  |  +--+       |      |     | +--+ |
|  |             |      |     | |  | |
|  +-------+     +-+--+-+     +-+--+-+
|          |       |  |
+----------+       +--+
Re: searching polygons not merged
by hippo (Chancellor) on Oct 27, 2018 at 15:51 UTC
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
}
}

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(n2) gain? I probably would.

(I bet it's not)

It's a gamble either way. :-)

Re: searching polygons not merged
by vr (Deacon) on Oct 27, 2018 at 17:08 UTC

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.

Re: searching polygons not merged
by thanos1983 (Parson) on Oct 27, 2018 at 15:41 UTC

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

Seeking for Perl wisdom...on the process of learning...not there...yet!
> 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

Re: searching polygons not merged
by erix (Parson) on Oct 27, 2018 at 20:27 UTC

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);
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 ;
select i, polygon '((200, 300),(210, 310),(230, 290))'
from generate_series(10001, 11000) AS i ;

-- 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)

-- 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

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)

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

Re: searching polygons not merged
by localshop (Monk) on Oct 28, 2018 at 20:23 UTC
```#!/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}->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->, \$p->, \$p->, \$p->[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
{
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;

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">
<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')
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}->draw(\$ctx, '#ff0000');
}
\$shapes = [];
#sleep(5);
#redraw_canvas();

} );

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

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] , \$new_shape->{poin
+ts}[\$i-1], \$evt->{clientX} - \$rect->{left},\$evt->{clientY} - \$rect
+->{top} \n";
push @{ \$new_shape->{lines} }, line->new( \$c->getContext('
+2d'), [  [\$new_shape->{points}[\$i-1] , \$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] == \$new_shape->{po
+ints} && \$new_shape->{points}[\$i-1] == \$new_shape->{points}[
+0]  ) ## 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 );

+ 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] ,  \$new_shape->{points}[\$i-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}     , \$new_shape->{points}
+ ] ] );

## 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
},!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->, \$p->, \$p->, \$p->[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}, \$self->{two_points}[
+1] );
\$self->{ctx}->lineTo(  \$self->{two_points}, \$self->{two_points}
+ );
\$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
{
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>
document.getElementById('output')
.appendChild( Perl.makeOutputTextarea() );
});
</script>

<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>

Create A New User
Node Status?
node history
Node Type: perlquestion [id://1224764]
Approved by LanX
Front-paged by haukex
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (7)
As of 2019-12-14 15:15 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?

No recent polls found

Notices?