view release on metacpan or  search on metacpan

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

package Algorithm::QuadTree::PP;
$Algorithm::QuadTree::PP::VERSION = '0.5';
use strict;
use warnings;
use Exporter qw(import);

use Scalar::Util qw(weaken);

our @EXPORT = qw(
	_AQT_init
	_AQT_deinit
	_AQT_addObject
	_AQT_findObjects
	_AQT_delete
	_AQT_clear
);

# recursive method which adds levels to the quadtree
sub _addLevel
{
	my ($self, $depth, $parent, @coords) = @_;
	my $node = {
		PARENT => $parent,
		HAS_OBJECTS => 0,
		AREA => \@coords,
	};

	weaken $node->{PARENT} if $parent;

	if ($depth < $self->{DEPTH}) {
		my ($xmin, $ymin, $xmax, $ymax) = @coords;
		my $xmid = $xmin + ($xmax - $xmin) / 2;
		my $ymid = $ymin + ($ymax - $ymin) / 2;
		$depth += 1;

		# segment in the following order:
		# top left, top right, bottom left, bottom right
		$node->{CHILDREN} = [
			_addLevel($self, $depth, $node, $xmin, $ymid, $xmid, $ymax),
			_addLevel($self, $depth, $node, $xmid, $ymid, $xmax, $ymax),
			_addLevel($self, $depth, $node, $xmin, $ymin, $xmid, $ymid),
			_addLevel($self, $depth, $node, $xmid, $ymin, $xmax, $ymid),
		];
	}
	else {
		# leaves must have empty aref in objects
		$node->{OBJECTS} = [];
	}

	return $node;
}

# this private method executes $code on every leaf node of the tree
# which is within the circular shape
sub _loopOnNodesInCircle
{
	my ($self, $finding, @coords) = @_;

	# avoid squaring the radius on each iteration
	my $radius_squared = $coords[2] ** 2;

	my @nodes;
	my @loopargs = $self->{ROOT};
	while (my $current = shift @loopargs) {
		next if $finding && !$current->{HAS_OBJECTS};

		my ($cxmin, $cymin, $cxmax, $cymax) = @{$current->{AREA}};

		my $cx = $coords[0] < $cxmin
			? $cxmin
			: $coords[0] > $cxmax
				? $cxmax
				: $coords[0]
		;

		my $cy = $coords[1] < $cymin
			? $cymin
			: $coords[1] > $cymax
				? $cymax
				: $coords[1]
		;

		# first check if obj overlaps current segment.
		next if ($coords[0] - $cx) ** 2 + ($coords[1] - $cy) ** 2
			> $radius_squared;

		$current->{HAS_OBJECTS} = 1 if !$finding;
		if ($current->{CHILDREN}) {