File Coverage

blib/lib/Algorithm/QuadTree.pm

Criterion	Covered	Total	%
statement	77	82	93.9
branch	15	20	75.0
condition	3	5	60.0
subroutine	17	18	94.4
pod	9	9	100.0
total	121	134	90.3

package Algorithm::QuadTree;
$Algorithm::QuadTree::VERSION = '1.0';
use strict;
use warnings;
use Carp;

###############################
#
# Creating a new QuadTree objects automatically
# segments the given area into quadtrees of the
# specified depth.
#
# Arguments are a hash:
#
# -xmin  => minimum x value
# -xmax  => maximum x value
# -ymin  => minimum y value
# -ymax  => maximum y value
# -depth => depth of tree
#
###############################

my $backend;
BEGIN {
	require Algorithm::QuadTree::PP;
	$backend = 'Algorithm::QuadTree::PP';

	my $backend_requested = defined $ENV{ALGORITHM_QUADTREE_BACKEND};
	my $check_backend = $ENV{ALGORITHM_QUADTREE_BACKEND} || 'Algorithm::QuadTree::XS';
	if (eval "require $check_backend; 1;") {
		$backend = $check_backend;
	}
	elsif ($backend_requested) {
		die $@;
	}

	$backend->import;
}

# List::Util 1.45 added 'uniqstr'
use constant HAS_LIST_UTIL => eval { require List::Util; List::Util->VERSION('1.45'); 1 };
use constant BACKEND_UNIQUE_RESULTS => $backend->can('UNIQUE_RESULTS') ? $backend->UNIQUE_RESULTS : 0;

sub new
{
	my $self  = shift;
	my $class = ref($self) || $self;
	my %args = @_;

	my $obj = bless {}, $class;

	for my $arg (keys %args) {
		if ($arg =~ s{^-}{}) {
			$obj->{uc $arg} = $args{"-$arg"};
		}
	}

	for my $arg (qw/xmin ymin xmax ymax depth/) {
		unless (exists $obj->{uc $arg}) {
			carp "- must specify $arg";
			return undef;
		}
	}


	$obj->{ORIGIN} = [0, 0];
	$obj->{SCALE} = 1;

	_AQT_init($obj);

	return $obj;
}

sub DESTROY
{
	my ($self) = @_;

	_AQT_deinit($self);
}

# modify coords according to window
sub _adjustCoords
{
	my ($self, @coords) = @_;

	if (@coords == 4) {
		# rectangle

		$_ = $self->{ORIGIN}[0] + $_ / $self->{SCALE}
			for $coords[0], $coords[2];
		$_ = $self->{ORIGIN}[1] + $_ / $self->{SCALE}
			for $coords[1], $coords[3];
	}
	elsif (@coords == 3) {
		# circle

		$coords[0] = $self->{ORIGIN}[0] + $coords[0] / $self->{SCALE};
		$coords[1] = $self->{ORIGIN}[1] + $coords[1] / $self->{SCALE};
		$coords[2] /= $self->{SCALE};
	}

	return @coords;
}

sub add
{
	my ($self, $object, @coords) = @_;

	# assume that $object is unique.
	# assume coords are (xmin, ymix, xmax, ymax) or (centerx, centery, radius)

	@coords = $self->_adjustCoords(@coords)
		unless $self->{SCALE} == 1;

	_AQT_addObject($self, $object, @coords);

	return;
}

sub delete
{
	my ($self, $object) = @_;

	_AQT_delete($self, $object);

	return;
}

sub clear
{
	my $self = shift;

	_AQT_clear($self);

	return;
}

sub get
{
	my ($self, @coords) = @_;

	@coords = $self->_adjustCoords(@coords)
		unless $self->{SCALE} == 1;

	$self->{CHECK} = 1;
	if (BACKEND_UNIQUE_RESULTS) {
		return _AQT_findObjects($self, @coords);
	}
	else {
		return _uniq(_AQT_findObjects($self, @coords));
	}
}

sub getEnclosedObjects
{
	my ($self, @coords) = @_;

	@coords = $self->_adjustCoords(@coords)
		unless $self->{SCALE} == 1;

	$self->{CHECK} = 0;
	if (BACKEND_UNIQUE_RESULTS) {
		return _AQT_findObjects($self, @coords);
	}
	else {
		return _uniq(_AQT_findObjects($self, @coords));
	}
}

sub getApprox
{
	goto \&getEnclosedObjects;
}

sub setWindow
{
	my ($self, $sx, $sy, $s) = @_;

	$self->{ORIGIN}[0] += $sx / $self->{SCALE};
	$self->{ORIGIN}[1] += $sy / $self->{SCALE};
	$self->{SCALE} *= $s;
}

sub resetWindow
{
	my $self = shift;

	$self->{ORIGIN}[$_] = 0 for 0 .. 1;
	$self->{SCALE} = 1;
}

# HELPERS
# not called in object context

sub _uniq
{
	if (HAS_LIST_UTIL) {
		return [ List::Util::uniqstr(@{$_[0]}) ];
	}
	else {
		my %temp = map { $_ => $_ } @{$_[0]};
		return [ values %temp ];
	}
}

1;

__END__