view release on metacpan or  search on metacpan

lib/Algorithm/QuadTree.pm  view on Meta::CPAN

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)