|
0
|
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
|
