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;