Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!/usr/bin/perl -w # # drawmap - spot the monk! # Briac 'OeufMayo' Pilpré # 2001/06/15 # munged by Max 'Corion' Maischein # 2001/06/17 # Great earth maps available from http://apollo.spaceports.com/~jhasti +ng/earth.html # A jcwren's monkmap compliant map can be found at # http://www.pilpre.com/briac/small_earth.jpg # jcwren's monks.xml file available at: # http://www.tinymicros.com/pm/monks.xml #drawmap.pl -i=northam10k.jpg -o=monkmap_northam.jpg -x=-1280 -y=-896 + -m ./monks.xml -d cross.png -w 10800 -h 5400 #drawmap.pl -i=europe10k.jpg -o=monkmap_europe.jpg -x=-4880 -y=-695 + -m ./monks.xml -d cross.png -w 10800 -h 5400 -H monkmap_europe.html #drawmap.pl -i=small_earth.jpg -o=monkmap_world.jpg -x=-25 -y=-3 + -m ./monks.xml -d cross.png -C use strict; use lib 'lib/'; use vars qw($VERSION); $VERSION = 0.04; use XML::Simple; use Getopt::Mixed 'nextOption'; use GD; Getopt::Mixed::init('C:i i=s o=s d=s w=i h=i x:i y:i m=s H=s xml>m dot +>d width>w height>h input>i output>o offsetx>x offsety>y nocaption>C +html>H'); # Fetch the command line parameters my ($input, $output, $offsetx, $offsety, $dot, $xml, $width, $height, +$nocaption, $html); while (my ($option, $value, $pretty) = nextOption()) { $input = $value if $option eq 'i'; $output = $value if $option eq 'o'; $offsetx = $value if $option eq 'x'; $offsety = $value if $option eq 'y'; $xml = $value if $option eq 'm'; $dot = $value if $option eq 'd'; $width = $value if $option eq 'w'; $height = $value if $option eq 'h'; $nocaption = 1 if $option eq 'C'; if ($option eq 'H') { $html = $value; $nocaption = 0; }; } Getopt::Mixed::cleanup(); &usage unless ($input && $output); $offsetx ||= 0; $offsety ||= 0; my (%monks, %href); # Parse the monks coordinates XML file I fetched from jcwren's stats s +ite. # ( code to fetch & create the XML is available on request ) my $xs = new XML::Simple(); my $ref = $xs->XMLin($xml); # Fill the monks hash with their respective locations foreach (keys %{$ref->{monk}}){ push (@{$monks{$_}}, ( $ref->{monk}->{$_}->{location}->{latitude}, $ref->{monk}->{$_}->{location}->{longitude}, )); } # Load the pictures we need. my $map = GD::Image->newFromJpeg($input); my $flag = GD::Image->newFromPng($dot); my $white = $map->colorResolve(255,255,255); my $black = $map->colorResolve(0,0,0); unless ($width && $height){ ($width, $height) = $map->getBounds(); } my %points; #keep track of the points for managing monks density my %boxes; #keep track of the caption bounding boxes # First, lets filter out all monks not on the map : my ($img_width,$img_height) = $map->getBounds(); my @monks_off_map = grep { my ($x,$y) = coord2pix($monks{$_}->[0],$monks{$_}->[1], $width, $height); # Tweak the x/y to fit the picture $x += $offsetx; $y += $offsety; # We want only the off-map monks : ! (between(0,$width-$offsetx, $x) && between(0,$heigh +t-$offsety,$y)) || ! (between(0,$img_width, $x) && between(0,$img_height +,$y)); } keys %monks; foreach (@monks_off_map) { delete $monks{$_}; }; # Now, we want to place all position markers : my $f = 6; # "closeness" factor foreach (keys %monks){ # Convert the lat/long to x/y my ($x,$y) = coord2pix($monks{$_}->[0],$monks{$_}->[1], $width, $height); # Tweak the x/y to fit the picture $x += $offsetx; $y += $offsety; $points{$_} = [$x-$f, $y-$f, $x+$f, $y+$f]; # store the current + pos $boxes{"__$_"} = [$x-$f, $y-$f, $x+$f, $y+$f]; # store the current + pos of the bbox # Pinpoints the monk location on the map $map->copy($flag, $x, $y, 0,0,7,7); }; foreach (keys %monks){ # Convert the lat/long to x/y my ($x,$y) = coord2pix($monks{$_}->[0],$monks{$_}->[1], $width, $height); # Tweak the x/y to fit the picture $x += $offsetx; $y += $offsety; # Let's find if we have a monk close to the current one unless ($nocaption){ my ($x1,$y1); my ($radius, $angle) = (10,0); my $textl = 7 * length($_); #length of the caption # Create a box for the label my @box = (int($x-$textl/2), $y-17, int($x+$textl/2), $y-18+13 +); if (find_density(\%points, $_, $x,$y) || # If true the mo +nk is too close find_intersect(\%boxes, $_, @box) # or the place has b +een taken already ) { CLOSE :{ $radius += 5; $angle += 10 % 360; # Find a point on a circle. # provided by CheeseLord: (x+r cos a, y+r sin a) ($x1,$y1)=(int($x + ($radius * cos $angle)), int($y+($radi +us * sin $angle))); # Move the label @box = (int($x1-$textl/2), $y1, int($x1+$textl/2), $y1+13) +; # Check to see if it intersects with a previous caption redo CLOSE if find_intersect(\%boxes, $_, @box); $map->line($x+4, $y+4, $x1+4, $y1+4, $white); $map->string(gdMediumBoldFont, $x1 - $textl/2 + 2, $y1, $_ +, $black); $map->string(gdMediumBoldFont, $x1 - $textl/2 + 3, $y1, $_ +, $white); } } else { $map->string(gdMediumBoldFont, int($x - $textl/2)+1, $y-17 +, $_, $black); $map->string(gdMediumBoldFont, int($x - $textl/2), $y-18 +, $_, $white); } $boxes{$_} = [@box]; } } # We now save our masterpiece on a storage device open JPGOUT, "> $output" or die $!; binmode JPGOUT; print JPGOUT $map->jpeg(75); if ($html){ open HTML, "> $html" or die $!; print HTML <<"__HTML__"; <html> <head> <title>drawmap - $output</title> </head> <body> <h1>drawmap - $output</h1> <p><img border="0" src="$output" usemap="#drawmap" alt="$outpu +t" /></p> <map name="drawmap"> __HTML__ foreach (keys %boxes){ print HTML qq'\t\t<area '; print HTML 'coords="', join( ',', @{$boxes{$_}} ), '" '; s/^__//; print HTML qq'href="http://www.perlmonks.org/index.pl?node=$_" sha +pe="rect" alt="$_" />\n'; } print HTML '</map>\n</body>\n</html>'; } sub between { my ($a1,$a2,$b) = @_; return ($a1 <= $b) && ($b <= $a2); }; sub point_in_rectangle { my ($left,$top,$right,$bottom,$x,$y) = @_; return between($left,$right,$x) && between($top,$bottom,$y) }; sub rectangles_intersect { my ($a_lft,$a_top,$a_rgt,$a_btm,$b_lft,$b_top,$b_rgt,$b_btm) = @_; return ( # One of the four corners within the other rectangle point_in_rectangle($a_lft,$a_top,$a_rgt,$a_btm,$b_lft,$b_t +op) || point_in_rectangle($a_lft,$a_top,$a_rgt,$a_btm,$b_rgt,$b_t +op) || point_in_rectangle($a_lft,$a_top,$a_rgt,$a_btm,$b_lft,$b_b +tm) || point_in_rectangle($a_lft,$a_top,$a_rgt,$a_btm,$b_rgt,$b_b +tm) || point_in_rectangle($b_lft,$b_top,$b_rgt,$b_btm,$a_lft,$a_t +op) || point_in_rectangle($b_lft,$b_top,$b_rgt,$b_btm,$a_rgt,$a_t +op) || point_in_rectangle($b_lft,$b_top,$b_rgt,$b_btm,$a_lft,$a_b +tm) || point_in_rectangle($b_lft,$b_top,$b_rgt,$b_btm,$a_rgt,$a_b +tm) || # Or an intersection where no corner is within the other r +ectangle ( between( $a_lft, $a_rgt, $b_lft ) && between( $a_lft, $a_rgt, $b_rgt ) && between( $b_top, $b_btm, $a_top ) && between( $b_top, $b_btm, $a_btm ) ) || ( between( $b_lft, $b_rgt, $a_lft ) && between( $b_lft, $b_rgt, $a_rgt ) && between( $a_top, $a_btm, $b_top ) && between( $a_top, $a_btm, $b_btm ) ) ); }; sub find_intersect { my $boxes = shift; my $current = shift; my ($a_lft,$a_top, $a_rgt, $a_btm) = @_; my $overlap; foreach (keys %{$boxes}){ next if $_ eq $current; next if $_ eq "__$current"; # The own location marker +is never "too close" my ($b_lft,$b_top, $b_rgt, $b_btm) = @{$boxes->{$_}}; # Collison tests provided by Corion. I probably left some out. if (rectangles_intersect($a_lft,$a_top,$a_rgt,$a_btm,$b_lft,$b +_top,$b_rgt,$b_btm)){ $overlap++; last; } } return $overlap; } sub find_density { my $dens = shift; my $current = shift; my ($x,$y) = @_; my $too_close; foreach (keys %{$dens}){ next if $_ eq $current; my ($x1,$y1,$x2,$y2) = @{$dens->{$_}}; if (point_in_rectangle($x1,$y1,$x2,$y2, $x,$y)){ $too_close++; last; } } return $too_close; } sub coord2pix { # Convert the lat/long to their actual coordinates in the # picture (thanks to jcwren for the tips!) my ($lat, $long, $width, $height) = @_; my $x = $width / 2 + ($long / 360 * $width); my $y = $height / 2 - ($lat / 180 * $height); return ( int $x, int $y ); } sub usage { print STDERR <<"__USAGE__"; drawmap - v.$VERSION perl drawmap.pl -i inputfile.jpg -o outputfile.jpg -m ./locat.xml -d +dot.png Required arguments: -i --input : Name of the map base. -o --output : Name of the output file created by drawmap -d --dot : Location of the png used as location marker -m --xml : Location of the xml coordinates file Optional arguments: -x --offsetx : Offset of the x axis -y --offsety : Offset of the y axis -C --nocaption : Does not draw the caption above the marker -H --html : Generate a HTML with an IMAGEMAP (cancels the -C) requires the name of the html file to create -w --width : Width of the original whole earth map (useful when zoo +ming) -h --height : Height of the original whole earth map __USAGE__ die "\n"; } __DATA__ <!-- monks.xml DTD --> <!ELEMENT monkmap (monk+)> <!ATTLIST monk source CDATA #REQUIRED> <!ELEMENT monk (name, location)> <!ATTLIST monk id CDATA #REQUIRED> <!ELEMENT name (#PCDATA)> <!ELEMENT location (latitude, longitude)> <!ELEMENT latitude (#PCDATA)> <!ELEMENT longitude (#PCDATA)>

In reply to drawmap.pl by OeufMayo

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others taking refuge in the Monastery: (7)
    As of 2014-10-23 22:12 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      For retirement, I am banking on:










      Results (129 votes), past polls