63 lines
2.5 KiB
Raku
63 lines
2.5 KiB
Raku
use List::Util qw(sum min);
|
|
|
|
$source = <<'END';
|
|
............................................................
|
|
..#################...................#############.........
|
|
..##################...............################.........
|
|
..###################............##################.........
|
|
..########.....#######..........###################.........
|
|
....######.....#######.........#######.......######.........
|
|
....######.....#######........#######.......................
|
|
....#################.........#######.......................
|
|
....################..........#######.......................
|
|
....#################.........#######.......................
|
|
....######.....#######........#######.......................
|
|
....######.....#######........#######.......................
|
|
....######.....#######.........#######.......######.........
|
|
..########.....#######..........###################.........
|
|
..########.....#######.######....##################.######..
|
|
..########.....#######.######......################.######..
|
|
..########.....#######.######.........#############.######..
|
|
............................................................
|
|
END
|
|
|
|
for $line (split "\n", $source) {
|
|
push @lines, [map { 1 & ord $_ } split '', $line]
|
|
}
|
|
|
|
$v = @lines;
|
|
$h = @{$lines[0]};
|
|
push @black, @$_ for @lines;
|
|
@p8 = ((-$h-1), (-$h+0), (-$h+1), # flatland distances to 8 neighbors.
|
|
0-1, 0+1,
|
|
$h-1, $h+0, $h+1)[1,2,4,7,6,5,3,0]; # (in cycle order)
|
|
|
|
# Candidates have 8 neighbors and are known black
|
|
@cand = grep { $black[$_] } map { my $x = $_; map $_*$h + $x, 1..$v-2 } 1..$h-2;
|
|
|
|
do {
|
|
sub seewhite {
|
|
my($w1,$w2) = @_;
|
|
my(@results);
|
|
sub cycles { my(@neighbors)=@_; my $c; $c += $neighbors[$_] < $neighbors[($_+1)%8] for 0..$#neighbors; return $c }
|
|
sub blacks { my(@neighbors)=@_; sum @neighbors }
|
|
|
|
@prior = @cand; @cand = ();
|
|
for $p (@prior) {
|
|
@n = @black[map { $_+$p } @p8];
|
|
if (cycles(@n) == 1 and 2 <= sum(blacks(@n)) and sum(blacks(@n)) <= 6 and min(@n[@$w1]) == 0 and min(@n[@$w2]) == 0) {
|
|
push @results, $p;
|
|
} else {
|
|
push @cand, $p
|
|
}
|
|
}
|
|
return @results;
|
|
}
|
|
|
|
@goners1 = seewhite [0,2,4], [2,4,6]; @black[@goners1] = 0 x @goners1;
|
|
@goners2 = seewhite [0,2,6], [0,4,6]; @black[@goners2] = 0 x @goners2;
|
|
} until @goners1 == 0 and @goners2 == 0;
|
|
|
|
while (@black) { push @thinned, join '', qw<. #>[splice(@black,0,$h)] }
|
|
|
|
print join "\n", @thinned;
|