diff Tree/Interval/Node.pm @ 0:acc8d8bfeb9a

Uploaded

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Tree/Interval/Node.pm	Wed Feb 08 16:59:24 2012 -0500
@@ -0,0 +1,208 @@
+package Tree::Interval::Node;
+
+use strict;
+use Carp;
+use Tree::Interval::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.1';
+
+# key and interval is the same thing
+my %attribute = (
+    key    => _KEY,
+    val    => _VAL,
+    color  => _COLOR,
+    parent => _PARENT,
+    left   => _LEFT,
+    right  => _RIGHT,
+	max    => _MAX,
+	interval => _INTERVAL,
+);
+
+#using an array instead of a hash for the node
+sub _accessor {
+    my $index = shift;
+    return sub {
+        my $self = shift;
+		return undef unless $self;
+        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] = $obj->[_INTERVAL] = shift;
+        $obj->[_VAL] = shift;
+    }
+    return bless $obj, $class;
+}
+
+sub left_most {
+    my $self = shift;
+    while ($self->[_LEFT]) {
+        $self = $self->[_LEFT];
+    }
+    return $self;
+}
+
+sub right_most {
+    my $self = shift;
+    while ($self->[_RIGHT]) {
+        $self = $self->[_RIGHT];
+    }
+    return $self;
+}
+
+#find left_most leaf
+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]->left_most;
+    }
+    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]->right_most;
+    }
+    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][0],$node->[_KEY][1]]:$node->[_MAX]";
+    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
+
+# do wen need it? as we have accessors already
+sub set_color {
+    my ($node, $color) = @_;
+    if($node) {
+        $node->[_COLOR] = $color; 
+    }
+}
+
+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;
+}
+
+sub _overlap {
+	my ($a, $b) = @_;
+	return 1 if($a->[0] <= $b->[1] && $a->[1] >= $b->[0]);
+	return undef;
+}	
+
+sub intersect {
+	my $x = shift;
+	my $interval = shift;
+	return if(!$x);
+#	print $x->val->name, "\t", $x->key->[0], "\t", $x->key->[1], "\n";
+	my @rtn;
+	if(_overlap($x->interval, $interval)) {
+		push @rtn, $x;
+	}
+#	my $y = $x->parent;
+	if($x->left && $x->left->max >= $interval->[0] ) { # && (!$y || _overlap($interval, [$y->interval->[0], $x->left->max]))) {
+		push @rtn, $x->left->intersect($interval);
+	}
+	push @rtn, $x->right->intersect($interval) if($x->right && _overlap($interval, [$x->interval->[0], $x->right->max]));
+	return @rtn;
+}
+
+1;
+