#!/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],
}
|