Mercurial > repos > jjohnson > crest

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Uploaded
author jjohnson
date Wed, 08 Feb 2012 16:59:24 -0500
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:acc8d8bfeb9a
1 package Tree::Interval::Node;
2
3 use strict;
4 use Carp;
5 use Tree::Interval::Node::Constants;
6 use vars qw( $VERSION @EXPORT_OK );
7
8 require Exporter;
9 *import = \&Exporter::import;
10 @EXPORT_OK = qw[set_color color_of parent_of left_of right_of];
11
12 $VERSION = '0.1';
13
14 # key and interval is the same thing
15 my %attribute = (
16 key => _KEY,
17 val => _VAL,
18 color => _COLOR,
19 parent => _PARENT,
20 left => _LEFT,
21 right => _RIGHT,
22 max => _MAX,
23 interval => _INTERVAL,
24 );
25
26 #using an array instead of a hash for the node
27 sub _accessor {
28 my $index = shift;
29 return sub {
30 my $self = shift;
31 return undef unless $self;
32 if (@_) {
33 $self->[$index] = shift;
34 }
35 return $self->[$index];
36 };
37 }
38
39 while(my($at, $idx) = each %attribute) {
40 no strict 'refs';
41 *$at = _accessor($idx);
42 }
43
44 sub new {
45 my $class = shift;
46 my $obj = [];
47
48 if (@_) {
49 $obj->[_KEY] = $obj->[_INTERVAL] = shift;
50 $obj->[_VAL] = shift;
51 }
52 return bless $obj, $class;
53 }
54
55 sub left_most {
56 my $self = shift;
57 while ($self->[_LEFT]) {
58 $self = $self->[_LEFT];
59 }
60 return $self;
61 }
62
63 sub right_most {
64 my $self = shift;
65 while ($self->[_RIGHT]) {
66 $self = $self->[_RIGHT];
67 }
68 return $self;
69 }
70
71 #find left_most leaf
72 sub leaf {
73 my $self = shift;
74 while (my $any_child = $self->[_LEFT] || $self->[_RIGHT]) {
75 $self = $any_child;
76 }
77 return $self;
78 }
79
80 sub successor {
81 my $self = shift;
82 if ($self->[_RIGHT]) {
83 return $self->[_RIGHT]->left_most;
84 }
85 my $parent = $self->[_PARENT];
86 while ($parent && $parent->[_RIGHT] && $self == $parent->[_RIGHT]) {
87 $self = $parent;
88 $parent = $parent->[_PARENT];
89 }
90 return $parent;
91 }
92
93 sub predecessor {
94 my $self = shift;
95 if ($self->[_LEFT]) {
96 return $self->[_LEFT]->right_most;
97 }
98 my $parent = $self->[_PARENT];
99 while ($parent && $parent->[_LEFT] && $self == $parent->[_LEFT]) {
100 $self = $parent;
101 $parent = $parent->[_PARENT];
102 }
103 return $parent;
104 }
105
106 sub as_lol {
107 my $self = shift;
108 my $node = shift || $self;
109 my $aref;
110 push @$aref,
111 $node->[_LEFT]
112 ? $self->as_lol($node->[_LEFT])
113 : '*';
114 push @$aref,
115 $node->[_RIGHT]
116 ? $self->as_lol($node->[_RIGHT])
117 : '*';
118 my $color = ($node->[_COLOR] == RED ? 'R' : 'B');
119 no warnings 'uninitialized';
120 push @$aref, "$color:[$node->[_KEY][0],$node->[_KEY][1]]:$node->[_MAX]";
121 return $aref;
122 }
123
124 sub strip {
125 my $self = shift;
126 my $callback = shift;
127
128 my $x = $self;
129 while($x) {
130 my $leaf = $x->leaf;
131 $x = $leaf->[_PARENT];
132
133 # detach $leaf from the (sub)tree
134 no warnings "uninitialized";
135 if($leaf == $x->[_LEFT]) {
136 undef $x->[_LEFT];
137 }
138 else {
139 undef $x->[_RIGHT];
140 }
141 undef $leaf->[_PARENT];
142 if($callback) {
143 $callback->($leaf);
144 }
145
146 if(!$x->[_LEFT] && !$x->[_RIGHT]) {
147 $x = $x->[_PARENT];
148 }
149 }
150 }
151
152 sub DESTROY { $_[0]->strip; }
153
154 # Null aware accessors to assist with rebalancings during insertion and deletion
155 #
156 # A weird case of Java to the rescue!
157 # These are inspired by http://www.javaresearch.org/source/jdk142/java/util/TreeMap.java.html
158 # which was found via http://en.wikipedia.org/wiki/Red-black_tree#Implementations
159
160 # do wen need it? as we have accessors already
161 sub set_color {
162 my ($node, $color) = @_;
163 if($node) {
164 $node->[_COLOR] = $color;
165 }
166 }
167
168 sub color_of {
169 $_[0] ? $_[0]->[_COLOR] : BLACK;
170 }
171
172 sub parent_of {
173 $_[0] ? $_[0]->[_PARENT] : undef;
174 }
175
176 sub left_of {
177 $_[0] ? $_[0]->[_LEFT] : undef;
178 }
179
180 sub right_of {
181 $_[0] ? $_[0]->[_RIGHT] : undef;
182 }
183
184 sub _overlap {
185 my ($a, $b) = @_;
186 return 1 if($a->[0] <= $b->[1] && $a->[1] >= $b->[0]);
187 return undef;
188 }
189
190 sub intersect {
191 my $x = shift;
192 my $interval = shift;
193 return if(!$x);
194 # print $x->val->name, "\t", $x->key->[0], "\t", $x->key->[1], "\n";
195 my @rtn;
196 if(_overlap($x->interval, $interval)) {
197 push @rtn, $x;
198 }
199 # my $y = $x->parent;
200 if($x->left && $x->left->max >= $interval->[0] ) { # && (!$y || _overlap($interval, [$y->interval->[0], $x->left->max]))) {
201 push @rtn, $x->left->intersect($interval);
202 }
203 push @rtn, $x->right->intersect($interval) if($x->right && _overlap($interval, [$x->interval->[0], $x->right->max]));
204 return @rtn;
205 }
206
207 1;
208