[ [[177, 518], [205, 353]], [[259, 614], [177, 518]], [[205, 353], [383, 489]], [[259, 614], [380, 498]], [[367, 274], [415, 456]], [[464, 246], [367, 274]], [[380, 498], [486, 622]], [[383, 489], [415, 456]], [[452, 160], [464, 246]], [[490, 135], [452, 160]], [[486, 622], [579, 606]], [[490, 135], [586, 244]], [[579, 606], [632, 643]], [[586, 244], [717, 227]], [[632, 643], [719, 549]], [[717, 227], [746, 269]], [[719, 549], [775, 555]], [[746, 269], [856, 312]], [[775, 555], [856, 312]], ] #### sub edges2poly { my $edges = shift; ## Ref to the AoAoA above. ## For each edge in the list (which is reordered as this loop progresses) for my $i ( 0 .. $#$edges - 1 ) { ## Stringyfy the end-point my $target = "@{ $edges->[ $i ][ 1 ] }"; ## And scan the remain edges for my $j ( $i + 1 .. $#$edges ) { ## Comparing the target, ## first against the start if( $target eq "@{ $edges->[ $j ][ 0 ] }" ) { ## found the next edge correctly oriented. last if $j == $i + 1; ## nowt to do if its already the next edge } ## and then the end of each elsif( $target eq "@{ $edges->[ $j ][ 1 ] }" ) { ## Found it, but its ends need swapping @{ $edges->[ $j ] } = reverse @{ $edges->[ $j ] }; last if $j == $i + 1; ## nowt more to do if its the next edge } else { next; ## try the next edge } ## If we got here, we found it (and possible swapped then ends, ## But it is in the wrong place in the list, so swap the edges. @{ $edges }[ $i+1, $j ] = @{ $edges }[ $j, $i+1 ]; last; ## And skip to the next target } } ## return an AoA of just the required points for the bounding polygon. return( $edges->[ 0 ][ 0 ], map{ $_->[ 1 ] } @$edges ); } #### #! perl -slw use strict; use Data::Dump qw[ pp ]; $Data::Dump::MAX_WIDTH = 200; use List::Util qw[ reduce ]; use Math::Geometry::Voronoi; use GD; use constant { X => 1000, Y => 800 }; $|++; our $N ||= 20; our $PAT ||= 'random'; my @points; if( $PAT eq 'diamond' ) { @points = map{ my $y = $_; map [ $_, $y ], map{ ( ($y=~m[^[13579]] ? 0 : 0.5) + $_ )* 200 } 0 .. 7; } map $_ * 100, 1 .. 7; } elsif( $PAT eq 'hex' ) { @points = map{ my $y = $_; map [ $_, $y ], map{ ( ($y=~m[^.5] ? 0 : 0.5) + $_ )* 50 } 2 .. 18; } map $_ * 50, 2 .. 14; } elsif( $PAT eq 'hex2' ) { @points = map{ my $y = $_; map [ $_, $y ], map{ ( ($y=~m[^.5] ? 0 : 0.5) + $_ )* 25 } 4 .. 34; } map $_ * 25, 4 .. 28; } elsif( $PAT eq 'square' ) { @points = map{ my $y = $_; map [ $_, $y ], map $_ * 100, 1 .. 9; } map $_ * 100, 1 .. 7; } else { # 'random' -N=nnn @points = map [ int( 100 + rand X - 200 ), int( 100 + rand Y- 200 ), ], 1 .. $N; } #pp \@points; <>; my $geo = Math::Geometry::Voronoi->new( points => \@points ); $geo->compute; my $img = GD::Image->new( X, Y, 1 ); $img->filledRectangle( 100, 100, X-100, Y-100, 0x00ffffff ); my @geoPolys = $geo->polygons; #pp \@geoPolys; <>; my @gdUnfilteredPolys = map { gdPolyFromPoints( @{ $_ }[ 1 .. $#$_ ] ); } @geoPolys; $img->openPolygon( $_, rgb2n( 128, 128, 128 ) ) for @gdUnfilteredPolys; my @filteredPolys = map { my $ref = [ filterPoly( 100, 100, 900, 700, @{ $_ }[ 1 .. $#$_ ] ) ]; @$ref ? $ref : () } @geoPolys; #pp \@filteredPolys; <>; my @gdPolys = map { gdPolyFromPoints( @$_ ); } @filteredPolys; #pp \@gdPolys; <>; $img->openPolygon( $_, rgb2n( 0, 255, 0 ) ) for @gdPolys; $img->filledEllipse( @$_, 3, 3, rgb2n( 255, 0, 0 ) ) for @points; my %countedEdges; for my $poly ( @filteredPolys ) { reduce{ my( $sa, $sb ) = sort( "@$a", "@$b" ); $countedEdges{ "$sa, $sb" }++; $b } @{ $poly }, $poly->[ 0 ]; } #pp \%countedEdges; ## rebuild the stringified edges my @coverageEdges = map { [ map [ split ], split ', ' ] } grep $countedEdges{ $_ } == 1, keys %countedEdges; #pp \@coverageEdges; my @coveragePoly = edges2poly( \@coverageEdges ); my $gdCoveragePoly = gdPolyFromPoints( @coveragePoly ); $img->openPolygon( $gdCoveragePoly, rgb2n( 0, 0, 255 ) ); open IMG, '>:raw', 'voronoi.png' or die $!; print IMG $img->png; close IMG; system 'voronoi.png'; sub rgb2n{ unpack 'N', pack 'CCCC', 0, @_ } sub n2rgb{ unpack 'xCCC', pack 'N', $_[0] } sub gdPolyFromPoints { # pp \@_; return unless @_; my $p = new GD::Polygon; $p->addPt( @$_ ) for @_; return $p; } sub filterPoly { my( $xmin, $ymin, $xmax, $ymax ) = map shift, 1 .. 4; my @rv; my $last = [-1,-1]; for( @_ ) { $_ = int( $_ ) for @$_; ## reject the entire poly if one or more points is out of bounds. # warn( "rejecting @{[ map{ qq[@$_] } @_ ]} completely" ), return if $_->[ 0 ] < $xmin or $_->[ 0 ] > $xmax or $_->[ 1 ] < $ymin or $_->[ 1 ] > $ymax; ## Reject this point if it is the same as the previous point # warn( "rejecting point [ @$_ ]" ), next if $_->[ 0 ] == $last->[ 0 ] and $_->[ 1 ] == $last->[ 1 ]; push @rv, $_; $last = $_; } return @rv; } sub edges2poly { my $edges = shift; for my $i ( 0 .. $#$edges - 1 ) { my $target = "@{ $edges->[ $i ][ 1 ] }"; # warn "looking for ($i) $target\n"; for my $j ( $i + 1 .. $#$edges ) { # warn "in ($j)" . pp $edges->[ $j ]; if( $target eq "@{ $edges->[ $j ][ 0 ] }" ) { ## found the next point correctly oriented. # warn "Found it the right way around\n"; last if $j == $i + 1; ## nothing to do } elsif( $target eq "@{ $edges->[ $j ][ 1 ] }" ) { ## Found it, but it needs reversing # warn "Found it the reversed\n"; @{ $edges->[ $j ] } = reverse @{ $edges->[ $j ] }; last if $j == $i + 1; ## nothing more to do } else { next; ## try the next } # warn "swapping " . pp( $edges->[ $i+1 ] ) # . " and " . pp( $edges->[ $j ] ); @{ $edges }[ $i+1, $j ] = @{ $edges }[ $j, $i+1 ]; last; } # pp $edges; <>; } return( $edges->[ 0 ][ 0 ], map{ $_->[ 1 ] } @$edges ); }