File Coverage

blib/lib/Algorithm/SpatialIndex/Strategy/QuadTree.pm

Criterion	Covered	Total	%
statement	161	176	91.4
branch	39	52	75.0
condition	21	26	80.7
subroutine	22	23	95.6
pod	6	6	100.0
total	249	283	87.9

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;
}

sub init_storage {
  my $self = shift;
  my $index   = $self->index;
  my $storage = $self->storage;

  # stored bucket_size/max_depth for persistent indexes
  $self->{bucket_size} = $storage->get_option('bucket_size');
  $self->{max_depth}   = $storage->get_option('max_depth');
  # or use configured ones
  $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 => [],
  );
  # 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


sub find_nodes_for {
  my ($self, $x1, $y1, $x2, $y2) = @_;

  # normalize coords
  my ($xl, $xu) = $x1 < $x2 ? ($x1, $x2) : ($x2, $x1);
  my ($yl, $yu) = $y1 < $y2 ? ($y1, $y2) : ($y2, $y1);

  my $storage = $self->storage;
  my $topnode = $storage->fetch_node($self->top_node_id);
  my $coords = $topnode->coords;

  my $rv = [];
  _find_nodes_for($self, $xl, $yl, $xu, $yu, $storage, $topnode, $rv);
  return @$rv;
}

sub _find_nodes_for {
  my ($self, $xl, $yl, $xu, $yu, $storage, $node, $rv) = @_;

  my $coords = $node->coords;

  # boundary check
  if (   $xu < $coords->[XLOW]
      or $xl > $coords->[XUP]
      or $yu < $coords->[YLOW]
      or $yl > $coords->[YUP])
  {
    return;
  }

  my $snode_ids = $node->subnode_ids;
  if (not @$snode_ids) {
    # leaf
    push @$rv, $node;
    return;
  }

  # not a leaf
  foreach my $id (@$snode_ids) {
    $self->_find_nodes_for(
      $xl, $yl, $xu, $yu, $storage,
      $storage->fetch_node($id),
      $rv
    );
  }
}

# Returns the leaves for the given node
sub _get_all_leaf_nodes {
  my $self = shift;
  my $node = shift;
  my $storage = $self->storage;

  my @leaves;
  my @nodes = ($node);
  while (@nodes) {
    $node = shift @nodes;
    my $snode_ids = $node->subnode_ids;
    if (@$snode_ids) {
      push @nodes, map $storage->fetch_node($_), @$snode_ids;
    }
    else {
      push @leaves, $node;
    }
  }

  return @leaves;
}

1;
__END__