in reply to searching polygons not merged
#!/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;
Re^2: searching polygons not merged
by localshop (Monk) on Oct 30, 2018 at 02:26 UTC
|
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>
| [reply] [d/l] |
|
|