File Coverage

lib/Geo/ShapeFile/Shape/Index.pm

Criterion	Covered	Total	%
statement	71	75	94.6
branch	5	8	62.5
condition	3	4	75.0
subroutine	13	16	81.2
pod	9	9	100.0
total	101	112	90.1

package Geo::ShapeFile::Shape::Index;
#use 5.010;  #  not yet
use strict;
use warnings;
use POSIX qw /floor/;
use Carp;
use autovivification;

our $VERSION = '3.00';

#  should also handle X cells
sub new {
    my ($class, $n, $x_min, $y_min, $x_max, $y_max) = @_;

    my $self = bless {}, $class;

    $n ||= 10;  #  need a better default?
    $n   = int $n;
    die 'Number of blocks must be positive and >=1'
      if $n <= 0;

    my $y_range = abs ($y_max - $y_min);
    my $y_tol   = $y_range / 1000;
    $y_range   += 2 * $y_tol;
    $y_min     -= $y_tol;
    $y_max     += $y_tol;

    my $block_ht = $y_range / $n;

    $self->{x_min} = $x_min;
    $self->{y_min} = $y_min;
    $self->{x_max} = $x_max;
    $self->{y_max} = $y_max;
    $self->{y_res} = $block_ht;
    $self->{y_n}   = $n;
    $self->{x_n}   = 1;

    my %blocks;
    my $y = $y_min;
    foreach my $i (1 .. $n) {
        my $key = $self->snap_to_index($x_min, $y);  #  index by lower left
        $blocks{$key} = [];
        $y += $block_ht;
    }
    $self->{containers} = \%blocks;

    return $self;
}

sub get_x_min {$_[0]->{x_min}}
sub get_x_max {$_[0]->{x_max}}
sub get_y_min {$_[0]->{y_min}}
sub get_y_max {$_[0]->{y_max}}
sub get_y_res {$_[0]->{y_res}}

#  return an anonymous array if we are out of the index bounds
sub _get_container_ref {
    my ($self, $id) = @_;

    no autovivification;

    my $containers = $self->{containers};
    my $container  = $containers->{$id} || [];

    return $container;
};

#  need to handle X coords as well
sub snap_to_index {
    my ($self, $x, $y) = @_;

    #my $x_min = $self->get_x_min;
    my $y_min = $self->get_y_min;
    my $y_res = $self->get_y_res;

    #  take the floor, but add a small tolerance to
    #  avoid precision issues with snapping
    my $partial = ($y - $y_min) / $y_res;
    my $y_block = floor ($partial * 1.001);

    return wantarray ? (0, $y_block) : "0:$y_block";
}

#  inserts into whichever blocks overlap the bounding box
sub insert {
    my ($self, $item, @bbox) = @_;

    my @index_id1 = $self->snap_to_index (@bbox[0, 1]);
    my @index_id2 = $self->snap_to_index (@bbox[2, 3]);

    my $insert_count = 0;
    foreach my $y ($index_id1[1] .. $index_id2[1]) {
        my $index_id  = "0:$y";  #  hackish
        my $container = $self->_get_container_ref ($index_id);
        push @$container, $item;
        $insert_count++;
    }

    return $insert_count;
}

#  $storage ref arg is for Tree::R compat - still needed?
sub query_point {
    my ($self, $x, $y, $storage_ref) = @_;

    my $index_id  = $self->snap_to_index ($x, $y);
    my $container = $self->_get_container_ref ($index_id);

    if ($storage_ref) {
        push @$storage_ref, @$container;
    }

    return wantarray ? @$container : [@$container];
}


1;

__END__