Beefy Boxes and Bandwidth Generously Provided by pair Networks
Come for the quick hacks, stay for the epiphanies.
 
PerlMonks  

Re: Distribute locations evenly on a map

by blokhead (Monsignor)
on Nov 30, 2009 at 23:48 UTC ( [id://810286]=note: print w/replies, xml ) Need Help??


in reply to Distribute locations evenly on a map

This reminds me of image resizing by seam carving, and I think the solution to your problem could be informed by theirs.

In their setting, they had an image and wanted to "squish" away "unimportant" parts during the resize, while maintaining the remaining image information. Their solution was to find "seams" in the image. A seam is a path between opposite edges of an image, using any combination of straight or diagonal moves (in this way, a seam is a "contiguous" strand of pixels but need not be simply a row or column). Their approach was to use a dynamic programming algorithm to find a seam whose removal would cause the least "disturbance" in an image.

Here, your solution could be even easier. You have an "image" made up of "." and non-"." pixels. You want to find and remove any horizontal or vertical seams made up of entirely "." pixels. This can also be done in a simple dynamic programming way.

#!/usr/bin/perl use strict; chomp( my @data = <DATA> ); $_ = [ split // ] for @data; do { print_map(\@data); print "=====\n"; } while (remove_vert_seam(\@data)); sub remove_vert_seam { my $data = shift; my $seam; my $rows = $#$data; my $cols = $#{ $data[0] }; for my $j (0 .. $cols) { $seam->[0][$j] = 0 if $data->[0][$j] eq "."; } # there is a seam from the top row to ($i,$j) # only if (i,j) has a "." and there is a seam from # the top row to any of (i-1,j-1), (i-1,j), (i-1,j+1) # if there is a seam, remember its predecessor so we # can trace it back. for my $i (1 .. $rows) { for my $j (0 .. $cols) { if ($data->[$i][$j] eq ".") { $seam->[$i][$j] = $j-1 if $j-1 >= 0 and defined $seam->[$i-1][$j-1]; $seam->[$i][$j] = $j if defined $seam->[$i-1][$j]; $seam->[$i][$j] = $j+1 if $j+1 <= $cols and defined $seam->[$i-1][$j+1]; } } } # if there is a seam to the bottom row, trace it back # to the top and remove all of the cells that are visited for my $j (0 .. $cols) { if (defined $seam->[$rows][$j]) { my $i = $rows; while ($i >= 0) { splice @{ $data->[$i] }, $j, 1; ($i,$j) = ($i-1, $seam->[$i][$j]); } return 1; } } return 0; } sub print_map { my $data = shift; for (@$data) { print join("", @$_), $/; } } __DATA__ XX... X.... ..... ....X ...XX
Output:
XX... X.... ..... ....X ...XX ===== XX.. X... .... ...X ..XX ===== XX. X.. ... ..X .XX ===== XX X. .. .X XX =====
It prints out the result after removing successive vertical seams, until no more can be removed.

If you applied the same approach and then went on to remove horizontal seams, you would get

XX XX. XX instead of X.X XX .XX
This is because the diagonal dots constitute a seam. From your example, it is possible that you have the following unwritten rule: If two X's do not start out adjacent, then they should not become adjacent as a result of seam removal. To accomplish this, you can simply add a "buffer" around the X's:
XX:.. X:... :.... ....X ...XX ===== XX:. X:.. :... ...X ..XX ===== XX: X:. :.. ..X .XX =====
I used ":" as the "buffer" -- You only need to add buffer space on the east & south sides of every initial "X", instead of around all sides. Adding buffer around all sides would prevent distant X's from getting squished to within 2 cells of each other. Now removing the horizontal seams as well would result in your example output.

Update: another example:

XXX:..........XX XXXX:....XX:...X X:.....XXX:..XXX XX:.....XXXX:.XX XXXXXXX.........
is squished to:
XXX:.......XX XXXX:..XX:..X X:...XXX:.XXX XX:...XXXX:XX XXXXXXX......
I didn't put a "south" buffer on, so the middle "island" gets squished to be adjacent to the stuff on the bottom-left.

blokhead

Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others browsing the Monastery: (6)
As of 2024-03-19 02:35 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found