http://qs321.pair.com?node_id=1224806


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;

[download]

Replies are listed 'Best First'.
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>

    [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom