Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Re: Polygon Creation -- Request for Algorithm Suggestions

by tybalt89 (Monsignor)
on Nov 26, 2017 at 17:38 UTC ( [id://1204288]=note: print w/replies, xml ) Need Help??


in reply to Polygon Creation -- Request for Algorithm Suggestions

I wanted to see what an edge walker looked like in the "strings/regex" domain...

#!/usr/bin/perl # http://perlmonks.org/?node_id=1204060 use strict; use warnings; my @points = points(); my ($minx, $miny, $maxx, $maxy) = ( $points[0][0], $points[0][1], $points[0][0], $points[0][1]); for (@points) { my ($x, $y) = @$_; $minx > $x and $minx = $x; $miny > $y and $miny = $y; $maxx < $x and $maxx = $x; $maxy < $y and $maxy = $y; } my $height = $maxy - $miny + 3; # some useful stuff my $width = $maxx - $minx + 3; my $gw = $width + 1; # grid width (distance to down one row) my $gwm3 = $gw - 3; my @letters = ('A' .. 'Z', 'a' .. 'z'); # label points by letter seque +nce my @steps = (1, $gw+1, $gw, $gw-1, -1, -$gw-1, -$gw, -$gw+1); # by dir +ection my $grid = ( ' ' x $width . "\n" ) x $height; my @answerpoints; # coordinates around edge for (@points) # put points on grid (multiline string :) { my ($x, $y) = @$_; substr $grid, (($y - $miny + 1)) * $gw + ($x - $minx + 1), 1, '#'; } my $direction = 0; # start facing east (increases clockwise) my $start = my $at = $grid =~ /(?<= )#/ ? $-[0] : die "empty"; # at to +pleft do # clockwise walk around edge { push @answerpoints, [ $at % $gw - 1 + $minx, int $at / $gw - 1 + $mi +ny ]; pos($grid) = $at - $gw - 1; # northwest corner neighbor $grid =~ /\G(.)(.)(.).{$gwm3}(.).(.).{$gwm3}(.)(.)(.)/s; # all neigh +bors ("$1$2$3$5$8$7$6$4" x 2) =~ /^.{$direction} *(#)/ and # rotate & sca +n $at += $steps[ $direction = ( $-[1] - 3 ) % 8 ]; # step in new dir +ection } until( $at == $start ); my $i = 0; for (@answerpoints) # add letters for display if wanted { my ($x, $y) = @$_; pos($grid) = $x - $minx + 1 + ($y - $miny + 1) * $gw; $grid =~ s/\G#/$letters[$i++ % @letters]/; # label point if not } print $grid; #use Data::Dump 'pp'; pp \@answerpoints; # the real answer :) sub points { [527,83],[527,84],[526,84],[525,84],[524,84],[523,84],[522,84], ... some points deleted to shorten listing ... [534,113],[533,113],[532,113],[531,113],[530,113], }

Outputs:

A MNOPQRSB KL#######C J########D I########E k H##########FG O j#l G#############HIJKLMNP i#m F#####################Q h#no E#####################R g##pq D#####################S f###rs C#####################T e#####tuvw B#####################U d#########xyzA######################V c###################################W baZ#################################X Y################################Y X################################Z W################################a V###############################b U###############################c T###############################d S##############################e R##############################f Q##############################g P############################h ONMLK#######################i JIHGFED################j CBAz############k yxwvut######l s####m rqpon

Sure saves a lot of that ugly subscripting :)

UPDATE: New and Improved!! Now with Tk!! see Re^2: Polygon Creation -- Request for Algorithm Suggestions

Replies are listed 'Best First'.
Re^2: Polygon Creation -- Request for Algorithm Suggestions
by tybalt89 (Monsignor) on Nov 27, 2017 at 22:28 UTC

    New and Improved! Now with Tk !!

    #!/usr/bin/perl # http://perlmonks.org/?node_id=1204060 use strict; use warnings; my @points = points(); #@points = map [int rand 27, int rand 25 ], 1..700; # random test case my ($minx, $miny, $maxx, $maxy) = ( $points[0][0], $points[0][1], $points[0][0], $points[0][1]); for (@points) { my ($x, $y) = @$_; $minx > $x and $minx = $x; $miny > $y and $miny = $y; $maxx < $x and $maxx = $x; $maxy < $y and $maxy = $y; } my $height = $maxy - $miny + 3; # some useful stuff my $width = $maxx - $minx + 3; my $gw = $width + 1; # grid width (distance to down one row) my $gwm3 = $gw - 3; my @letters = ('A' .. 'Z', 'a' .. 'z'); # label points by letter seque +nce my @steps = (1, $gw+1, $gw, $gw-1, -1, -$gw-1, -$gw, -$gw+1); # by dir +ection my $grid = ( ' ' x $width . "\n" ) x $height; for (@points) # put points on grid (multiline string :) { my ($x, $y) = @$_; substr $grid, (($y - $miny + 1)) * $gw + ($x - $minx + 1), 1, '#'; } while( $^R = 0, # reset, find valid starting point $grid =~ /(?<= .{$gwm3} )#(?= .{$gwm3} . )/s # top end - spikes or $grid =~ /(?<= .{$gwm3} )#(?=..{$gwm3} )/s # left end or $grid =~ /(?<= .{$gwm3}.)#(?= .{$gwm3} )/s # right end or $grid =~ /(?<= . .{$gwm3} )#(?= .{$gwm3} )/s # bottom end or $grid =~ /(?<= .{$gwm3} )#(?= .{$gwm3}( #|# ))/s # ul | ur en +d or $grid =~ /(?<=(# | #).{$gwm3} )#(?= .{$gwm3} )/s # ll | lr en +d or $grid =~ /(?<= .{$gwm3} )#(?=#.{$gwm3}(.#| #))/s # top left or $grid =~ /(?<= .{$gwm3}#)#(?= .{$gwm3}(#| #))/s # top right or $grid =~ /(?<=(.#.| #).{$gwm3} )#(?=#.{$gwm3} )(?{4})/s # bott +om left or $grid =~ /(?<=(.#.|#..).{$gwm3}#)#(?= .{$gwm3} )(?{4})/s # bott +om right ) { my $direction = $^R; # 0 is east (increases clockwise) my @answerpoints; # coordinates around edge my $start = my $at = $-[0]; # at topleft do # clockwise walk around edge { push @answerpoints, [ $at % $gw - 1 + $minx, int $at / $gw - 1 + $ +miny ]; pos($grid) = $at - $gw - 1; # northwest corner neighbor $grid =~ /\G(.)(.)(.).{$gwm3}(.).(.).{$gwm3}(.)(.)(.)/s; # all nei +ghbors $at += ("$1$2$3$5$8$7$6$4" x 2) =~ /^.{$direction} *(#)/ # rotate +& scan ? $steps[ $direction = ( $-[1] - 3 ) % 8 ] # step in new directi +on : $start - $at; # force loop exit because scan failed } until( $at == $start ); #use Data::Dump 'pp'; pp \@answerpoints; # the real answer :) my $i = 0; for (@answerpoints) # add letters for display if wanted { my ($x, $y) = @$_; pos($grid) = $x - $minx + 1 + ($y - $miny + 1) * $gw; $grid =~ s/\G#/$letters[$i++ % @letters]/; # label point if not } print $grid; draw(@answerpoints); # for Tk } sub draw { use Tk; my $size = 700; my @pts = map { ($_->[0] - $minx + 1) * $size / $gw + 1, ($_->[1] - $miny + 1) * $size / ($maxy - $miny + 2) + 1 } @_; @pts > 50 or return; my $mw = MainWindow->new; $mw->geometry('+600+2'); my $c = $mw->Canvas(-width => $size, -height => $size)->pack; $c->createPolygon(@pts, -fill => 'green', -width => 7, -outline => 'black'); $c->createOval($pts[0] - 10, $pts[1] - 10, $pts[0] + 10, $pts[1] + 1 +0); $mw->Button(-text => 'Exit', -command => sub {$mw->destroy}, )->pack(-fill => 'x', -expand => 1); MainLoop; } sub points { [527,83],[527,84],[526,84],[525,84],[524,84],[523,84],[522,84], ... some points not shown to shorten listing ... [534,113],[533,113],[532,113],[531,113],[530,113], }
Re^2: Polygon Creation -- Request for Algorithm Suggestions
by roboticus (Chancellor) on Nov 26, 2017 at 19:46 UTC

    tybalt89:

    Very neat! I'll have to study it and see how it works. I've had to put in a few more bounds-checks in mine to remove some problems, adding even more annoying subscripts...

    ...roboticus

    When your only tool is a hammer, all problems look like your thumb.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://1204288]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (4)
As of 2024-04-18 03:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found