File Coverage

blib/lib/Tree/RB/Node.pm

Criterion	Covered	Total	%
statement	82	91	90.1
branch	18	30	60.0
condition	17	23	73.9
subroutine	22	23	95.6
pod	8	13	61.5
total	147	180	81.6

package Tree::RB::Node;

use strict;
use Carp;
use Tree::RB::Node::_Constants;
use vars qw( $VERSION @EXPORT_OK );

require Exporter;
*import    = \&Exporter::import;
@EXPORT_OK = qw[set_color color_of parent_of left_of right_of];

$VERSION = '0.2';

my %attribute = (
    key    => _KEY,
    val    => _VAL,
    color  => _COLOR,
    parent => _PARENT,
    left   => _LEFT,
    right  => _RIGHT,
);

sub _accessor {
    my $index = shift;
    return sub {
        my $self = shift;
        if (@_) {
          $self->[$index] = shift;
        }
        return $self->[$index];
    };
}

while(my($at, $idx) = each %attribute) {
    no strict 'refs';
    *$at = _accessor($idx);
}

sub new {
    my $class = shift;
    my $obj = [];

    if (@_) {
        $obj->[_KEY] = shift;
        $obj->[_VAL] = shift;
    }
    return bless $obj, $class;
}

sub min {
    my $self = shift;
    while ($self->[_LEFT]) {
        $self = $self->[_LEFT];
    }
    return $self;
}

sub max {
    my $self = shift;
    while ($self->[_RIGHT]) {
        $self = $self->[_RIGHT];
    }
    return $self;
}

sub leaf {
    my $self = shift;
    while (my $any_child = $self->[_LEFT] || $self->[_RIGHT]) {
        $self = $any_child;
    }
    return $self;
}

sub successor {
    my $self = shift;
    if ($self->[_RIGHT]) {
        return $self->[_RIGHT]->min;
    }
    my $parent = $self->[_PARENT];
    while ($parent && $parent->[_RIGHT] && $self == $parent->[_RIGHT]) {
        $self = $parent;
        $parent = $parent->[_PARENT];
    }
    return $parent;
}

sub predecessor {
    my $self = shift;
    if ($self->[_LEFT]) {
        return $self->[_LEFT]->max;
    }
    my $parent = $self->[_PARENT];
    while ($parent && $parent->[_LEFT] && $self == $parent->[_LEFT]) {
        $self = $parent;
        $parent = $parent->[_PARENT];
    }
    return $parent;
}

sub as_lol {
    my $self = shift;
    my $node = shift || $self;
    my $aref;
    push @$aref,
         $node->[_LEFT]
           ? $self->as_lol($node->[_LEFT])
           : '*';
    push @$aref,
         $node->[_RIGHT]
           ? $self->as_lol($node->[_RIGHT])
           : '*';
    my $color = ($node->[_COLOR] == RED ? 'R' : 'B');
    no warnings 'uninitialized';
    push @$aref, "$color:$node->[_KEY]";
    return $aref;
}

sub strip {
    my $self = shift;
    my $callback = shift;

    my $x = $self;
    while($x) {
        my $leaf = $x->leaf;
        $x = $leaf->[_PARENT];

        # detach $leaf from the (sub)tree
        no warnings "uninitialized";
        if($leaf == $x->[_LEFT]) {
            undef $x->[_LEFT];
        }
        else {
            undef $x->[_RIGHT];
        }
        undef $leaf->[_PARENT];
        if($callback) {
            $callback->($leaf);
        }

        if(!$x->[_LEFT] && !$x->[_RIGHT]) {
            $x = $x->[_PARENT];
        }
    }
}

sub DESTROY { $_[0]->strip; }

# Null aware accessors to assist with rebalancings during insertion and deletion
#
# A weird case of Java to the rescue!
# These are inspired by http://www.javaresearch.org/source/jdk142/java/util/TreeMap.java.html
# which was found via http://en.wikipedia.org/wiki/Red-black_tree#Implementations

sub set_color {
    my ($node, $color) = @_;
    if($node) {
        $node->[_COLOR] = $color || BLACK;
    }
}

sub color_of {
    $_[0] ? $_[0]->[_COLOR] : BLACK;
}

sub parent_of {
    $_[0] ? $_[0]->[_PARENT] : undef;
}

sub left_of {
    $_[0] ? $_[0]->[_LEFT] : undef;
}

sub right_of {
    $_[0] ? $_[0]->[_RIGHT] : undef;
}


1; # Magic true value required at end of module
__END__