view release on metacpan or  search on metacpan

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

  $self->{bucket_size} = $index->bucket_size if not defined $self->bucket_size;
  $self->{max_depth}   = $index->max_depth   if not defined $self->max_depth;

  $self->{top_node_id} = $storage->get_option('top_node_id');
  if (not defined $self->top_node_id) {
    # create a new top node and its bucket
    my $node = Algorithm::SpatialIndex::Node->new(
      coords => [
        $index->limit_x_low, $index->limit_y_low,
        $index->limit_x_up, $index->limit_y_up,
        undef, undef,
      ],
      subnode_ids => [],
    );
    $self->{top_node_id} = $storage->store_node($node);
    $self->_make_bucket_for_node($node, $storage);
  }

  $self->{total_width} = $index->limit_x_up - $index->limit_x_low;
}

sub insert {
  my ($self, $id, $x, $y) = @_;
  my $storage = $self->{storage}; # hash access due to hot path
  my $top_node = $storage->fetch_node($self->{top_node_id}); # hash access due to hot path
  return $self->_insert($id, $x, $y, $top_node, $storage);
}

SCOPE: {
  no warnings 'recursion';
  sub _insert {
    my ($self, $id, $x, $y, $node, $storage) = @_;
    my $nxy = $node->coords;
    my $subnodes = $node->subnode_ids;

    # If we have a bucket, we are the last level of nodes
    SCOPE: {
      my $bucket = $storage->fetch_bucket($node->id);
      if (defined $bucket) {
        if ($bucket->nitems < $self->{bucket_size}) {
          # 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 => [],