Tree-RedBlack-0.5/0000755000077100007710000000000011044404373013234 5ustar bahbah00000000000000Tree-RedBlack-0.5/Node.pm0000644000077100007710000001030211044342565014457 0ustar bahbah00000000000000package 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; Tree-RedBlack-0.5/MANIFEST0000644000077100007710000000022411044404373014363 0ustar bahbah00000000000000Changes MANIFEST README Makefile.PL RedBlack.pm Node.pm t/redblack.t META.yml Module meta-data (added by MakeMaker) Tree-RedBlack-0.5/Makefile.PL0000644000077100007710000000063111044342565015212 0ustar bahbah00000000000000use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Tree::RedBlack', 'PM' => {'RedBlack.pm' => '$(INST_LIBDIR)/RedBlack.pm', 'Node.pm' => '$(INST_LIBDIR)/RedBlack/Node.pm'}, 'VERSION_FROM' => 'RedBlack.pm', # finds $VERSION 'dist' => {COMPRESS => 'gzip', SUFFIX => 'gz'}, ); Tree-RedBlack-0.5/Changes0000644000077100007710000000105511044404362014526 0ustar bahbah00000000000000Revision history for Perl extension Tree::RedBlack. 0.01 Wed Oct 14 13:42:34 1998 - original version; created by h2xs 1.18 0.1 Wed Oct 14 16:51:00 1998 - first public alpha release; bholzman 0.2 Wed Oct 28 16:07:00 1998 - fixed major Makefile.PL mess-up; bholzman 0.3 Tue Jun 29 10:53:00 1999 - fixed memory leak; bholzman 0.4 Thu Jul 31 10:33:00 2008 - fixed misspelled method name (value instead of val), ID 13482 - fix bug when using custom comparator, ID 19431 0.5 Thu Jul 31 14:48:00 2008 - added some tests (still more to add) Tree-RedBlack-0.5/t/0000755000077100007710000000000011044404373013477 5ustar bahbah00000000000000Tree-RedBlack-0.5/t/redblack.t0000644000077100007710000000215511044404266015437 0ustar bahbah00000000000000use strict; use Test::More tests => 23; use Tree::RedBlack; my $tree = Tree::RedBlack->new(); isa_ok($tree, 'Tree::RedBlack'); is($tree->root, undef); is($tree->find(42), undef); is($tree->max, undef); is($tree->min, undef); $tree->insert(3, 'cat'); is($tree->find(3), 'cat'); is($tree->min->val, 'cat'); is($tree->max->val, 'cat'); is($tree->find(42), undef); $tree->insert(3, 'dog'); is($tree->find(3), 'dog'); $tree->insert(4); is($tree->max->val, undef); is($tree->find(4), undef); isa_ok($tree->node(4), 'Tree::RedBlack::Node'); $tree->insert(7, 'dude'); $tree->insert(5, 'really'); $tree->insert(6, 'cool'); is($tree->min->val, 'dog'); is($tree->max->val, 'dude'); is($tree->find(5), 'really'); $tree->delete(3); is($tree->min->val, undef); is($tree->node(14), undef); my $tree2 = Tree::RedBlack->new(); $tree2->cmp(sub { $_[0] <=> $_[1] }); $tree2->insert(10); $tree2->insert(2); is($tree2->max->key, 10); is($tree2->min->key, 2); is($tree2->node(10), $tree2->max); is($tree2->node(2), $tree2->min); SKIP: { skip 'delete not working correctly' => 1; $tree2->delete(10); is($tree2->max->key, 2); }; Tree-RedBlack-0.5/RedBlack.pm0000644000077100007710000002206611044404333015243 0ustar bahbah00000000000000package Tree::RedBlack; use strict; use Tree::RedBlack::Node; use vars qw($VERSION); $VERSION = '0.5'; =head1 NAME Tree::RedBlack - Perl implementation of Red/Black tree, a type of balanced tree. =head1 SYNOPSIS use Tree::RedBlack; my $t = new Tree::RedBlack; $t->insert(3, 'cat'); $t->insert(4, 'dog'); my $v = $t->find(4); my $min = $t->min; my $max = $t->max; $t->delete(3); $t->print; =head1 DESCRIPTION This is a perl implementation of the Red/Black tree algorithm found in the book "Algorithms", by Cormen, Leiserson & Rivest (more commonly known as "CLR" or "The White Book"). A Red/Black tree is a binary tree which remains "balanced"- that is, the longest length from root to a node is at most one more than the shortest such length. It is fairly efficient; no operation takes more than O(lg(n)) time. A Tree::RedBlack object supports the following methods: =over 4 =item new () Creates a new RedBlack tree object. =item root () Returns the root node of the tree. Note that this will either be undef if no nodes have been added to the tree, or a Tree::RedBlack::Node object. See the L manual page for details on the Node object. =item cmp (&) Use this method to set a comparator subroutine. The tree defaults to lexical comparisons. This subroutine should be just like a comparator subroutine to sort, except that it doesn't do the $a, $b trick; the two elements to compare will just be the first two items on the stack. =item insert ($;$) Adds a new node to the tree. The first argument is the key of the node, the second is its value. If a node with that key already exists, its value is replaced with the given value and the old value is returned. Otherwise, undef is returned. =item delete ($) The argument should be either a node object to delete or the key of a node object to delete. WARNING!!! THIS STILL HAS BUGS!!! =item find ($) Searches the tree to find the node with the given key. Returns the value of that node, or undef if a node with that key isn't found. Note, in particular, that you can't tell the difference between finding a node with value undef and not finding a node at all. If you want to determine if a node with a given key exists, use the node method, below. =item node ($) Searches the tree to find the node with the given key. Returns that node object if it is found, undef otherwise. The node object is a Tree::RedBlack::Node object. =item min () Returns the node with the minimal key. =item max () Returns the node with the maximal key. =back =head1 AUTHOR Benjamin Holzman =head1 SEE ALSO Tree::RedBlack::Node =cut sub new { my $type = shift; return bless {'null' => Tree::RedBlack::Node::->new, 'root' => undef}, $type; } sub DESTROY { if ($_[0]->{'root'}) { $_[0]->{'root'}->DESTROY } } sub root { my $this = shift; return $this->{'root'}; } sub cmp { my($this, $cr) = @_; $this->{'cmp'} = $cr; } sub insert { my($this, $key, $value) = @_; my $cmp = $this->{'cmp'}; my $node = $this->{'root'}; my $parent; while ($node) { $parent = $node; if ($cmp ? $cmp->($key, $node->key) < 0 : $key lt $node->key) { $node = $node->left; } else { $node = $node->right; } } if ($parent) { # Handle case of inserting node with duplicate key. if ($cmp ? $cmp->($parent->key, $key) == 0 : $parent->key eq $key) { my $val = $parent->val; $parent->val($value); return $val; } $node = $parent->new($key, $value); if ($this->{'cmp'} ? $this->{'cmp'}->($key, $parent->key) < 0 : $key lt $parent->key) { $parent->left($node); } else { $parent->right($node); } } else { $this->{'root'} = $node = Tree::RedBlack::Node::->new($key, $value); } $node->color(1); while ($node != $this->{'root'} && $node->parent->color) { if (defined $node->parent->parent->left && $node->parent == $node->parent->parent->left) { my $uncle = $node->parent->parent->right; if ($uncle && $uncle->color) { $node->parent->color(0); $uncle->color(0); $node->parent->parent->color(1); $node = $node->parent->parent; } else { if ($node == $node->parent->right) { $node = $node->parent; $this->left_rotate($node); } $node->parent->color(0); $node->parent->parent->color(1); $this->right_rotate($node->parent->parent); } } else { my $uncle = $node->parent->parent->left; if ($uncle && $uncle->color) { $node->parent->color(0); $uncle->color(0); $node->parent->parent->color(1); $node = $node->parent->parent; } else { if (defined $node->parent->left && $node == $node->parent->left) { $node = $node->parent; $this->right_rotate($node); } $node->parent->color(0); $node->parent->parent->color(1); $this->left_rotate($node->parent->parent); } } } $this->{'root'}->color(0); return; } sub left_rotate { my($this, $node) = @_; my $child = $node->right; $node->right($child->left); if ($child->left) { $child->left->parent($node); } $child->parent($node->parent); if ($node->parent) { if ($node == $node->parent->left) { $node->parent->left($child); } else { $node->parent->right($child); } } else { $this->{'root'} = $child; } $child->left($node); $node->parent($child); } sub right_rotate { my($this, $node) = @_; my $child = $node->left; $node->left($child->right); if ($child->right) { $child->right->parent($node); } $child->parent($node->parent); if ($node->parent) { if ($node == $node->parent->right) { $node->parent->right($child); } else { $node->parent->left($child); } } else { $this->{'root'} = $child; } $child->right($node); $node->parent($child); } sub delete { my($this, $node_or_key) = @_; my $node; if (ref $node_or_key && $node_or_key->isa('Tree::RedBlack::Node')) { $node = $node_or_key; } else { $node = $this->node($node_or_key) or return; } my($successor, $successor_child); if (!($node->left && $node->right)) { $successor = $node; } else { $successor = $node->successor; } if ($successor->left) { $successor_child = $successor->left; } else { $successor_child = $successor->right || $this->{'null'}; } $successor_child->parent($successor->parent); if (!$successor_child || !$successor_child->parent) { $this->{'root'} = $successor_child; } elsif ($successor == $successor->parent->left) { $successor->parent->left($successor_child); } else { $successor->parent->right($successor_child); } if ($successor != $node) { $node->key($successor->key); $node->val($successor->val); } if (!$successor->color) { $this->delete_fixup($successor_child); } if (!$successor_child->parent) { $this->{'root'} = undef; } $successor; } sub delete_fixup { my($this, $x) = @_; while ($x != $this->{'root'} && !$x->color) { if ($x == $x->parent->left) { my $w = $x->parent->right; if ($w->color) { $w->color(0); $x->parent->color(1); $this->left_rotate($x->parent); } if (!$w->left->color && !$w->right->color) { $w->color(1); $x = $x->parent; } else { if (!$w->right->color) { $w->left->color(0); $w->color(1); $this->right_rotate($w); $w = $x->parent->right; } $w->color($x->parent->color); $x->parent->color(0); $w->right->color(0); $this->left_rotate($x->parent); $x = $this->{'root'}; } } else { my $w = $x->parent->left; if ($w->color) { $w->color(0); $x->parent->color(1); $this->right_rotate($x->parent); } if (!$w->left->color && !$w->right->color) { $w->color(1); $x = $x->parent; } else { if (!$w->left->color) { $w->right->color(0); $w->color(1); $this->left_rotate($w); $w = $x->parent->left; } $w->color($x->parent->color); $x->parent->color(0); $w->left->color(0); $this->right_rotate($x->parent); $x = $this->{'root'}; } } } $x->color(0); } sub min { my $this = shift; if ($this->{'root'}) { if ($this->{'root'}->left) { return $this->{'root'}->left->min; } else { return $this->{'root'}; } } return; } sub max { my $this = shift; if ($this->{'root'}) { if ($this->{'root'}->right) { return $this->{'root'}->right->max; } else { return $this->{'root'}; } } return; } sub find { my($this, $key) = @_; my $cmp = $this->{'cmp'}; my $node = $this->{'root'}; while ($node) { if ($cmp ? $cmp->($key, $node->key) == 0 : $key eq $node->key) { return $node->val; } elsif ($cmp ? $cmp->($key, $node->key) < 0 : $key lt $node->key) { $node = $node->left; } else { $node = $node->right; } } # Got to the end without finding the node. return; } sub node { my($this, $key) = @_; my $cmp = $this->{'cmp'}; my $node = $this->{'root'}; while ($node) { if ($cmp ? $cmp->($key, $node->key) == 0 : $key eq $node->key) { return $node; } elsif ($cmp ? $cmp->($key, $node->key) < 0 : $key lt $node->key) { $node = $node->left; } else { $node = $node->right; } } # Got to the end without finding the node. return; } 1; Tree-RedBlack-0.5/META.yml0000644000077100007710000000045411044404373014510 0ustar bahbah00000000000000# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Tree-RedBlack version: 0.5 version_from: RedBlack.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30 Tree-RedBlack-0.5/README0000644000077100007710000000303511044346615014121 0ustar bahbah00000000000000Tree::RedBlack version 0.4 ------------------------------------------------------------------------ This program is free software; you can redistribute it and/or modify it under the terms of the Artistic License, a copy of which can be found with perl. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Artistic License for more details. ------------------------------------------------------------------------ *** This is beta software -- use at your own risk *** Introduction ------------ Tree::RedBlack is a pure perl implementation of the Red/Black balanced tree algorithm from the book "Algorithms" by Cormen, Leiserson & Rivest. It supports insertion, searching, finding minima, maxima, predecessors and successors, and deletion (deletion definitely has bugs right now). Each node in the tree consists of a key and a value. Both can be any Perl scalar, even a complex structure. By default, keys in the tree are ordered lexically, but the ordering can be overriden by providing the tree with a comparison subroutine. Installation ------------ Installation follows the normal module installation procedure: 1. Uncompress and untar the distribution 2. In the root of the distribution, execute $ perl Makefile.PL $ make $ make install (sorry, no test suite yet) Feedback -------- Please report any bugs or feature requests to Benjamin Holzman at