#!/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;
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.