File Coverage

blib/lib/Image/WorldMap.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Image::WorldMap;
use strict;
use warnings;
use Carp;
use Image::Imlib2;
use Image::WorldMap::Label;
use vars qw($VERSION);
$VERSION = '0.15';

# Class method, creates a new map
sub new {
    my ( $class, $filename, $label ) = @_;

    my $self = {};

    my $image = Image::Imlib2->load($filename);
    if ( not defined $image ) {
        croak("Image::WorldMap: unable to load $filename");
        return;
    }
    my $w = $image->get_width;
    my $h = $image->get_height;
    $image->add_font_path("../");
    $image->add_font_path("examples/");

    $self->{IMAGE}  = $image;
    $self->{LABELS} = [];
    $self->{LABEL}  = $label;
    $self->{W}      = $w;
    $self->{H}      = $h;
    bless $self, $class;

    if ( defined $label ) {

        # Determine the label offset for the current font
        $image->load_font($label);
        my $testlabel
            = Image::WorldMap::Label->new( 0, 0,
            "This is a testy little label",
            $self->{IMAGE} );
        my ( $w, $h )
            = $testlabel->_boundingbox( $image,
            "This is a testy little label" );
        $Image::WorldMap::Label::YOFFSET = -int( $h / 2 );
        $Image::WorldMap::Label::XOFFSET = 4;
    }

    return $self;
}

sub add {
    my ( $self, $longitude, $latitude, $label, $dot_colour ) = @_;

    my ( $w, $h ) = ( $self->{W}, $self->{H} );
    $w /= 2;

    my $x = $longitude;
    my $y = $latitude;

    $x = $x * $w / 180;
    $y = $y * $h / 180;
    $y = -$y;
    $x += $w;
    $y += ( $h / 2 );

    #  print "Adding: $label at $longitude, $latitude ($x, $y)\n";

    # If we're not showing labels, delete the label
    undef $label unless $self->{LABEL};

    my $newlabel = Image::WorldMap::Label->new( int($x), int($y), $label,
        $self->{IMAGE}, $dot_colour );
    push @{ $self->{LABELS} }, $newlabel;
}

sub draw {
    my ( $self, $filename ) = @_;

    my $t_changes            = 0;
    my $t                    = 0.95;
    my $nlabels              = @{ $self->{LABELS} };
    my $changed              = 0;
    my $changed_successfully = 0;
    my $steps                = 0;

    my @labels   = ( @{ $self->{LABELS} } );
    my $overlaps = $self->_number_of_overlaps;

    #  warn "Initial overlaps: $overlaps\n";

    while (1) {

        last if $overlaps == 0;

        _fisher_yates_shuffle( \@labels );

        foreach my $l1 (@labels) {

            last if $overlaps == 0;

            my ( $l1x, $l1y, $l1w, $l1h )
                = ( $l1->{X}, $l1->{Y}, $l1->{LABELW}, $l1->{LABELH} );

            my ( $oldlabelx, $oldlabely ) = ( $l1->{LABELX}, $l1->{LABELY} );
            my $old_overlaps_single = $self->_number_of_overlaps_single($l1)
                || 0;
            my $mode = int( rand(8) );
            if ( $mode == 0 ) {

                # right
                $l1->{LABELX} = $l1x + $Image::WorldMap::Label::XOFFSET;
                $l1->{LABELY} = $l1y + $Image::WorldMap::Label::YOFFSET;
            } elsif ( $mode == 1 ) {

                # left
                $l1->{LABELX}
                    = $l1x - $l1w - $Image::WorldMap::Label::XOFFSET;
                $l1->{LABELY} = $l1y + $Image::WorldMap::Label::YOFFSET;
            } elsif ( $mode == 2 ) {

                # top
                $l1->{LABELX} = $l1x - $l1w / 2;
                $l1->{LABELY} = $l1y - $l1h;
            } elsif ( $mode == 3 ) {

                # bottom
                $l1->{LABELX} = $l1x - $l1w / 2;
                $l1->{LABELY} = $l1y;
            } elsif ( $mode == 4 ) {

                # top right
                $l1->{LABELX} = $l1x;
                $l1->{LABELY} = $l1y - $l1h;
            } elsif ( $mode == 5 ) {

                # top left
                $l1->{LABELX} = $l1x - $l1w;
                $l1->{LABELY} = $l1y - $l1h;
            } elsif ( $mode == 6 ) {

                # bottom right
                $l1->{LABELX} = $l1x;
                $l1->{LABELY} = $l1y;
            } elsif ( $mode == 7 ) {

                # bottom left
                $l1->{LABELX} = $l1x - $l1w;
                $l1->{LABELY} = $l1y;
            }

            my $overlaps_single = $self->_number_of_overlaps_single($l1) || 0;
            my $de = $overlaps_single - $old_overlaps_single;

            $steps++;

            if ( $de <= 0 ) {
                if ( $de == 0 ) {
                } else {
                    $changed_successfully++;
                    $changed++;

                    #	  warn "  Moved " . $l1->{TEXT} . " $de\n";
                }
                $overlaps += $overlaps_single - $old_overlaps_single;
            } elsif ( $de > 0 ) {
                my $p = 1 - exp( -$de / $t );

                #	warn "T $t, p $p\n";
                if ( rand(1) < $p ) {

                    # move label back
                    $l1->{LABELX} = $oldlabelx;
                    $l1->{LABELY} = $oldlabely;
                } else {

                    #	  warn "  Moved " . $l1->{TEXT} . " $de (worse)\n";
                    $changed++;
                    $overlaps += $overlaps_single - $old_overlaps_single;
                }
            }
        }

        #    warn "Overlaps: $overlaps\n";

        if ( $steps > $nlabels * 20 && $changed == 0 ) {

            #      warn "No changes\n";
            last;
        }

        if (   $changed_successfully > $nlabels * 5
            || $changed > $nlabels * 20 )
        {
            $t *= 0.9;
            $t_changes++;
            $changed              = 0;
            $changed_successfully = 0;
            $steps                = 0;

            #      warn "T $t, overlaps $overlaps\n";
        }
        last if $t_changes == 50;
    }

    my $image = $self->{IMAGE};

    # Grey out label background
    #  foreach my $l1 (@{$self->{LABELS}}) {
    #    my($l1x, $l1y, $l1w, $l1h) =
    #      ($l1->labelx, $l1->labely, $l1->labelwidth, $l1->labelheight);
    #    $image->set_color(255, 255, 255, 32);
    #    $image->fill_rectangle($l1x, $l1y, $l1w, $l1h);
    #  }
    map { $_->draw_dot($image) } @{ $self->{LABELS} };
    map { $_->draw_label($image) } @{ $self->{LABELS} };

    $image->save($filename);
}

sub _draw_oldish {
    my ( $self, $filename ) = @_;

    my @labels   = ( @{ $self->{LABELS} } );
    my $overlaps = $self->_number_of_overlaps;

    foreach ( 1 .. 20 ) {
        foreach my $l1 (@labels) {
            my ( $l1x, $l1y, $l1w, $l1h )
                = ( $l1->{X}, $l1->{Y}, $l1->{LABELW}, $l1->{LABELH} );

            my ( $oldlabelx, $oldlabely ) = ( $l1->{LABELX}, $l1->{LABELY} );
            my $old_overlaps_single = $self->_number_of_overlaps_single($l1);
            my $mode                = int( rand(4) );
            if ( $mode == 0 ) {
                $l1->{LABELX} = $l1x + $Image::WorldMap::Label::XOFFSET;
                $l1->{LABELY} = $l1y + $Image::WorldMap::Label::YOFFSET;
            } elsif ( $mode == 1 ) {
                $l1->{LABELX}
                    = $l1x - $l1w - $Image::WorldMap::Label::XOFFSET;
                $l1->{LABELY} = $l1y + $Image::WorldMap::Label::YOFFSET;
            } elsif ( $mode == 2 ) {
                $l1->{LABELX} = $l1x - $l1w / 2;
                $l1->{LABELY} = $l1y - $l1h;
            } elsif ( $mode == 3 ) {
                $l1->{LABELX} = $l1x - $l1w / 2;
                $l1->{LABELY} = $l1y;
            }

            my $overlaps_single = $self->_number_of_overlaps_single($l1);
            if ( $overlaps_single > $old_overlaps_single ) {
                $l1->{LABELX} = $oldlabelx;
                $l1->{LABELY} = $oldlabely;
            } else {
                $overlaps += $overlaps_single - $old_overlaps_single;
            }
        }

        warn "Overlaps: $overlaps\n";
        last if $overlaps == 0;
    }

    my $image = $self->{IMAGE};

    #  foreach my $l1 (@{$self->{LABELS}}) {
    #    my($l1x, $l1y, $l1w, $l1h) =
    #      ($l1->labelx, $l1->labely, $l1->labelwidth, $l1->labelheight);
    #    $image->set_color(255, 255, 255, 32);
    #    $image->fill_rectangle($l1x, $l1y, $l1w, $l1h);
    #  }
    map { $_->draw_dot($image) } @{ $self->{LABELS} };
    map { $_->draw_label($image) } @{ $self->{LABELS} };

    $image->save($filename);
}

sub _number_of_overlaps_single {
    my ( $self, $l1 ) = @_;

    my $overlaps = 0;
    my @labels   = ( @{ $self->{LABELS} } );

    my $l1text = $l1->{TEXT};
    my ( $l1x, $l1y, $l1w, $l1h )
        = ( $l1->{LABELX}, $l1->{LABELY}, $l1->{LABELW}, $l1->{LABELH} );
    return unless $l1text;
    foreach my $l2 (@labels) {
        next if $l1 eq $l2;
        my $l2text = $l2->{TEXT};
        next unless $l2text;

        #      warn "Comparing $l1text against $l2text...\n";
        my ( $l2x, $l2y, $l2w, $l2h )
            = ( $l2->{LABELX}, $l2->{LABELY}, $l2->{LABELW}, $l2->{LABELH} );
        my $x = $l1x > $l2x ? $l1x : $l2x;
        my $y = $l1y > $l2y ? $l1y : $l2y;
        my $w
            = ( $l1x + $l1w < $l2x + $l2w ? $l1x + $l1w : $l2x + $l2w ) - $x;
        my $h
            = ( $l1y + $l1h < $l2y + $l2h ? $l1y + $l1h : $l2y + $l2h ) - $y;
        if ( $w > 0 && $h > 0 ) {
            $overlaps++;
        }
    }
    return $overlaps;
}

sub _number_of_overlaps {
    my ($self) = @_;
    my %seen;

    my $overlaps = 0;
    my @labels   = ( @{ $self->{LABELS} } );

    foreach my $l1 (@labels) {
        my ( $l1x, $l1y, $l1w, $l1h, $l1text ) = (
            $l1->{LABELX}, $l1->{LABELY}, $l1->{LABELW},
            $l1->{LABELH}, $l1->{TEXT}
        );
        next unless $l1text;
        foreach my $l2 (@labels) {
            next if $seen{$l1}{$l2}++;
            next if $seen{$l2}{$l1}++;
            next if $l1 eq $l2;
            my $l2text = $l2->{TEXT};
            next unless $l2text;

            #      warn "Comparing $l1text against $l2text...\n";
            my ( $l2x, $l2y, $l2w, $l2h )
                = ( $l2->{LABELX}, $l2->{LABELY}, $l2->{LABELW},
                $l2->{LABELH} );
            my $x = $l1x > $l2x ? $l1x : $l2x;
            my $y = $l1y > $l2y ? $l1y : $l2y;
            my $w = ( $l1x + $l1w < $l2x + $l2w ? $l1x + $l1w : $l2x + $l2w )
                - $x;
            my $h = ( $l1y + $l1h < $l2y + $l2h ? $l1y + $l1h : $l2y + $l2h )
                - $y;

            #      warn "Overlap: $w x $h\n";
            if ( $w > 0 && $h > 0 ) {

                #        warn "Overlaps!\n";
                $overlaps++;
            }

        }
    }
    return $overlaps;
}

# fisher_yates_shuffle( \@array ) :
# generate a random permutation of @array in place
sub _fisher_yates_shuffle {
    my $array = shift;
    my $i;
    for ( $i = @$array; --$i; ) {
        my $j = int rand( $i + 1 );
        @$array[ $i, $j ] = @$array[ $j, $i ];
    }
}

__END__