File Coverage

blib/lib/Tree/RedBlack/Node.pm

Criterion	Covered	Total	%
statement	47	56	83.9
branch	19	22	86.3
condition	0	3	0.0
subroutine	11	12	91.6
pod	9	10	90.0
total	86	103	83.5

package Tree::RedBlack::Node;

use strict;

=head1 NAME

Tree::RedBlack::Node - Node class for Perl implementation of Red/Black tree

=head1 SYNOPSIS

use Tree::RedBlack;
my $t = new Tree::RedBlack;
$t->insert(3, 'dog');
my $node = $t->node(3);
$animal = $node->val;

=head1 DESCRIPTION

A Tree::RedBlack::Node object supports the following methods:

=over 4

=item key ()

Key of the node.  This is what the nodes are sorted by in the tree.

=item val ($)

Value of the node.  Can be any perl scalar, so it could be a hash-ref,
f'rinstance.  This can be set directly.

=item color ()

Color of the node.  1 for "red", 0 or undef for "black".

=item parent ()

Parent node of this one.  Returns undef for root node.

=item left ()

Left child node of this one.  Returns undef for leaf nodes.

=item right ()

Right child node of this one.  Returns undef for leaf nodes.

=item min ()

Returns the node with the minimal key starting from this node.

=item max ()

Returns the node with the maximal key starting from this node.

=item successor ()

Returns the node with the smallest key larger than this node's key, or this
node if it is the node with the maximal key.

=item predecessor ()

Similar to successor. WARNING: NOT YET IMPLEMENTED!!

=back

You can use these methods to write utility routines for actions on red/black
trees.  For instance, here's a routine which writes a tree out to disk, putting
the byte offsets of the left and right child records in the record for each
node.

    sub dump {
      my($node, $fh) = @_;
      my($left, $right);
      my $pos = tell $fh;
      print $fh $node->color ? 'R' : 'B';
      seek($fh, 8, 1);
      print $fh $node->val;
      if ($node->left) {
        $left = dump($node->left,$fh);
      }
      if ($node->right) {
        $right = dump($node->right,$fh);
      }
      my $end = tell $fh;
      seek($fh, $pos+1, 0);
      print $fh pack('NN', $left, $right);
      seek($fh, $end, 0);
      $pos;
    }

You would call it like this:

    my $t = new Tree::RedBlack;
    ...
    open(FILE, ">tree.dump");
    dump($t->root,\*FILE);
    close FILE;

As another example, here's a simple routine to print a human-readable dump of
the tree:

    sub pretty_print {
      my($node, $fh, $lvl) = @_;
      if ($node->right) {
        pretty_print($node->right, $fh, $lvl+1);
      }
      print $fh ' 'x($lvl*3),'[', $node->color ? 'R' : 'B', ']', $node->key, "\n";
      if ($node->left) {
        pretty_print($this->left, $fh, $lvl+1);
      }
    }

A cleaner way of doing this kind of thing is probably to allow sub-classing of
Tree::RedBlack::Node, and then allow the Tree::RedBlack constructor to take an
argument saying what class of node it should be made up out of. Hmmm...

=head1 AUTHOR

Benjamin Holzman

=head1 SEE ALSO

Tree::RedBlack

=cut

sub new {
  my $type = shift;
  my $this = {};
  if (ref $type) {
    $this->{'parent'} = $type;
    $type = ref $type;
  }
  if (@_) {
    @$this{'key','val'} = @_;
  }
  return bless $this, $type;
}

sub DESTROY {
  if ($_[0]->{'left'}) {
    (delete $_[0]->{'left'})->DESTROY;
  }
  if ($_[0]->{'right'}) {
    (delete $_[0]->{'right'})->DESTROY;
  }
  delete $_[0]->{'parent'};
}

sub key {
  my $this = shift;
  if (@_) {
    $this->{'key'} = shift;
  }
  $this->{'key'};
}

sub val {
  my $this = shift;
  if (@_) {
    $this->{'val'} = shift;
  }
  $this->{'val'};
}

sub color {
  my $this = shift;
  if (@_) {
    $this->{'color'} = shift;
  }
  $this->{'color'};
}

sub left {
  my $this = shift;
  if (@_) {
    $this->{'left'} = shift;
  }
  $this->{'left'};
}

sub right {
  my $this = shift;
  if (@_) {
    $this->{'right'} = shift;
  }
  $this->{'right'};
}

sub parent {
  my $this = shift;
  if (@_) {
    $this->{'parent'} = shift;
  }
  $this->{'parent'};
}

sub successor {
  my $this = shift;
  if ($this->{'right'}) {
    return $this->{'right'}->min;
  }
  my $parent = $this->{'parent'};
  while ($parent && $this == $parent->{'right'}) {
    $this = $parent;
    $parent = $parent->{'parent'};
  }
  $parent;
}

sub min {
  my $this = shift;
  while ($this->{'left'}) {
    $this = $this->{'left'};
  }
  $this;
}

sub max {
  my $this = shift;
  while ($this->{'right'}) {
    $this = $this->{'right'};
  }
  $this;
}

1;