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;