annotate Tree/Interval.pm @ 1:4f6952e0af48 default tip

CREST - add crest.loc.sample
author Jim Johnson <jj@umn.edu>
date Wed, 08 Feb 2012 16:08:01 -0600
parents acc8d8bfeb9a
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
1 package Tree::Interval;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
2
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
3 use strict;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
4 use Carp;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
5
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
6 use Tree::Interval::Node qw[set_color color_of parent_of left_of right_of];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
7 use Tree::Interval::Node::Constants;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
8 use Tree::DAG_Node;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
9 use vars qw( $VERSION @EXPORT_OK );
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
10 $VERSION = 0.1;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
11
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
12 require Exporter;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
13 *import = \&Exporter::import;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
14 @EXPORT_OK = qw[LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
15
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
16 use enum qw{ LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV };
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
17
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
18 # object slots
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
19 use enum qw{ ROOT CMP SIZE };
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
20
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
21 sub new {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
22 my ($class, $cmp) = @_;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
23 my $obj = [];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
24 $obj->[SIZE] = 0;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
25 if($cmp) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
26 ref $cmp eq 'CODE'
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
27 or croak('Invalid arg: codref expected');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
28 $obj->[CMP] = $cmp;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
29 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
30 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
31 # default compare
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
32 $obj->[CMP] = sub { $_[0]->[0] <=> $_[1]->[0] || $_[0]->[1] <=> $_[1]->[1]};
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
33 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
34 return bless $obj => $class;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
35 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
36
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
37
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
38 sub DESTROY { $_[0]->[ROOT]->DESTROY if $_[0]->[ROOT] }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
39
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
40 sub root { $_[0]->[ROOT] }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
41 sub size { $_[0]->[SIZE] }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
42
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
43 sub left_most {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
44 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
45 return undef unless $self->[ROOT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
46 return $self->[ROOT]->left_most;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
47 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
48
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
49 sub right_most {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
50 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
51 return undef unless $self->[ROOT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
52 return $self->[ROOT]->right_most;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
53 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
54
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
55 # return all the intervals intersect with the interval
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
56 sub intersect {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
57 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
58 my $interval = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
59 return my @tmp unless $self->[ROOT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
60 return $self->[ROOT]->intersect($interval);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
61 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
62
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
63 sub lookup {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
64 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
65 my $key = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
66 defined $key
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
67 or croak("Can't use undefined value as key");
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
68 my $mode = shift || LUEQUAL;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
69 my $cmp = $self->[CMP];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
70
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
71 my $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
72 my $x = $self->[ROOT]
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
73 or return;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
74 my $next_child;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
75 while($x) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
76 $y = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
77 if($cmp ? $cmp->($key, $x->[_KEY]) == 0
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
78 : $key eq $x->[_KEY]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
79 # found it!
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
80 if($mode == LUGREAT || $mode == LUNEXT) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
81 $x = $x->successor;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
82 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
83 elsif($mode == LULESS || $mode == LUPREV) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
84 $x = $x->predecessor;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
85 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
86 return wantarray
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
87 ? ($x->[_VAL], $x)
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
88 : $x->[_VAL];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
89 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
90 if($cmp ? $cmp->($key, $x->[_KEY]) < 0
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
91 : $key lt $x->[_KEY]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
92 $next_child = _LEFT;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
93 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
94 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
95 $next_child = _RIGHT;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
96 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
97 $x = $x->[$next_child];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
98 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
99 # Didn't find it :(
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
100 if($mode == LUGTEQ || $mode == LUGREAT) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
101 if($next_child == _LEFT) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
102 return wantarray ? ($y->[_VAL], $y) : $y->[_VAL];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
103 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
104 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
105 my $next = $y->successor
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
106 or return;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
107 return wantarray ? ($next->[_VAL], $next) : $next->[_VAL];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
108 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
109 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
110 elsif($mode == LULTEQ || $mode == LULESS) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
111 if($next_child == _RIGHT) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
112 return wantarray ? ($y->[_VAL], $y) : $y->[_VAL];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
113 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
114 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
115 my $next = $y->predecessor
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
116 or return;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
117 return wantarray ? ($next->[_VAL], $next) : $next->[_VAL];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
118 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
119 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
120 return;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
121 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
122
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
123 sub insert {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
124 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
125 my $key_or_node = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
126 defined $key_or_node
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
127 or croak("Can't use undefined value as key or node");
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
128 my $val = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
129
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
130 my $cmp = $self->[CMP];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
131 my $z = (ref $key_or_node eq 'Tree::Interval::Node')
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
132 ? $key_or_node
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
133 : Tree::Interval::Node->new($key_or_node => $val);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
134
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
135 my $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
136 my $x = $self->[ROOT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
137 while($x) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
138 $y = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
139 # Handle case of inserting node with duplicate key.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
140 if($cmp ? $cmp->($z->[_KEY], $x->[_KEY]) == 0
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
141 : $z->[_KEY] eq $x->[_KEY])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
142 {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
143 warn "The same key (range) is already in the tree
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
144 it will be replaced!";
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
145 my $old_val = $x->[_VAL];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
146 $x->[_VAL] = $z->[_VAL];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
147 return $old_val;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
148 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
149
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
150 if($cmp ? $cmp->($z->[_KEY], $x->[_KEY]) < 0
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
151 : $z->[_KEY] lt $x->[_KEY])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
152 {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
153 $x = $x->[_LEFT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
154 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
155 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
156 $x = $x->[_RIGHT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
157 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
158 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
159 # insert new node
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
160 $z->[_PARENT] = $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
161 if(not defined $y) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
162 $self->[ROOT] = $z;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
163 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
164 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
165 if($cmp ? $cmp->($z->[_KEY], $y->[_KEY]) < 0
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
166 : $z->[_KEY] lt $y->[_KEY])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
167 {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
168 $y->[_LEFT] = $z;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
169 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
170 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
171 $y->[_RIGHT] = $z;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
172 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
173 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
174 _update_max($z);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
175 $self->_fix_after_insertion($z);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
176 $self->[SIZE]++;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
177 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
178
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
179 sub _fix_after_insertion {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
180 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
181 my $x = shift or croak('Missing arg: node');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
182
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
183 $x->[_COLOR] = RED;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
184 while($x != $self->[ROOT] && $x->[_PARENT][_COLOR] == RED) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
185 my ($child, $rotate1, $rotate2);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
186 if(($x->[_PARENT] || 0) == ($x->[_PARENT][_PARENT][_LEFT] || 0)) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
187 ($child, $rotate1, $rotate2) = (_RIGHT, '_left_rotate', '_right_rotate');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
188 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
189 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
190 ($child, $rotate1, $rotate2) = (_LEFT, '_right_rotate', '_left_rotate');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
191 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
192 my $y = $x->[_PARENT][_PARENT][$child];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
193
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
194 if($y && $y->[_COLOR] == RED) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
195 $x->[_PARENT][_COLOR] = BLACK;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
196 $y->[_COLOR] = BLACK;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
197 $x->[_PARENT][_PARENT][_COLOR] = RED;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
198 $x = $x->[_PARENT][_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
199 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
200 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
201 if($x == ($x->[_PARENT][$child] || 0)) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
202 $x = $x->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
203 $self->$rotate1($x);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
204 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
205 $x->[_PARENT][_COLOR] = BLACK;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
206 $x->[_PARENT][_PARENT][_COLOR] = RED;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
207 $self->$rotate2($x->[_PARENT][_PARENT]);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
208 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
209 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
210 $self->[ROOT][_COLOR] = BLACK;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
211 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
212
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
213 sub delete {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
214 my ($self, $key_or_node) = @_;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
215 defined $key_or_node
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
216 or croak("Can't use undefined value as key or node");
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
217
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
218 my $z = (ref $key_or_node eq 'Tree::Interval::Node')
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
219 ? $key_or_node
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
220 : ($self->lookup($key_or_node))[1];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
221 return unless $z;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
222
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
223 my $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
224 if($z->[_LEFT] && $z->[_RIGHT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
225 # (Notes kindly provided by Christopher Gurnee)
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
226 # When deleting a node 'z' which has two children from a binary search tree, the
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
227 # typical algorithm is to delete the successor node 'y' instead (which is
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
228 # guaranteed to have at most one child), and then to overwrite the key/values of
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
229 # node 'z' (which is still in the tree) with the key/values (which we don't want
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
230 # to lose) from the now-deleted successor node 'y'.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
231
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
232 # Since we need to return the deleted item, it's not good enough to overwrite the
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
233 # key/values of node 'z' with those of node 'y'. Instead we swap them so we can
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
234 # return the deleted values.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
235
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
236 $y = $z->predecessor;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
237 ($z->[_KEY], $y->[_KEY]) = ($y->[_KEY], $z->[_KEY]);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
238 ($z->[_VAL], $y->[_VAL]) = ($y->[_VAL], $z->[_VAL]);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
239 ($z->[_INTERVAL], $y->[_INTERVAL]) = ($y->[_INTERVAL], $z->[_INTERVAL]);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
240 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
241 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
242 $y = $z;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
243 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
244
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
245 # splice out $y
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
246 my $x = $y->[_LEFT] || $y->[_RIGHT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
247 if(defined $x) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
248 $x->[_PARENT] = $y->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
249 if(! defined $y->[_PARENT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
250 $self->[ROOT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
251 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
252 elsif($y == $y->[_PARENT][_LEFT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
253 $y->[_PARENT][_LEFT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
254 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
255 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
256 $y->[_PARENT][_RIGHT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
257 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
258 # Null out links so they are OK to use by _fix_after_deletion
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
259 delete @{$y}[_PARENT, _LEFT, _RIGHT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
260 _update_max($x);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
261 # Fix replacement
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
262 if($y->[_COLOR] == BLACK) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
263 $self->_fix_after_deletion($x);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
264 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
265 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
266 elsif(! defined $y->[_PARENT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
267 # return if we are the only node
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
268 delete $self->[ROOT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
269 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
270 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
271 # No children. Use self as phantom replacement and unlink
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
272 if($y->[_COLOR] == BLACK) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
273 $self->_fix_after_deletion($y);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
274 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
275 if(defined $y->[_PARENT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
276 no warnings 'uninitialized';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
277 if($y == $y->[_PARENT][_LEFT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
278 delete $y->[_PARENT][_LEFT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
279 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
280 elsif($y == $y->[_PARENT][_RIGHT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
281 delete $y->[_PARENT][_RIGHT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
282 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
283 my $tmp = $y->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
284 delete $y->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
285 _update_max($tmp);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
286 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
287 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
288 $self->[SIZE]--;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
289 return $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
290 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
291
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
292 sub _fix_after_deletion {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
293 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
294 my $x = shift or croak('Missing arg: node');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
295
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
296 while($x != $self->[ROOT] && color_of($x) == BLACK) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
297 my ($child1, $child2, $rotate1, $rotate2);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
298 no warnings 'uninitialized';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
299 if($x == left_of(parent_of($x))) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
300 ($child1, $child2, $rotate1, $rotate2) =
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
301 (\&right_of, \&left_of, '_left_rotate', '_right_rotate');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
302 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
303 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
304 ($child1, $child2, $rotate1, $rotate2) =
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
305 (\&left_of, \&right_of, '_right_rotate', '_left_rotate');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
306 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
307 use warnings;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
308
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
309 my $w = $child1->(parent_of($x));
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
310 if(color_of($w) == RED) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
311 set_color($w, BLACK);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
312 set_color(parent_of($x), RED);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
313 $self->$rotate1(parent_of($x));
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
314 $w = right_of(parent_of($x));
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
315 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
316 if(color_of($child2->($w)) == BLACK &&
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
317 color_of($child1->($w)) == BLACK) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
318 set_color($w, RED);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
319 $x = parent_of($x);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
320 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
321 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
322 if(color_of($child1->($w)) == BLACK) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
323 set_color($child2->($w), BLACK);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
324 set_color($w, RED);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
325 $self->$rotate2($w);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
326 $w = $child1->(parent_of($x));
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
327 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
328 set_color($w, color_of(parent_of($x)));
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
329 set_color(parent_of($x), BLACK);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
330 set_color($child1->($w), BLACK);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
331 $self->$rotate1(parent_of($x));
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
332 $x = $self->[ROOT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
333 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
334 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
335 set_color($x, BLACK);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
336 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
337
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
338
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
339 sub _max3 {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
340 my ($a, $b, $c) = @_;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
341 my $min = ($a || $b || $c) - 1;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
342 $a = $a || $min;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
343 $b = $b || $min;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
344 $c = $c || $min;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
345 return $a if($a >= $b && $a >= $c);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
346 return $b if($b >= $a && $b >= $c);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
347 return $c if($c >= $a && $c >= $b);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
348 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
349
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
350 sub _max {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
351 my $x = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
352 my $tmp = _max3($x->[_INTERVAL][1],
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
353 $x->[_LEFT] ? $x->[_LEFT][_MAX] : undef,
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
354 $x->[_RIGHT] ? $x->[_RIGHT][_MAX] : undef);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
355 $x->[_MAX] = $tmp;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
356 return $tmp;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
357 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
358
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
359 sub _update_max {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
360 my $x = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
361 #update the max field for each parent node
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
362 _max($x);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
363 my $k = $x->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
364 while($k) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
365 my $tmp = $k->[_MAX];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
366 _max($k);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
367 last if($tmp == $k->[_MAX]); # no need to update further
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
368 $k = $k->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
369 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
370 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
371
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
372 sub _left_rotate {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
373 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
374 my $x = shift or croak('Missing arg: node');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
375
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
376 my $y = $x->[_RIGHT]
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
377 or return;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
378 $x->[_RIGHT] = $y->[_LEFT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
379 if($y->[_LEFT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
380 $y->[_LEFT]->[_PARENT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
381 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
382 $y->[_PARENT] = $x->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
383 if(not defined $x->[_PARENT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
384 $self->[ROOT] = $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
385 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
386 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
387 $x == $x->[_PARENT]->[_LEFT]
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
388 ? $x->[_PARENT]->[_LEFT] = $y
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
389 : $x->[_PARENT]->[_RIGHT] = $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
390 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
391 $y->[_LEFT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
392 $x->[_PARENT] = $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
393 #update max
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
394 _max($x); _max($y);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
395 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
396
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
397 sub _right_rotate {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
398 my $self = shift;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
399 my $y = shift or croak('Missing arg: node');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
400
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
401 my $x = $y->[_LEFT]
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
402 or return;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
403 $y->[_LEFT] = $x->[_RIGHT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
404 if($x->[_RIGHT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
405 $x->[_RIGHT]->[_PARENT] = $y
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
406 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
407 $x->[_PARENT] = $y->[_PARENT];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
408 if(not defined $y->[_PARENT]) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
409 $self->[ROOT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
410 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
411 else {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
412 $y == $y->[_PARENT]->[_RIGHT]
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
413 ? $y->[_PARENT]->[_RIGHT] = $x
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
414 : $y->[_PARENT]->[_LEFT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
415 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
416 $x->[_RIGHT] = $y;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
417 $y->[_PARENT] = $x;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
418 _max($y); _max($x);
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
419 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
420
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
421 1;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
422
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
423 # Magic true value required at end of module
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
424 __END__
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
425
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
426 =head1 NAME
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
427
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
428 Tree::RB - Perl implementation of the Red/Black tree, a type of balanced binary search tree.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
429
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
430
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
431 =head1 VERSION
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
432
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
433 This document describes Tree::RB version 0.1
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
434
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
435
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
436 =head1 SYNOPSIS
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
437
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
438 use Tree::RB;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
439
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
440 my $tree = Tree::RB->new;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
441 $tree->put('France' => 'Paris');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
442 $tree->put('England' => 'London');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
443 $tree->put('Hungary' => 'Budapest');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
444 $tree->put('Ireland' => 'Dublin');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
445 $tree->put('Egypt' => 'Cairo');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
446 $tree->put('Germany' => 'Berlin');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
447
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
448 $tree->put('Alaska' => 'Anchorage'); # D'oh!
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
449 $tree->delete('Alaska');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
450
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
451 print $tree->get('Ireland'); # 'Dublin'
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
452
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
453 print $tree->min->key; # 'Egypt'
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
454 print $tree->max->key; # 'Ireland'
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
455 print $tree->size; # 6
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
456
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
457 # print items, ordered by key
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
458 my $it = $tree->iter;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
459
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
460 while(my $node = $it->next) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
461 sprintf "key = %s, value = %s\n", $node->key, $node->val;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
462 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
463
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
464 # print items in reverse order
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
465 $it = $tree->rev_iter;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
466
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
467 while(my $node = $it->next) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
468 sprintf "key = %s, value = %s\n", $node->key, $node->val;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
469 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
470
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
471 # Hash interface
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
472 tie my %capital, 'Tree::RB';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
473
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
474 # or do this to store items in descending order
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
475 tie my %capital, 'Tree::RB', sub { $_[1] cmp $_[0] };
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
476
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
477 $capital{'France'} = 'Paris';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
478 $capital{'England'} = 'London';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
479 $capital{'Hungary'} = 'Budapest';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
480 $capital{'Ireland'} = 'Dublin';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
481 $capital{'Egypt'} = 'Cairo';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
482 $capital{'Germany'} = 'Berlin';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
483
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
484 # print items in order
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
485 while(my ($key, $val) = each %capital) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
486 printf "key = $key, value = $val\n";
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
487 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
488
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
489 =head1 DESCRIPTION
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
490
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
491 This is a Perl implementation of the Red/Black tree, a type of balanced binary search tree.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
492
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
493 A tied hash interface is also provided to allow ordered hashes to be used.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
494
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
495 See the Wikipedia article at L<http://en.wikipedia.org/wiki/Red-black_tree> for more on Red/Black trees.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
496
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
497
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
498 =head1 INTERFACE
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
499
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
500 =head2 new([CODEREF])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
501
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
502 Creates and returns a new tree. If a reference to a subroutine is passed to
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
503 new(), the subroutine will be used to override the tree's default lexical
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
504 ordering and provide a user a defined ordering.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
505
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
506 This subroutine should be just like a comparator subroutine used with L<sort>,
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
507 except that it doesn't do the $a, $b trick.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
508
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
509 For example, to get a case insensitive ordering
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
510
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
511 my $tree = Tree::RB->new(sub { lc $_[0] cmp lc $_[1]});
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
512 $tree->put('Wall' => 'Larry');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
513 $tree->put('Smith' => 'Agent');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
514 $tree->put('mouse' => 'micky');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
515 $tree->put('duck' => 'donald');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
516
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
517 my $it = $tree->iter;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
518
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
519 while(my $node = $it->next) {
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
520 sprintf "key = %s, value = %s\n", $node->key, $node->val;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
521 }
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
522
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
523 =head2 resort(CODEREF)
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
524
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
525 Changes the ordering of nodes within the tree. The new ordering is
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
526 specified by a comparator subroutine which must be passed to resort().
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
527
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
528 See L</new> for further information about the comparator.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
529
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
530 =head2 size()
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
531
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
532 Returns the number of nodes in the tree.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
533
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
534 =head2 root()
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
535
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
536 Returns the root node of the tree. This will either be undef
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
537 if no nodes have been added to the tree, or a L<Tree::RB::Node> object.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
538 See the L<Tree::RB::Node> manual page for details on the Node object.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
539
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
540 =head2 min()
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
541
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
542 Returns the node with the minimal key.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
543
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
544 =head2 max()
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
545
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
546 Returns the node with the maximal key.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
547
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
548 =head2 lookup(KEY, [MODE])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
549
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
550 When called in scalar context, lookup(KEY) returns the value
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
551 associated with KEY.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
552
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
553 When called in list context, lookup(KEY) returns a list whose first
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
554 element is the value associated with KEY, and whose second element
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
555 is the node containing the key/value.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
556
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
557 An optional MODE parameter can be passed to lookup() to influence
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
558 which key is returned.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
559
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
560 The values of MODE are constants that are exported on demand by
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
561 Tree::RB
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
562
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
563 use Tree::RB qw[LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV];
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
564
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
565 =over
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
566
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
567 =item LUEQUAL
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
568
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
569 Returns node exactly matching the key.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
570
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
571 =item LUGTEQ
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
572
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
573 Returns the node exactly matching the specified key,
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
574 if this is not found then the next node that is greater than the specified key is returned.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
575
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
576 =item LULTEQ
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
577
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
578 Returns the node exactly matching the specified key,
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
579 if this is not found then the next node that is less than the specified key is returned.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
580
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
581 =item LUGREAT
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
582
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
583 Returns the node that is just greater than the specified key - not equal to.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
584 This mode is similar to LUNEXT except that the specified key need not exist in the tree.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
585
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
586 =item LULESS
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
587
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
588 Returns the node that is just less than the specified key - not equal to.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
589 This mode is similar to LUPREV except that the specified key need not exist in the tree.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
590
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
591 =item LUNEXT
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
592
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
593 Looks for the key specified, if not found returns C<undef>.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
594 If the node is found returns the next node that is greater than
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
595 the one found (or C<undef> if there is no next node).
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
596
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
597 This can be used to step through the tree in order.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
598
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
599 =item LUPREV
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
600
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
601 Looks for the key specified, if not found returns C<undef>.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
602 If the node is found returns the previous node that is less than
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
603 the one found (or C<undef> if there is no previous node).
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
604
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
605 This can be used to step through the tree in reverse order.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
606
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
607 =back
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
608
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
609 =head2 get(KEY)
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
610
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
611 get() is an alias for lookup().
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
612
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
613 =head2 iter([KEY])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
614
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
615 Returns an iterator object that can be used to traverse the tree in order.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
616
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
617 The iterator object supports a 'next' method that returns the next node in the
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
618 tree or undef if all of the nodes have been visited.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
619
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
620 See the synopsis for an example.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
621
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
622 If a key is supplied, the iterator returned will traverse the tree in order starting from
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
623 the node with key greater than or equal to the specified key.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
624
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
625 $it = $tree->iter('France');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
626 my $node = $it->next;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
627 print $node->key; # -> 'France'
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
628
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
629 =head2 rev_iter([KEY])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
630
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
631 Returns an iterator object that can be used to traverse the tree in reverse order.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
632
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
633 If a key is supplied, the iterator returned will traverse the tree in order starting from
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
634 the node with key less than or equal to the specified key.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
635
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
636 $it = $tree->rev_iter('France');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
637 my $node = $it->next;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
638 print $node->key; # -> 'England'
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
639
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
640 =head2 hseek(KEY, [{-reverse => 1|0}])
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
641
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
642 For tied hashes, determines the next entry to be returned by each.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
643
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
644 tie my %capital, 'Tree::RB';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
645
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
646 $capital{'France'} = 'Paris';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
647 $capital{'England'} = 'London';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
648 $capital{'Hungary'} = 'Budapest';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
649 $capital{'Ireland'} = 'Dublin';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
650 $capital{'Egypt'} = 'Cairo';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
651 $capital{'Germany'} = 'Berlin';
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
652 tied(%capital)->hseek('Germany');
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
653
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
654 ($key, $val) = each %capital;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
655 print "$key, $val"; # -> Germany, Berlin
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
656
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
657 The direction of iteration can be reversed by passing a hashref with key '-reverse' and value 1
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
658 to hseek after or instead of KEY, e.g. to iterate over the hash in reverse order:
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
659
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
660 tied(%capital)->hseek({-reverse => 1});
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
661 $key = each %capital;
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
662 print $key; # -> Ireland
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
663
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
664 The following calls are equivalent
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
665
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
666 tied(%capital)->hseek('Germany', {-reverse => 1});
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
667 tied(%capital)->hseek({-key => 'Germany', -reverse => 1});
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
668
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
669 =head2 put(KEY, VALUE)
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
670
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
671 Adds a new node to the tree.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
672
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
673 The first argument is the key of the node, the second is its value.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
674
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
675 If a node with that key already exists, its value is replaced with
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
676 the given value and the old value is returned. Otherwise, undef is returned.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
677
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
678 =head2 delete(KEY)
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
679
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
680 If the tree has a node with the specified key, that node is
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
681 deleted from the tree and returned, otherwise C<undef> is returned.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
682
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
683
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
684 =head1 DEPENDENCIES
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
685
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
686 L<enum>
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
687
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
688
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
689 =head1 INCOMPATIBILITIES
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
690
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
691 None reported.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
692
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
693
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
694 =head1 BUGS AND LIMITATIONS
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
695
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
696 Please report any bugs or feature requests to
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
697 C<bug-tree-rb@rt.cpan.org>, or through the web interface at
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
698 L<http://rt.cpan.org>.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
699
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
700
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
701 =head1 AUTHOR
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
702
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
703 Arun Prasad C<< <arunbear@cpan.org> >>
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
704
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
705 Some documentation has been borrowed from Benjamin Holzman's L<Tree::RedBlack>
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
706 and Damian Ivereigh's libredblack (L<http://libredblack.sourceforge.net/>).
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
707
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
708 =head1 ACKNOWLEDGEMENTS
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
709
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
710 Thanks for bug reports go to Anton Petrusevich, Wes Thompson and Christopher Gurnee.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
711
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
712 =head1 LICENCE AND COPYRIGHT
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
713
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
714 Copyright (c) 2007, Arun Prasad C<< <arunbear@cpan.org> >>. All rights reserved.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
715
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
716 This module is free software; you can redistribute it and/or
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
717 modify it under the same terms as Perl itself. See L<perlartistic>.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
718
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
719
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
720 =head1 DISCLAIMER OF WARRANTY
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
721
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
722 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
723 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
724 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
725 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
726 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
727 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
728 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
729 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
730 NECESSARY SERVICING, REPAIR, OR CORRECTION.
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
731
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
732 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
733 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
734 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
735 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
736 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
737 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
738 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
739 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
740 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
acc8d8bfeb9a Uploaded
jjohnson
parents:
diff changeset
741 SUCH DAMAGES.