package Tree::Binary::RedBlack; require Exporter; @ISA = 'Exporter'; @EXPORT = qw/ deleteKey deleteMax deleteMin insert key_exists lookup max min new_rb node_count /; our $VERSION = '0.01'; # Tree definition use constant ROOT => 0; use constant COUNT => 1; use constant COMPARE => 2; # Node definition use constant COLOR => 0; use constant KEY => 1; use constant VALUE => 2; use constant RIGHT => 3; use constant LEFT => 4; # Color definition use constant BLACK => 0; use constant RED => 1; # Comparison definition use constant LESS => -1; use constant EQUAL => 0; use constant MORE => 1; # Truth definition use constant TRUE => 1; use constant FALSE => undef; # Stack definition use constant LAST => -1; use constant NODE => 0; use constant DIR => 1; use strict; use warnings; use Carp; use UNIVERSAL 'isa'; # Public sub new_rb { croak "Incorrect number of parameters" if @_ % 2; my %opt = @_; my $cmp = delete $opt{compare} || 'cmp'; if (isa($cmp, 'CODE')) { *_insert = *_insert_custom; } elsif($cmp eq 'cmp') { #*_insert = *_insert_ascii; *_insert = *_insert_cmp; } else { croak "The '$cmp' comparison is not supported"; } carp "The '$_' parameter is not supported\n" for keys %opt; return [undef, 0, $cmp]; } # Public sub insert { my ($tree, $key, $val) = @_; $tree->[ROOT] = _insert($tree->[ROOT], $tree->[COMPARE], $key, $val); $tree->[COUNT]++; $tree->[ROOT][COLOR] = BLACK; } # Private sub _insert_custom { my ($node, $cmp, $key, $val) = @_; return [RED, $key, $val, undef, undef] if ! $node; if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $node->[LEFT][COLOR]) { $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } my $result = $cmp->($key, $node->[KEY]); if ($result == EQUAL) { $node->[VALUE] = $val; } elsif ($result == MORE) { $node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val); } else { $node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val); } if ($node->[RIGHT] && $node->[RIGHT][COLOR] && ! ($node->[LEFT] && $node->[LEFT][COLOR])) { my $temp = $node->[RIGHT]; $node->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] && $node->[LEFT][LEFT][COLOR]) { my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } return $node; } sub _insert_cmp { my ($node, $cmp, $key, $val) = @_; return [RED, $key, $val, undef, undef] if ! $node; if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $node->[LEFT][COLOR]) { $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } my $result = $key cmp $node->[KEY]; if ($result == EQUAL) { $node->[VALUE] = $val; } elsif ($result == MORE) { $node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val); } else { $node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val); } if ($node->[RIGHT] && $node->[RIGHT][COLOR] && ! ($node->[LEFT] && $node->[LEFT][COLOR])) { my $temp = $node->[RIGHT]; $node->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] && $node->[LEFT][LEFT][COLOR]) { my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } return $node; } sub _insert_ascii { my ($node, $cmp, $key, $val) = @_; my ($found, @stack); while ($node) { if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $node->[LEFT][COLOR]) { $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } my $result = $key cmp $node->[KEY]; # Descend right if ($result == LESS) { push @stack, [$node, LEFT]; $node = $node->[LEFT]; } # Descend right elsif ($result == MORE) { push @stack, [$node, RIGHT]; $node = $node->[RIGHT]; } # Dup key, replace value else { push @stack, [$node]; ($found, $node->[VALUE]) = (1, $val); $node = undef; } } push @stack, [[RED, $key, $val, undef, undef]] if ! $found; my $idx = @stack; my $assign; while ($idx--) { my ($item, $dir) = @{$stack[$idx]}[NODE, DIR]; if ($assign || $found) { $item->[$dir] = $assign->[NODE] if $assign; if ($item->[RIGHT] && $item->[RIGHT][COLOR] && ! ($item->[LEFT] && $item->[LEFT][COLOR])) { my $temp = $item->[RIGHT]; $item->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $item; $temp->[COLOR] = $item->[COLOR]; $item->[COLOR] = RED; $item = $temp; } if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] && $node->[LEFT][LEFT][COLOR]) { my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } } $assign = [$item]; } return $assign->[NODE]; } sub lookup { my ($tree, $key) = @_; return FALSE if ! defined $key; my ($root, $cmp) = ($tree->[ROOT], $tree->[COMPARE]); while ($root) { my $result = $cmp->($key, $root->[KEY]); return $root->[VALUE] if $result == EQUAL; $root = $result == LESS ? $root->[LEFT] : $root->[RIGHT]; } return FALSE; } sub key_exists { my ($tree, $key) = @_; return FALSE if ! defined $key; my ($root, $cmp) = ($tree->[ROOT], $tree->[COMPARE]); while ($root) { my $result = $cmp->($key, $root->[KEY]); return TRUE if $result == EQUAL; $root = $result == LESS ? $root->[LEFT] : $root->[RIGHT]; } return FALSE; } sub node_count { my ($tree) = @_; return $tree->[COUNT]; } sub deleteMin { my ($tree) = @_; $tree->[ROOT] = _deleteMin($tree->[ROOT]); $tree->[COUNT]-- if $tree->[COUNT]; $tree->[ROOT][COLOR] = BLACK; } sub deleteKey { my ($tree, $key) = @_; $tree->[ROOT] = _deleteKey($tree->[ROOT], $tree->[COMPARE], $key); $tree->[COUNT]-- if $tree->[COUNT]; $tree->[ROOT][COLOR] = BLACK; } sub max { my ($tree, $key) = @_; return FALSE if ! $tree->[ROOT]; return _max($tree->[ROOT]); } sub min { my ($tree, $key) = @_; return FALSE if ! $tree->[ROOT]; return _min($tree->[ROOT]); } sub deleteMax { my ($tree) = @_; $tree->[ROOT] = _deleteMax($tree->[ROOT]); $tree->[COUNT]-- if $tree->[COUNT]; $tree->[ROOT][COLOR] = BLACK; } # Private sub _deleteMax { my ($node) = @_; $node = _rotateRight($node) if _isRed($node->[LEFT]); return FALSE if ! $node->[RIGHT]; $node = _moveRedRight($node) if ! _isRed($node->[RIGHT]) && ! _isRed($node->[RIGHT][LEFT]); $node->[RIGHT] = _deleteMax($node->[RIGHT]); return _fixUp($node); } sub _deleteKey { my ($node, $cmp, $key) = @_; if ($cmp->($key, $node->[KEY]) == LESS) { $node = _moveRedLeft($node) if ! _isRed($node->[LEFT]) && ! _isRed($node->[LEFT][LEFT]); $node->[LEFT] = _deleteKey($node->[LEFT], $cmp, $key); } else { $node = _rotateRight($node) if _isRed($node->[LEFT]); return FALSE if $cmp->($key, $node->[KEY]) == EQUAL && ! $node->[RIGHT]; $node = _moveRedRight($node) if ! _isRed($node->[RIGHT]) && ! _isRed($node->[RIGHT][LEFT]); if ($cmp->($key, $node->[KEY]) == EQUAL) { # Opportunity to return key/val together $node->[VALUE] = _get($node->[RIGHT], $cmp, _min($node->[RIGHT])); $node->[KEY] = _min($node->[RIGHT]); $node->[RIGHT] = _deleteMin($node->[RIGHT]); } else { $node->[RIGHT] = _deleteKey($node->[RIGHT], $key); } } return _fixUp($node); } sub _get { my ($node, $cmp, $key) = @_; return FALSE if ! $node; my $result = $cmp->($key, $node->[KEY]); return $node->[VALUE] if $result == EQUAL; return _get($node->[LEFT], $cmp, $key) if $result == LESS; return _get($node->[RIGHT], $cmp, $key); } sub _min { my ($node) = @_; return $node->[KEY] if ! $node->[LEFT]; return _min($node->[LEFT]); } sub _max { my ($node) = @_; return $node->[KEY] if ! $node->[RIGHT]; return _max($node->[RIGHT]); } sub _deleteMin { my ($node) = @_; return FALSE if ! $node->[LEFT]; $node = _moveRedLeft($node) if ! _isRed($node->[LEFT]) && ! _isRed($node->[LEFT][LEFT]); $node->[LEFT] = _deleteMin($node->[LEFT]); return _fixUp($node); } sub _moveRedLeft { my ($node) = @_; _colorFlip($node); if (_isRed($node->[RIGHT][LEFT])) { $node->[RIGHT] = _rotateRight($node->[RIGHT]); $node = _rotateLeft($node); _colorFlip($node); } return $node; } sub _moveRedRight { my ($node) = @_; _colorFlip($node); if (_isRed($node->[LEFT][LEFT])) { $node = _rotateRight($node); _colorFlip($node); } return $node; } sub _rotateLeft { my ($node) = @_; my $temp = $node->[RIGHT]; $node->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; return $temp; } sub _rotateRight { my ($node) = @_; my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; return $temp; } sub _isRed { my ($node) = @_; return FALSE if ! $node; return $node->[COLOR] == RED; } sub _colorFlip { my ($node) = @_; $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } sub _fixUp { my ($node) = @_; $node = _rotateLeft($node) if _isRed($node->[RIGHT]); $node = _rotateRight($node) if _isRed($node->[LEFT]) && _isRed($node->[LEFT][LEFT]); _colorFlip($node) if _isRed($node->[LEFT]) && _isRed($node->[RIGHT]); return $node; } 'This statement is false.'; __END__ OPTIMIZATIONS 1. Inline some subs 2. Turn recursion into a stack 3. Allow predefined comparison subs and then *foo = in order to not pay penalty - ascii, numerical, coderef sub {$_[0] cmp $_[1]} 4. Add get_min_kv and get_max_kv (see _deleteKey) 5. Turn the things that make sense from recursion to iteration (but frustratingly, not insert) 6. Consider XS 7. As a configurable option, allow not storing values to reduce memory FEATURES 1. Add val_defined 2. Iterator for going over the tree GENERAL 1. Consistency in sub names REFERENCE 1. http://www.cs.princeton.edu/~rs/talks/LLRB/08Dagstuhl/RedBlack.pdf 2. http://www.cs.princeton.edu/~rs/talks/LLRB/RedBlack.pdf 3. http://www.cs.princeton.edu/~rs/talks/LLRB/08Penn.pdf