view release on metacpan or  search on metacpan

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

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

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

# Note that the subnode indexes are as follows:
# (like octants, http://en.wikipedia.org/wiki/Octant)
# After wikipedia:
#
#  0) first octant (+, +, +)
#  1) top-back-right (−, +, +)
#  2) top-back-left (−, −, +)
#  3) top-front-left (+, −, +)
#  4) bottom-front-left (+, −, −)
#  5) bottom-back-left (−, −, −)
#  6) bottom-back-right (−, +, −)
#  7) bottom-front-right (+, +, −)


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

  XLOW     => 0, # for access to node coords
  YLOW     => 1,
  ZLOW     => 2,
  XUP      => 3,
  YUP      => 4,
  ZUP      => 5,
  XSPLIT   => 6,
  YSPLIT   => 7,
  ZSPLIT   => 8,

  PPP_NODE => 0,
  MPP_NODE => 1,
  MMP_NODE => 2,
  PMP_NODE => 3,
  PMM_NODE => 4,
  MMM_NODE => 5,
  MPM_NODE => 6,
  PPM_NODE => 7,
};

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

  XLOW
  YLOW
  ZLOW
  XUP
  YUP
  ZUP
  XSPLIT
  YSPLIT
  ZSPLIT

  PPP_NODE
  MPP_NODE
  MMP_NODE
  PMP_NODE

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

        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 <= $nxyz->[XSPLIT]) {
      if ($y <= $nxyz->[YSPLIT]) {
        if ($z <= $nxyz->[ZSPLIT]) { $subnode_index = MMM_NODE }
        else                       { $subnode_index = MMP_NODE }
      }
      else { # $y > ysplit
        if ($z <= $nxyz->[ZSPLIT]) { $subnode_index = MPM_NODE }
        else                       { $subnode_index = MPP_NODE }
      }
    }
    else { # $x > xsplit
      if ($y <= $nxyz->[YSPLIT]) {
        if ($z <= $nxyz->[ZSPLIT]) { $subnode_index = PMM_NODE }
        else                       { $subnode_index = PMP_NODE }
      }
      else { # $y > ysplit
        if ($z <= $nxyz->[ZSPLIT]) { $subnode_index = PPM_NODE }
        else                       { $subnode_index = PPP_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, $z, $subnode, $storage);
    }
  }
} # end SCOPE

sub _node_split_coords {
  # args: $self, $node, $bucket, $coords
  my $c = $_[3];
  return(
    ($c->[XLOW]+$c->[XUP])/2,
    ($c->[YLOW]+$c->[YUP])/2,
    ($c->[ZLOW]+$c->[ZUP])/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, $splitz) = $self->_node_split_coords($parent_node, $bucket, $coords);
  @$coords[XSPLIT, YSPLIT, ZSPLIT] = ($splitx, $splity, $splitz); # stored below
  my @child_nodes;

  # PPP_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$splitx, $splity, $splitz,
                    $coords->[XUP], $coords->[YUP], $coords->[ZUP],
                    undef, undef, undef],
    subnode_ids => [],
  );
  # MPP_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$coords->[XLOW], $splity, $splitz,
                    $splitx, $coords->[YUP], $coords->[ZUP],
                    undef, undef, undef],
    subnode_ids => [],
  );
  # MMP_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$coords->[XLOW], $coords->[YLOW], $splitz,
                    $splitx, $splity, $coords->[ZUP],
                    undef, undef, undef],
    subnode_ids => [],
  );
  # PMP_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$splitx, $coords->[YLOW], $splitz,
                    $coords->[XUP], $splity, $coords->[ZUP],
                    undef, undef, undef],
    subnode_ids => [],
  );
  # PMM_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$splitx, $coords->[YLOW], $coords->[ZLOW],
                    $coords->[XUP], $splity, $splitz,
                    undef, undef, undef],
    subnode_ids => [],
  );
  # MMM_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$coords->[XLOW], $coords->[YLOW], $coords->[ZLOW],
                    $splitx, $splity, $splitz,
                    undef, undef, undef],
    subnode_ids => [],
  );
  # MPM_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$coords->[XLOW], $splity, $coords->[ZLOW],
                    $splitx, $coords->[YUP], $splitz,
                    undef, undef, undef],
    subnode_ids => [],
  );
  # PPM_NODE
  push @child_nodes, Algorithm::SpatialIndex::Node->new(
    coords      => [$splitx, $splity, $coords->[ZLOW],
                    $coords->[XUP], $coords->[YUP], $splitz,
                    undef, 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 = ( map [], @child_nodes );
  foreach my $item (@$items) {
    if ($item->[XI] <= $splitx) {
      if ($item->[YI] <= $splity) {
        if ($item->[ZI] <= $splitz) { push @{$child_items[MMM_NODE]}, $item }
        else                        { push @{$child_items[MMP_NODE]}, $item }
      }
      else { # $item->[YI] > ysplit
        if ($item->[ZI] <= $splitz) { push @{$child_items[MPM_NODE]}, $item }
        else                        { push @{$child_items[MPP_NODE]}, $item }
      }
    }
    else { # $item->[XI] > xsplit
      if ($item->[YI] <= $splity) {
        if ($item->[ZI] <= $splitz) { push @{$child_items[PMM_NODE]}, $item }
        else                        { push @{$child_items[PMP_NODE]}, $item }
      }
      else { # $item->[YI] > ysplit
        if ($item->[ZI] <= $splitz) { push @{$child_items[PPM_NODE]}, $item }
        else                        { push @{$child_items[PPP_NODE]}, $item }
      }
    }
  }
  
  # generate buckets
  foreach my $subnode_idx (0..$#child_nodes) {
    $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, $z) = @_;
  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]
      or $z < $coords->[ZLOW]
      or $z > $coords->[ZUP])
  {
    return undef;
  }

  return $self->_find_node_for($x, $y, $z, $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, $z, $storage, $node) = @_;

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

    # find the right sub node
    my ($xsplit, $ysplit, $zsplit) = @{$node->coords}[XSPLIT, YSPLIT, ZSPLIT];
    my $subnode_id;
    if ($x <= $xsplit) {
      if ($y <= $ysplit) {
        if ($z <= $zsplit) { $subnode_id = $snode_ids->[MMM_NODE] }
        else               { $subnode_id = $snode_ids->[MMP_NODE] }
      }
      else { # $y > ysplit
        if ($z <= $zsplit) { $subnode_id = $snode_ids->[MPM_NODE] }
        else               { $subnode_id = $snode_ids->[MPP_NODE] }
      }
    }