Here's some code. It occurred to me, that algorithm eliminating shape interior, in original post by golux, is actually simple kernel convolution in 2D, rolled out manually. Because of that, and because I don't like the idea of manipulating points one by one, I decided to process them "en masse", starting from original "image".
It looks like Imager can only do 1D convolution, PerlMagick is in somewhat sad state. So it's back to PDL again.
I tried to invent a kernel that would allow both to eliminate interior and to "round" corners in one pass, but unsuccessfully. Further, I couldn't invent such 2nd kernel, so that only one (instead of 2) comparison is required afterwards.
Interesting: walking direction along the outline happened to be counter-clockwise. Perhaps algorithm can be improved to allow to choose direction, from starting point.
use strict; use warnings; use feature qw/ say /; use List::Util qw/ first uniqnum /; use PDL; use PDL::Image2D; # It's important that shape doesn't touch boundaries. # Otherwise neighbours could be found across image edges, # or substr (below) can look outside argument. my ( $w, $h ) = ( 42, 33 ); my $str = << 'END'; .......................................... ..............................#........... .......................########........... .....................##########........... .....................##########........... .....................##########........... ..#.................#############.......#. .###...............######################. .###..............#######################. ..####............#######################. ...#####..........#######################. ....######........#######################. ....##########....#######################. ....#####################################. ....#####################################. ....#####################################. .......##################################. .......##################################. .......##################################. ........#################################. ........#################################. ........#################################. .........################################. .........################################. .........################################. ..........##############################.. ...........#############################.. ................########################.. .......................#################.. ...........................#############.. .................................######... .................................#####.... .......................................... END $str =~ tr/.#\n/01/d; my ( $w_, $h_ ) = ( 3 * $w, 3 * $h ); my $in = pdl([ split '', $str ])-> reshape( $w, $h ); my $img = zeroes( $w_, $h_ ); rescale2d( $in, $img ); my $kernel_1 = pdl([ qw/ 0 -1 0 -1 4 -1 0 -1 0 /])-> reshape( 3, 3 ); my $kernel_2 = pdl([ qw/ 0 -2 0 -1 5 -1 0 -2 0 /])-> reshape( 3, 3 ); $img = conv2d( $img, $kernel_1 ) > 0; $img = conv2d( $img, $kernel_2 ); $img = ( $img == 1 ) + ( $img >= 3 ); # Dump image any time for inspection, # terminal must be wider than $w_ (126). # # my @lst = $img-> list; # say splice @lst, 0, $w_ while @lst; # Back to Perl from PDL-land. my $s = ${ $img-> byte-> get_dataref }; my @checks = ( # 8 neighbours -$w_ - 1, -$w_, -$w_ + 1, -1, 1, $w_ - 1, $w_, $w_ + 1, ); my $i = CORE::index $s, "\1"; # 1st point my @list = ( $i ); substr $s, $i, 1, "\0"; while () { my $j = first { "\1" eq substr $s, $i + $_, 1 } @checks; last unless defined $j; $i += $j; push @list, $i; substr $s, $i, 1, "\0"; } die if CORE::index( $s, "\1" ) >= 0; # can't be # Scale point coordinates back to original, # squash duplicates. @list = uniqnum map { use integer; my $x = $_ % $w_ / 3; my $y = $_ / $w_ / 3; $x + $y * $w } @list; # @list uniquely identifies sequence to create polyline, # can be converted to (x,y) pairs if required. # Below is simple transformation to 2D picture. my $out = '.' x ( $w * $h ); my $n = 0; for ( @list ) { substr $out, $_, 1, $n ++; $n %= 10; } say substr $out, 0, $w, '' while $out;
And then:
.......................................... ..............................0........... .......................76543212........... .....................98.......1........... .....................0........0........... .....................1........9........... ..5.................2..........87.......9. .6.4...............3.............65432108. .7.3..............4.....................7. ..8.21............5.....................6. ...9..09..........6.....................5. ....0...87........7.....................4. ....1.....6543....8.....................3. ....2.........2109......................2. ....3...................................1. ....456.................................0. .......7................................9. .......8................................8. .......9................................7. ........0...............................6. ........1...............................5. ........2...............................4. .........3..............................3. .........4..............................2. .........5..............................1. ..........6............................0.. ...........78901.......................9.. ................2345678................8.. .......................9012............7.. ...........................345678......6.. .................................9....5... .................................01234.... ..........................................
P.S. And isn't it great that regex engine has finally a day off?
Update. Damn... Of course 2nd convolution and kernel weren't necessary. Convex corners are "2"s after the 1st one. A replacement for fragment from applying a kernel till die statement, with other (I hope so) improvements:
$img = conv2d( $img, $kernel ) == 1; $img += 48; my $s = ${ $img-> byte-> get_dataref }; my @checks = ( # increments to -$w_ - 1 ,1, 1, # 8 neighbours $w_ - 2, 2, $w_ - 2, 1, 1, ); my $i = CORE::index $s, 1; # 1st point my @list = ( $i ); substr $s, $i, 1, 0; push @list, $i while first { substr $s, $i += $_, 1, 0 } @checks;
Update 2. Oh, DAMN... What a frustration. The uniqnum description says:
Filters a list of values to remove subsequent duplicates
(emphasis mine), and I didn't test it.
>perl -MList::Util=uniqnum -E "say for uniqnum 1,1,2,1 1 2
Ah? I thought, like:
>perl -E "say '1121'=~tr/12/12/sr" 121
Then, are any duplicates removed? Why wasting time on word "subsequent"? Part of my code to be replaced, uniqnum dumped for good, core module or not:
my $prev = -1; @list = grep { my $res = $prev != $_; $prev = $_; $res } map { use integer; my $x = $_ % $w_ / 3; my $y = $_ / $w_ / 3; $x + $y * $w } @list;
damn...
In reply to Re^2: Polygon Creation -- Request for Algorithm Suggestions
by vr
in thread Polygon Creation -- Request for Algorithm Suggestions
by golux
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |