File Coverage

blib/lib/Tree/Binary.pm

Criterion	Covered	Total	%
statement	159	159	100.0
branch	72	74	97.3
condition	18	21	85.7
subroutine	32	32	100.0
pod	25	25	100.0
total	306	311	98.3

package Tree::Binary;

use strict;
use warnings;

our $VERSION = '1.08';

use Scalar::Util qw(blessed);

## ----------------------------------------------------------------------------
## Tree::Binary
## ----------------------------------------------------------------------------

### constructor

sub new {
	my ($_class, $node) = @_;
	my $class = ref($_class) || $_class;
	my $binary_tree = {};
	bless($binary_tree, $class);
	$binary_tree->_init($node);
	return $binary_tree;
}

### ---------------------------------------------------------------------------
### methods
### ---------------------------------------------------------------------------

## ----------------------------------------------------------------------------
## private methods

sub _init {
	my ($self, $node) = @_;
    (defined($node)) || die "Insufficient Arguments : you must provide a node value";
    # set the value of the unique id
    ($self->{_uid}) = ("$self" =~ /\((.*?)\)$/);
	# set the value of the node
	$self->{_node}   = $node;
    # create the child nodes
    $self->{_left}   = undef;
    $self->{_right}  = undef;
    # initialize the parent and depth here
    $self->{_parent} = undef;
    $self->{_depth}  = 0;
}

## ----------------------------------------------------------------------------
## mutators

sub setNodeValue {
	my ($self, $node_value) = @_;
	(defined($node_value)) || die "Insufficient Arguments : must supply a value for node";
	$self->{_node} = $node_value;
}

sub setUID {
    my ($self, $uid) = @_;
    ($uid) || die "Insufficient Arguments : Custom Unique ID's must be a true value";
    $self->{_uid} = $uid;
}

sub setLeft {
    my ($self, $tree) = @_;
    (blessed($tree) && $tree->isa("Tree::Binary"))
        || die "Insufficient Arguments : left argument must be a Tree::Binary object";
	$tree->{_parent} = $self;
    $self->{_left} = $tree;
    unless ($tree->isLeaf()) {
        $tree->fixDepth();
    }
    else {
        $tree->{_depth} = $self->getDepth() + 1;
    }
    $self;
}

sub removeLeft {
    my ($self) = @_;
    ($self->hasLeft()) || die "Illegal Operation: cannot remove node that doesnt exist";
    my $left = $self->{_left};
    $left->{_parent} = undef;
    unless ($left->isLeaf()) {
        $left->fixDepth();
    }
    else {
        $left->{_depth} = 0;
    }
    $self->{_left} = undef;
    return $left;
}

sub setRight {
    my ($self, $tree) = @_;
    (blessed($tree) && $tree->isa("Tree::Binary"))
        || die "Insufficient Arguments : right argument must be a Tree::Binary object";
	$tree->{_parent} = $self;
    $self->{_right} = $tree;
    unless ($tree->isLeaf()) {
        $tree->fixDepth();
    }
    else {
        $tree->{_depth} = $self->getDepth() + 1;
    }
    $self;
}

sub removeRight {
    my ($self) = @_;
    ($self->hasRight()) || die "Illegal Operation: cannot remove node that doesnt exist";
    my $right = $self->{_right};
    $right->{_parent} = undef;
    unless ($right->isLeaf()) {
        $right->fixDepth();
    }
    else {
        $right->{_depth} = 0;
    }
    $self->{_right} = undef;
    return $right;
}

## ----------------------------------------------------------------------------
## accessors

sub getUID {
    my ($self) = @_;
    return $self->{_uid};
}

sub getParent {
	my ($self)= @_;
	return $self->{_parent};
}

sub getDepth {
	my ($self) = @_;
	return $self->{_depth};
}

sub getNodeValue {
	my ($self) = @_;
	return $self->{_node};
}

sub getLeft {
    my ($self) = @_;
    return $self->{_left};
}

sub getRight {
    my ($self) = @_;
    return $self->{_right};
}

## ----------------------------------------------------------------------------
## informational

sub isLeaf {
	my ($self) = @_;
	return (!defined $self->{_left} && !defined $self->{_right});
}

sub hasLeft {
    my ($self) = @_;
    return defined $self->{_left};
}

sub hasRight {
    my ($self) = @_;
    return defined $self->{_right};
}

sub isRoot {
	my ($self) = @_;
	return not defined $self->{_parent};
}

## ----------------------------------------------------------------------------
## misc

# NOTE:
# Occasionally one wants to have the
# depth available for various reasons
# of convience. Sometimes that depth
# field is not always correct.
# If you create your tree in a top-down
# manner, this is usually not an issue
# since each time you either add a child
# or create a tree you are doing it with
# a single tree and not a hierarchy.
# If however you are creating your tree
# bottom-up, then you might find that
# when adding hierarchies of trees, your
# depth fields are all out of whack.
# This is where this method comes into play
# it will recurse down the tree and fix the
# depth fields appropriately.
# This method is called automatically when
# a subtree is added to a child array
sub fixDepth {
	my ($self) = @_;
	# make sure the tree's depth
	# is up to date all the way down
	$self->traverse(sub {
			my ($tree) = @_;
            unless ($tree->isRoot()) {
                $tree->{_depth} = $tree->getParent()->getDepth() + 1;
            }
            else {
                $tree->{_depth} = 0;
            }
		}
	);
}

sub traverse {
	my ($self, $func) = @_;
	(defined($func)) || die "Insufficient Arguments : Cannot traverse without traversal function";
    (ref($func) eq "CODE") || die "Incorrect Object Type : traversal function is not a function";
    $func->($self);
    $self->{_left}->traverse($func) if defined $self->{_left};
    $self->{_right}->traverse($func) if defined $self->{_right};
}

sub mirror {
    my ($self) = @_;
    # swap left for right
    my $temp = $self->{_left};
    $self->{_left} = $self->{_right};
    $self->{_right} = $temp;
    # and recurse
    $self->{_left}->mirror() if $self->hasLeft();
    $self->{_right}->mirror() if $self->hasRight();
    $self;
}

sub size {
    my ($self) = @_;
    my $size = 1;
    $size += $self->{_left}->size() if $self->hasLeft();
    $size += $self->{_right}->size() if $self->hasRight();
    return $size;
}

sub height {
    my ($self) = @_;
    my ($left_height, $right_height) = (0, 0);
    $left_height = $self->{_left}->height() if $self->hasLeft();
    $right_height = $self->{_right}->height() if $self->hasRight();
    return 1 + (($left_height > $right_height) ? $left_height : $right_height);
}

sub accept {
	my ($self, $visitor) = @_;
    # it must be a blessed reference and ...
	(blessed($visitor) &&
        # either a Tree::Simple::Visitor object, or ...
        ($visitor->isa("Tree::Binary::Visitor") ||
            # it must be an object which has a 'visit' method avaiable
            $visitor->can('visit')))
		|| die "Insufficient Arguments : You must supply a valid Visitor object";
	$visitor->visit($self);
}

## ----------------------------------------------------------------------------
## cloning

sub clone {
    my ($self) = @_;
    # first clone the value in the node
    my $cloned_node = _cloneNode($self->getNodeValue());
    # create a new Tree::Simple object
    # here with the cloned node, however
    # we do not assign the parent node
    # since it really does not make a lot
    # of sense. To properly clone it would
    # be to clone back up the tree as well,
    # which IMO is not intuitive. So in essence
    # when you clone a tree, you detach it from
    # any parentage it might have
    my $clone = $self->new($cloned_node);
    # however, because it is a recursive thing
    # when you clone all the children, and then
    # add them to the clone, you end up setting
    # the parent of the children to be that of
    # the clone (which is correct)
    $clone->setLeft($self->{_left}->clone()) if $self->hasLeft();
    $clone->setRight($self->{_right}->clone()) if $self->hasRight();
    # return the clone
    return $clone;
}


# this allows cloning of single nodes while
# retaining connections to a tree, this is sloppy
sub cloneShallow {
	my ($self) = @_;
	my $cloned_tree = { %{$self} };
	bless($cloned_tree, ref($self));
	# just clone the node (if you can)
    my $cloned_node =_cloneNode($self->getNodeValue());
    (defined($cloned_node)) || die "Node did not clone : " . $self->getNodeValue();
	$cloned_tree->setNodeValue($cloned_node);
	return $cloned_tree;
}

# this is a helper function which
# recursively clones the node
sub _cloneNode {
    my ($node, $seen) = @_;
    # create a cache if we dont already
    # have one to prevent circular refs
    # from being copied more than once
    $seen = {} unless defined $seen;
    # now here we go...
    my $clone;
    # if it is not a reference, then lets just return it
    return $node unless ref($node);
    # if it is in the cache, then return that
    return $seen->{$node} if exists ${$seen}{$node};
    # if it is an object, then ...
    if (blessed($node)) {
        # see if we can clone it
        if ($node->can('clone')) {
            $clone = $node->clone();
        }
        # otherwise respect that it does
        # not want to be cloned
        else {
            $clone = $node;
        }
    }
    else {
        # if the current slot is a scalar reference, then
        # dereference it and copy it into the new object
        if (ref($node) eq "SCALAR" || ref($node) eq "REF") {
            my $var = "";
            $clone = \$var;
            ${$clone} = _cloneNode(${$node}, $seen);
        }
        # if the current slot is an array reference
        # then dereference it and copy it
        elsif (ref($node) eq "ARRAY") {
            $clone = [ map { _cloneNode($_, $seen) } @{$node} ];
        }
        # if the current reference is a hash reference
        # then dereference it and copy it
        elsif (ref($node) eq "HASH") {
            $clone = {};
            foreach my $key (keys %{$node}) {
                $clone->{$key} = _cloneNode($node->{$key}, $seen);
            }
        }
        else {
            # all other ref types are not copied
            $clone = $node;
        }
    }
    # store the clone in the cache and
    $seen->{$node} = $clone;
    # then return the clone
    return $clone;
}


## ----------------------------------------------------------------------------
## Desctructor

sub DESTROY {
	my ($self) = @_;
    # we need to call DESTORY on all our children
	# (first checking if they are defined
	# though since we never know how perl's
	# garbage collector will work)
    $self->{_left}->DESTROY() if defined $self->{_left};
    $self->{_right}->DESTROY() if defined $self->{_right};
    $self->{_parent} = undef;
}

1;

__END__