view release on metacpan or  search on metacpan

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

package Algorithm::SpatialIndex::Strategy::QuadTree;
use 5.008001;
use strict;
use warnings;
use Carp qw(croak);

use parent 'Algorithm::SpatialIndex::Strategy::2D';

# Note that the subnode indexes are as follows:
# (like quadrants in planar geometry)
#
# /---\
# |1|0|
# |-+-|
# |2+3|
# \---/
#

use constant {
  XI               => 1, # item X coord index
  YI               => 2, # item Y coord index

  XLOW             => 0, # for access to node coords
  YLOW             => 1,
  XUP              => 2,
  YUP              => 3,
  XSPLIT           => 4,
  YSPLIT           => 5,

  UPPER_RIGHT_NODE => 0,
  UPPER_LEFT_NODE  => 1,
  LOWER_LEFT_NODE  => 2,
  LOWER_RIGHT_NODE => 3,
};

use Exporter 'import';
our @EXPORT_OK = qw(
  XI
  YI

  XLOW
  YLOW
  XUP
  YUP
  XSPLIT
  YSPLIT

  UPPER_RIGHT_NODE
  UPPER_LEFT_NODE
  LOWER_LEFT_NODE
  LOWER_RIGHT_NODE
);
our %EXPORT_TAGS = ('all' => \@EXPORT_OK);

use Class::XSAccessor {
  getters => [qw(
    top_node_id
    bucket_size
    max_depth
    total_width
  )],
};

sub coord_types { qw(double double double double double double) }

sub init {
  my $self = shift;

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

          # sufficient space in bucket. Insert and return
          $bucket->add_items([$id, $x, $y]);
          $storage->store_bucket($bucket);
          return();
        }
        # check whether we've reached the maximum depth of the tree
        # and ignore bucket size if necessary
        # ( total width / local width ) = 2^( depth )
        elsif ($nxy->[XUP] - $nxy->[XLOW] <= 0.
               or log($self->total_width / ($nxy->[XUP]-$nxy->[XLOW])) / log(2) >= $self->max_depth)
        {
          # bucket at the maximum depth. Insert and return
          $bucket->add_items([$id, $x, $y]);
          $storage->store_bucket($bucket);
          return();
        }
        else {
          # bucket full, need to add new layer of nodes and split the bucket
          $self->_split_node($node, $bucket);
          # refresh data that will have changed:
          $node = $storage->fetch_node($node->id); # has updated subnode ids
          $subnodes = $node->subnode_ids;
          # Now we just continue with the normal subnode checking below:
        }
      }
    } # end scope

    my $subnode_index;
    if ($x <= $nxy->[XSPLIT]) {
      if ($y <= $nxy->[YSPLIT]) { $subnode_index = LOWER_LEFT_NODE }
      else                      { $subnode_index = UPPER_LEFT_NODE }
    }
    else {
      if ($y <= $nxy->[YSPLIT]) { $subnode_index = LOWER_RIGHT_NODE }
      else                      { $subnode_index = UPPER_RIGHT_NODE }
    }

    if (not defined $subnodes->[$subnode_index]) {
      die("Cannot find subnode $subnode_index if node id=".$node->id);
    }
    else {
      my $subnode = $storage->fetch_node($subnodes->[$subnode_index]);
      die("Need node '" .$subnodes->[$subnode_index] . '", but it is not in storage!')
        if not defined $subnode;
      return $self->_insert($id, $x, $y, $subnode, $storage);
    }
  }
} # end SCOPE

sub _node_split_coords {
  # args: $self, $node, $bucket, $coords
  my $c = $_[3];
  return( ($c->[0]+$c->[2])/2, ($c->[1]+$c->[3])/2 );
}


# Splits the given node into four new nodes of equal
# size and assigns the items
sub _split_node {
  my $self        = shift;
  my $parent_node = shift;
  my $bucket      = shift; # just for speed, can be taken from parent_node

  my $storage = $self->storage;
  my $parent_node_id = $parent_node->id;
  $bucket = $storage->fetch_bucket($parent_node_id) if not defined $bucket;

  my $coords = $parent_node->coords;
  my ($splitx, $splity) = $self->_node_split_coords($parent_node, $bucket, $coords);
  @$coords[XSPLIT, YSPLIT] = ($splitx, $splity); # stored below
  my @child_nodes;

  # UPPER_RIGHT_NODE => 0
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$splitx, $splity, $coords->[XUP], $coords->[YUP], undef, undef],
    subnode_ids => [],
  );
  # UPPER_LEFT_NODE => 1
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$coords->[XLOW], $splity, $splitx, $coords->[YUP], undef, undef],
    subnode_ids => [],
  );
  # LOWER_LEFT_NODE => 2
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$coords->[XLOW], $coords->[YLOW], $splitx, $splity, undef, undef],
    subnode_ids => [],
  );
  # LOWER_RIGHT_NODE => 3
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$splitx, $coords->[YLOW], $coords->[XUP], $splity, undef, undef],
    subnode_ids => [],
  );

  # save nodes
  my $snode_ids = $parent_node->subnode_ids;
  foreach my $cnode (@child_nodes) {
    push @{$snode_ids}, $storage->store_node($cnode);
  }
  $storage->store_node($parent_node);

  # split bucket
  my $items = $bucket->items;
  my @child_items = ([], [], [], []);
  foreach my $item (@$items) {
    if ($item->[XI] <= $splitx) {
      if ($item->[YI] <= $splity) { push @{$child_items[LOWER_LEFT_NODE]}, $item }
      else                        { push @{$child_items[UPPER_LEFT_NODE]}, $item }
    }
    else {
      if ($item->[YI] <= $splity) { push @{$child_items[LOWER_RIGHT_NODE]}, $item }
      else                        { push @{$child_items[UPPER_RIGHT_NODE]}, $item }
    }
  }
  
  # generate buckets
  foreach my $subnode_idx (0..3) {
    $self->_make_bucket_for_node(
      $child_nodes[$subnode_idx],
      $storage,
      $child_items[$subnode_idx]
    );
  }

  # remove the parent node's bucket
  $storage->delete_bucket($bucket);
}

sub _make_bucket_for_node {
  my $self = shift;
  my $node_id = shift;
  my $storage = shift || $self->storage;
  my $items = shift || [];
  $node_id = $node_id->id if ref $node_id;

  my $b = $storage->bucket_class->new(
    node_id => $node_id,
    items   => $items,
  );
  $storage->store_bucket($b);
}


sub find_node_for {
  my ($self, $x, $y) = @_;
  my $storage = $self->storage;
  my $topnode = $storage->fetch_node($self->top_node_id);
  my $coords = $topnode->coords;

  # boundary check
  if ($x < $coords->[XLOW]
      or $x > $coords->[XUP]
      or $y < $coords->[YLOW]
      or $y > $coords->[YUP]) {
    return undef;
  }

  return $self->_find_node_for($x, $y, $storage, $topnode);
}

# TODO: This is almost trivial to rewrite in non-recursive form
SCOPE: {
  no warnings 'recursion';
  sub _find_node_for {
    my ($self, $x, $y, $storage, $node) = @_;

    my $snode_ids = $node->subnode_ids;
    return $node if not @$snode_ids;

    # find the right sub node
    my ($splitx, $splity) = @{$node->coords}[XSPLIT, YSPLIT];
    my $subnode_id;
    if ($x <= $splitx) {
      if ($y <= $splity) { $subnode_id = $snode_ids->[LOWER_LEFT_NODE] }
      else               { $subnode_id = $snode_ids->[UPPER_LEFT_NODE] }
    }
    else {
      if ($y <= $splity) { $subnode_id = $snode_ids->[LOWER_RIGHT_NODE] }
      else               { $subnode_id = $snode_ids->[UPPER_RIGHT_NODE] }
    }

    my $snode = $storage->fetch_node($subnode_id);
    return $self->_find_node_for($x, $y, $storage, $snode);
  }
} # end SCOPE