File Coverage

blib/lib/Tree/AVL.pm
Criterion Covered Total %
statement 293 582 50.3
branch 127 290 43.7
condition 17 36 47.2
subroutine 26 47 55.3
pod 14 40 35.0
total 477 995 47.9


line stmt bran cond sub pod time code
1             ##############################################################################
2             #
3             # AVL.pm
4             #
5             # An implementation of an AVL tree for storing comparable objects.
6             #
7             # AVL Trees are balanced binary trees, first introduced
8             # in "An Algorithm for the Organization of Data" by
9             # Adelson-Velskii and Landis in 1962.
10             #
11             # Balance is kept in an AVL tree during insertion and
12             # deletion by maintaining a 'balance' factor in each node.
13             #
14             # If the subtree below any node in the tree is evenly balanced,
15             # the balance factor for that node will be 0.
16             #
17             # When the right-subtree below a node is taller than the left-subtree,
18             # the balance factor will be 1. For the opposite case, the balance
19             # factor will be -1.
20             #
21             # If the either subtree is heavier (taller by more than 2 levels) than the
22             # other, the balance factor within the node will be set to (+-)2,
23             # and the subtree below that node will be rebalanced.
24             #
25             # Re-balancing is done via 'single' or 'double' rotations, each of which
26             # takes constant-time.
27             #
28             # Insertion into an AVL tree will require at most 1 rotation.
29             #
30             # Deletion from an AVL tree may take as much as log(n) rotations
31             # in order to restore balance.
32             #
33             # Balanced trees can save huge amounts of time in your programs
34             # when used over regular flat data-structures. For example, if
35             # you are processing as much as 1,125,899,906,842,624 ordered objects
36             # on some super awesome mega workstation, the worst-case time (comparisons)
37             # required to access one of those objects will be on the order of
38             # ~1,125,899,906,842,624 (one quadrillion, one hundred twenty-five trillion,
39             # eight hundred eighty-nine billion, nine hundred six million, eight hundred
40             # forty-two thousand, six hundred twenty-four) if you keep them in a flat
41             # data structure. However, using a balanced tree such as a 2-3 tree, a
42             # Red-Black tree or an AVL tree, the worst-case time (comparisons) required
43             # will be on the order of 50.
44             #
45             ##############################################################################
46              
47             package Tree::AVL;
48              
49 1     1   15320 use Carp;
  1         1  
  1         73  
50 1     1   4 use strict;
  1         2  
  1         24  
51 1     1   3 use warnings;
  1         4  
  1         4111  
52              
53             our $VERSION = '1.076';
54              
55              
56             ##################################################
57             #
58             # AVL tree constructor
59             #
60             ##################################################
61             sub new {
62 1     1 1 10 my $invocant = shift;
63 1   33     6 my $class = ref($invocant) || $invocant;
64 1         7 my $self = {
65             _node => {
66             _obj => undef, # Object to store in AVL tree
67             _left_node => undef,
68             _right_node => undef,
69             _height => 0,
70             _balance => 0, # (abs(balance) < 2) <-> AVL property
71             },
72              
73             fcompare => undef, # comparison function
74             fget_key => undef, # function to get key from obj
75             fget_data => undef, # function to get data from obj
76            
77             acc_lookup_hash => undef,
78             @_, # Override previous attributes
79             };
80              
81 1         3 $self = bless $self, $class;
82              
83 1 50       5 if(!$self->{fcompare}){
84 1         3 $self->{fcompare} = \&default_cmp_func;
85             }
86 1 50       3 if(!$self->{fget_key}){
87 1     33   5 $self->{fget_key} = sub{ return $_[0]; };
  33         39  
88             }
89 1 50       3 if(!$self->{fget_data}){
90 1     0   6 $self->{fget_data} = sub{ return $_[0]; };
  0         0  
91             }
92              
93 1         16 return $self;
94             }
95              
96              
97             #
98             # insert
99             #
100             # usage: $tree->insert($object);
101             #
102             sub insert
103             {
104 7     7 1 2425 my ($self, $object) = @_;
105 7 50       16 if(!defined($object)){
106 0         0 croak "Error: cannot insert uninitialized object into AVL tree.\n";
107             }
108 7         13 $self->avl_insert($object);
109 7         14 return;
110             }
111              
112              
113             #
114             # avl_insert
115             #
116             # usage: $tree_object->avl_insert($object);
117             #
118             sub avl_insert
119             {
120 12     12 0 13 my ($self, $object, $node, $depth) = @_;
121              
122 12 100       21 if(!$depth){
123 7         6 $depth = 0;
124             }
125 12 100       18 if(!$node){
126 7         10 $node = \$self->{_node};
127             }
128            
129 12         14 my $get_key_func = $self->{fget_key};
130 12         15 my $key = $get_key_func->($object);
131            
132 12         15 my $node_obj = $$node->{_obj};
133 12         6 my $own_key;
134            
135 12         11 my $increase = 0;
136 12         10 my $change = 0;
137              
138 12 100       21 if( !defined($self->{_node}->{_obj}) ) # no root data yet, so populate with $object
139             {
140 2         3 $self->{_node}->{_obj} = $object;
141              
142 2         3 return;
143             }
144             else # need to insert object if object is not already in tree
145             {
146 10         13 $own_key = $node_obj->$get_key_func();
147 10 50       18 if(!defined($own_key)){
148 0         0 croak "Error: get_key() method provided to Tree::AVL object returned a null value\n";
149             }
150              
151 10         12 my $cmpfunc = $self->{fcompare};
152 10         13 my $result = $cmpfunc->($node_obj, $object);
153            
154 10 50       19 if($result == 0){ #element is already in tree, do nothing.
    100          
155 0         0 return 0;
156             }
157             elsif($result < 0){ # insert into right subtree
158 7 100       12 if (!defined($$node->{_right_node})){ # Need to create a new node.
159              
160              
161 3         11 my $new_node = {
162             _obj => $object,
163             _balance => 0,
164             _right_node => undef,
165             _left_node => undef,
166             };
167            
168 3         4 $$node->{_right_node} = $new_node;
169 3         4 $increase = 1;
170             }
171             else{ # descend and insert into right subtree
172 4         13 $change = $self->avl_insert($object, \$$node->{_right_node}, $depth+1);
173 4         7 $increase = 1 * $change;
174             }
175             }
176             else{ # insert into left subtree
177 3 100       7 if (!defined($$node->{_left_node})){ # Need to create a new node.
178              
179 2         5 my $new_node = {
180             _obj => $object,
181             _balance => 0,
182             _right_node => undef,
183             _left_node => undef,
184             };
185            
186 2         4 $$node->{_left_node} = $new_node;
187 2         2 $increase = -1;
188             }
189             else{ # descend and insert into left subtree
190 1         5 $change = $self->avl_insert($object, \$$node->{_left_node}, $depth+1);
191 1         2 $increase = -1 * $change;
192             }
193             }
194             } # end else determine whether need to insert into left or right subtree
195              
196 10         14 $$node->{_balance} = $$node->{_balance} + $increase;
197              
198 10 100 100     36 if($increase && $$node->{_balance}){
199 8         17 my $height_change = $self->rebalance($node);
200 8         9 $change = 1 - $height_change;
201             }
202             else{
203 2         12 $change = 0;
204             }
205              
206 10 100       18 if($depth == 0){
207 5         5 $self->{_node} = $$node;
208             }
209              
210 10         16 return $change;
211             }
212              
213              
214             #
215             # remove
216             #
217             # usage: my $found_obj = $avltree->remove($object);
218             #
219             # remove an object from tree.
220             #
221             #
222             sub remove
223             {
224 3     3 1 1265 my ($self, $object) = @_;
225 3         10 my ($obj) = $self->delete($object);
226 3         9 return $obj;
227             }
228              
229              
230             #
231             # avl_delete
232             #
233             # usage: ($found_obj) = $tree->delete($object);
234             #
235             #
236             sub delete
237             {
238            
239 5     5 0 7 my ($self, $object, $node, $depth) = @_;
240            
241 5 100       11 if(!$node){
242 3         496 $node = \$self->{_node};
243             }
244 5 100       9 if(!$depth){
245 3         3 $depth = 0;
246             }
247            
248 5         5 my $deleted_node;
249 5         4 my $change = 0;
250 5         3 my $decrease = 0;
251              
252 5 50       13 if(!defined($$node->{_obj})){ # no root data yet
253 0         0 return;
254             }
255             else{
256 5         5 my $node_obj = $$node->{_obj};
257 5         7 my $get_key_func = $self->{fget_key};
258 5         7 my $own_key = $get_key_func->($node_obj);
259 5         5 my $cmpfunc = $self->{fcompare};
260            
261 5         7 my $result = $cmpfunc->($node_obj, $object);
262 5 100       23 if($result > 0){ # look into left subtree
    100          
    50          
263 1 50       4 if (!defined($$node->{_left_node})){
264 0         0 return;
265             }
266             else{
267 1         6 ($deleted_node, my $new_ref, $change) = Tree::AVL::delete($self, $object, \$$node->{_left_node}, $depth+1);
268 1 50       2 if($deleted_node){
269 0         0 $$node->{_left_node} = $new_ref;
270 0         0 $decrease = -1 * $change;
271             }
272             else{
273 1         2 return;
274             }
275             }
276             }
277             elsif($result < 0){ # look into right subtree
278 2 100       6 if (!defined($$node->{_right_node})){
279 1         2 return;
280             }
281             else{
282 1         5 ($deleted_node, my $new_ref, $change) = Tree::AVL::delete($self, $object, \$$node->{_right_node}, $depth+1);
283 1 50       3 if($deleted_node){
284 0         0 $$node->{_right_node} = $new_ref;
285 0         0 $decrease = 1 * $change;
286             }
287             else{
288 1         2 return;
289             }
290             }
291             }
292             elsif($result == 0){ # this the node we want to delete FOUND THE NODE.
293 2         3 $deleted_node = $$node->{_obj};
294              
295 2 100 66     20 if(!$$node->{_left_node} && !$$node->{_right_node}){ # this is the node to delete, and it is a leaf node.
    50 33        
    50          
    50          
296            
297 1 50       3 if($depth == 0){ # this is also the root node.
298            
299 1         4 $$node = {
300             _obj => undef,
301             _balance => 0,
302             _right_node => undef,
303             _left_node => undef,
304             };
305            
306             }
307             else{
308             # this is the node to delete. It is not the root node and it has no children (it is a leaf)
309 0         0 $$node = undef;
310            
311 0         0 $change = 1;
312 0         0 return ($deleted_node, $$node, $change);
313             }
314             }
315             elsif(!$$node->{_left_node}){
316 0         0 $$node = $$node->{_right_node};
317 0         0 $change = 1;
318            
319 0         0 return ($deleted_node, $$node, $change);
320             }
321             elsif(!$$node->{_right_node}){
322 0         0 $$node = $$node->{_left_node};
323 0         0 $change = 1;
324              
325 0         0 return ($deleted_node, $$node, $change);
326             }
327             elsif($$node->{_right_node} && $$node->{_left_node}){
328 1         4 (my $new_root_obj, $$node->{_right_node}, $change) = $self->delete_smallest(\$$node->{_right_node});
329 1 50       30 if($self->is_empty($$node->{_right_node})){
330 0         0 delete $$node->{_right_node};
331             }
332 1         2 $$node->{_obj} = $new_root_obj;
333             }
334            
335 2         3 $decrease = $change;
336            
337             } # end else determine whether need to look into left or right subtree, or neither
338             } # end else() there was root data.
339              
340 2         4 $$node->{_balance} = $$node->{_balance} - $decrease;
341 2 100       3 if($decrease){
342 1 50       2 if($$node->{_balance}){
343 1         5 $change = $self->rebalance($node);
344             }
345             else{
346 0         0 $change = 1;
347             }
348             }
349             else{
350 1         1 $change = 0;
351             }
352              
353 2         4 return ($deleted_node, $$node, $change);
354             }
355              
356              
357             #
358             # delete_smallest
359             #
360             # usage: $tree_object->delete_smallest();
361             #
362             sub delete_smallest
363             {
364 4     4 0 6 my ($self,
365             $node,
366             $depth) = @_;
367              
368 4 100       8 if(!$node){
369 1         3 $node = \$self->{_node};
370             }
371              
372 4         6 my $node_obj = $$node->{_obj};
373 4         6 my $get_key_func = $self->{fget_key};
374 4         6 my $own_key = $get_key_func->($node_obj);
375 4         4 my $decrease = 0;
376 4         5 my $change = 0;
377              
378 4 100       9 if(!$$node->{_left_node}){
379 2         2 my $obj = $$node->{_obj};
380 2 50 66     9 if(!$$node->{_right_node} && !$depth){
381 0         0 $$node = {
382             _obj => undef,
383             _balance => 0,
384             _right_node => undef,
385             _left_node => undef,
386             };
387 0         0 $change = 1;
388             }
389             else{
390 2 100       4 if($$node->{_right_node}){
391 1         2 $$node = $$node->{_right_node};
392             }
393             else{
394 1         2 $$node = undef;
395             }
396 2 100       6 if($$node){
397 1         2 $$node->{_balance} = 0;
398             }
399 2         3 $change = 1;
400             }
401 2         6 return ($obj, $$node, $change);
402             }
403             else{
404 2         11 my ($obj, $newleft, $change) = Tree::AVL::delete_smallest($self, \$$node->{_left_node}, 1);
405 2         3 $decrease = -1 * $change;
406 2         2 $$node->{_left_node} = $newleft;
407 2         3 $$node->{_balance} = $$node->{_balance} - $decrease;
408 2 100       5 if($decrease){
409 1 50       9 if($$node->{_balance}){
410 1         3 $change = $self->rebalance($node);
411             }
412             else{
413 0         0 $change = 1;
414             }
415             }
416 2         4 return ($obj, $$node, $change);
417             }
418             }
419              
420              
421             #
422             # delete_largest
423             #
424             # usage: $tree_object->delete_largest();
425             #
426             sub delete_largest
427             {
428 2     2 0 3 my ($self,
429             $node,
430             $depth) = @_;
431              
432 2 100       5 if(!$node){
433 1         3 $node = \$self->{_node};
434             }
435              
436 2         3 my $node_obj = $$node->{_obj};
437 2         1 my $get_key_func = $self->{fget_key};
438 2         5 my $own_key = $get_key_func->($node_obj);
439 2         1 my $decrease = 0;
440 2         3 my $change = 0;
441              
442 2 100       4 if(!$$node->{_right_node}){
443 1         2 my $obj = $$node->{_obj};
444 1 50 33     5 if(!$$node->{_left_node} && !$depth){
445 0         0 $$node = {
446             _obj => undef,
447             _balance => 0,
448             _right_node => undef,
449             _left_node => undef,
450             };
451 0         0 $change = 1;
452             }
453             else{
454 1 50       3 if($$node->{_left_node}){
455 0         0 $$node = $$node->{_left_node};
456             }
457             else{
458 1         1 $$node = undef;
459             }
460 1 50       3 if($$node){
461 0         0 $$node->{_balance} = 0;
462             }
463 1         2 $change = 1;
464             }
465 1         2 return ($obj, $$node, $change);
466             }
467             else{
468 1         5 my ($obj, $newright, $change) = Tree::AVL::delete_largest($self, \$$node->{_right_node}, 1);
469 1         1 $decrease = 1 * $change;
470 1         2 $$node->{_right_node} = $newright;
471 1         2 $$node->{_balance} = $$node->{_balance} - $decrease;
472 1 50       2 if($decrease){
473 1 50       2 if($$node->{_balance}){
474 1         3 $change = $self->rebalance($node);
475             }
476             else{
477 0         0 $change = 1;
478             }
479             }
480 1         2 return ($obj, $$node, $change);
481             }
482             }
483              
484              
485              
486              
487             #
488             # rebalance
489             #
490             # Determines what sort of, if any, imbalance exists in the subtree
491             # rooted at $node, and calls the correct rotation subroutine.
492             #
493             sub rebalance
494             {
495 11     11 0 11 my ($self, $node) = @_;
496 11         8 my $height_change = 0;
497              
498 11 100       28 if($$node->{_balance} < -1){ # left heavy
    100          
499 1 50       4 if($$node->{_left_node}){
500 1 50       4 if($$node->{_left_node}->{_balance} == 1){ # right heavy
501 1         6 $height_change = $self->double_rotate_right($node);
502             }
503             else{
504 0         0 $height_change = $self->rotate_right($node);
505             }
506             }
507             }
508             elsif($$node->{_balance} > 1){ # right heavy
509 2 50       7 if($$node->{_right_node}){
510 2 100       7 if($$node->{_right_node}->{_balance} == -1){ # left heavy
511 1         6 $height_change = $self->double_rotate_left($node);
512             }
513             else{
514 1         4 $height_change = $self->rotate_left($node);
515             }
516             }
517             }
518 11         15 return $height_change;
519             }
520              
521              
522              
523             #
524             # rotate_right
525             #
526             # A single right-rotation. Yes, this is *very* similar code for right and left operations,
527             # but these subroutines have not been merged to one in the interest of clarity. After all, according to
528             # Abelson and Sussman, programs are for humans to read above all, and only incidentally for machines
529             # to run. Not that this code is as readable as it could be, of course.
530             #
531             sub rotate_right
532             {
533 2     2 0 3 my ($self, $node) = @_;
534 2         2 my $height_change = 0;
535 2         3 my $lr_grandchild;
536             my $lnode;
537              
538 2 50       5 if($$node->{_left_node}){
539 2         2 $lnode = $$node->{_left_node};
540             }
541            
542             # determine height_change
543 2 100 66     8 if($$node->{_right_node} && $$node->{_left_node}){
544 1 50       4 $height_change = $$node->{_left_node}->{_balance} == 0 ? 0 : 1;
545             }
546             else{
547 1         2 $height_change = 1;
548             }
549            
550             # do the rotation
551 2 50       5 if(defined($$node->{_left_node})){
552 2 50       5 if($$node->{_left_node}->{_right_node}){
553 0         0 $lr_grandchild = $$node->{_left_node}->{_right_node}; # becomes left child's new right child
554             }
555             }
556 2         3 $$node->{_left_node} = $lr_grandchild;
557 2 50       4 if($lnode){
558 2         2 $lnode->{_right_node} = $$node;
559 2         3 $$node = $lnode;
560             }
561              
562             # update balances
563 2 50       5 if($$node->{_right_node}){
564 2         4 $$node->{_right_node}->{_balance} = $$node->{_right_node}->{_balance} + (1 - min($$node->{_balance}, 0));
565 2         5 $$node->{_balance} = $$node->{_balance} + (1 + max($$node->{_right_node}->{_balance}, 0));
566             }
567              
568 2         3 return $height_change;
569             }
570              
571             #
572             # rotate_left
573             #
574             # A single left-rotation. Yes, this is *very* similar code for right and left operations,
575             # but these subroutines have not been merged to one in the interest of clarity. After all, according to
576             # Abelson and Sussman, programs are for humans to read above all, and only incidentally for machines
577             # to run. Not that this code is as readable as it could be, of course.
578             #
579             sub rotate_left
580             {
581 3     3 0 7 my ($self, $node) = @_;
582 3         4 my $height_change = 0;
583 3         2 my $rl_grandchild;
584             my $rnode;
585            
586 3 50       7 if($$node->{_right_node}){
587 3         3 $rnode = $$node->{_right_node};
588             }
589              
590             # determine height_change
591 3 100 66     11 if($$node->{_left_node} && $$node->{_right_node}){
592 1 50       3 $height_change = $$node->{_right_node}->{_balance} == 0 ? 0 : 1;
593             }
594             else{
595 2         1 $height_change = 1;
596             }
597              
598 3 50       8 if(defined($$node->{_right_node})){
599 3 100       6 if($$node->{_right_node}->{_left_node}){
600 1         2 $rl_grandchild = $$node->{_right_node}->{_left_node}; # becomes left child's new right child
601             }
602             }
603 3         4 $$node->{_right_node} = $rl_grandchild;
604              
605 3 50       8 if($rnode){
606 3         4 $rnode->{_left_node} = $$node;
607 3         3 $$node = $rnode;
608             }
609              
610             # update balances
611 3 50       10 if($$node->{_left_node}){
612 3         10 $$node->{_left_node}->{_balance} = $$node->{_left_node}->{_balance} - (1 + max($$node->{_balance}, 0));
613 3         10 $$node->{_balance} = $$node->{_balance} - (1 - min($$node->{_left_node}->{_balance}, 0));
614             }
615              
616 3         4 return $height_change;
617             }
618              
619              
620             #
621             # double_rotate_right
622             #
623             # A double right-rotation. Yes, this is *very* similar code for right and left operations,
624             # but these subroutines have not been merged to one in the interest of clarity. After all, according to
625             # Abelson and Sussman, programs are for humans to read above all, and only incidentally for machines
626             # to run. Not that this code is as readable as it could be, of course.
627             #
628             sub double_rotate_right
629             {
630 1     1 0 2 my ($self, $node) = @_;
631            
632 1         2 my $old_balance = $$node->{_balance};
633 1         1 my $old_l_balance = 0;
634 1         1 my $old_r_balance = 0;
635            
636 1 50       13 if($$node->{_left_node}){
637 1         2 $old_l_balance = $$node->{_left_node}->{_balance};
638             }
639 1 50       3 if($$node->{_right_node}){
640 0         0 $old_r_balance = $$node->{_right_node}->{_balance};
641             }
642              
643 1 50       3 if($$node->{_left_node}){
644 1         3 $self->rotate_left(\$$node->{_left_node});
645             }
646              
647 1         4 $self->rotate_right($node);
648            
649 1 50       2 if($$node->{_left_node}){
650 1         3 $$node->{_left_node}->{_balance} = -1 * max($old_r_balance, 0);
651             }
652 1 50       3 if($$node->{_right_node}){
653 1         2 $$node->{_right_node}->{_balance} = -1 * min($old_r_balance, 0);
654             }
655 1         2 $$node->{_balance} = 0;
656            
657            
658 1         2 return 1;
659             }
660              
661              
662             #
663             # double_rotate_left
664             #
665             # A double left-rotation. Yes, this is *very* similar code for right and left operations,
666             # but these subroutines have not been merged to one in the interest of clarity. After all, according to
667             # Abelson and Sussman, programs are for humans to read above all, and only incidentally for machines
668             # to run. Not that this code is as readable as it could be, of course.
669             #
670             sub double_rotate_left
671             {
672 1     1 0 1 my ($self, $node) = @_;
673 1         2 my $old_balance = $$node->{_balance};
674 1         2 my $old_l_balance = 0;
675 1         1 my $old_r_balance = 0;
676            
677 1 50       2 if($$node->{_left_node}){
678 1         3 $old_l_balance = $$node->{_left_node}->{_balance};
679             }
680 1 50       2 if($$node->{_right_node}){
681 1         3 $old_r_balance = $$node->{_right_node}->{_balance};
682             }
683            
684 1 50       3 if($$node->{_right_node}){
685 1         4 $self->rotate_right(\$$node->{_right_node});
686             }
687 1         2 $self->rotate_left($node);
688            
689 1 50       3 if($$node->{_left_node}){
690 1         2 $$node->{_left_node}->{_balance} = -1 * max($old_l_balance, 0);
691             }
692 1 50       2 if($$node->{_right_node}){
693 1         2 $$node->{_right_node}->{_balance} = -1 * min($old_l_balance, 0);
694             }
695 1         2 $$node->{_balance} = 0;
696            
697 1         1 return 1;
698             }
699              
700              
701             sub is_empty{
702 1     1 0 2 my ($self, $node) = @_;
703            
704 1 50       3 if(!$node){
705 0         0 $node = $self->{_node};
706             }
707            
708 1 50       2 if(!defined($node->{_obj})){
709 0         0 return 1;
710             }
711 1         3 return 0;
712             }
713              
714              
715              
716              
717             #
718             # smallest
719             #
720             # usage:
721             #
722             # my $largest_obj = $avltree->smallest()
723             #
724             # Returns the smallest-valued object in the tree
725             #
726             sub smallest
727             {
728 0     0 1 0 my ($self, $node) = @_;
729 0         0 return $self->extremum($node, 0);
730             }
731              
732             #
733             # largest
734             #
735             # usage:
736             #
737             # my $largest_obj = $avltree->largest()
738             #
739             # Returns the largest-valued object in the tree
740             #
741             # Fixed 07/11/09 for version 1.05 by Robert Lehr:
742             # recursive invocation was called incorrectly
743             #
744             sub largest
745             {
746 0     0 1 0 my ($self, $node) = @_;
747 0         0 return $self->extremum($node, 1);
748             }
749              
750              
751              
752             sub extremum
753             {
754 0     0 0 0 my ($self, $node, $which_extreme) = @_;
755            
756 0         0 my $node_dir;
757            
758 0 0       0 if($which_extreme eq 0){
    0          
759 0         0 $node_dir = "_left_node";
760             }
761             elsif($which_extreme == 1){
762 0         0 $node_dir = "_right_node";
763             }
764             else{
765 0         0 croak("Bad extreme type supplied: must be 0 or 1\n");
766             }
767              
768 0 0       0 if(!$node){
769 0         0 $node = $self->{_node};
770             }
771 0         0 my $obj = $node->{_obj};
772 0         0 my $next_node = $node->{$node_dir};
773 0 0       0 if(!$next_node){
774 0         0 return $obj;
775             }
776             else{
777 0         0 my $obj = Tree::AVL::extremum($self, $next_node, $which_extreme);
778 0         0 return $obj;
779             }
780             }
781              
782              
783              
784             #
785             # pop_largest
786             #
787             # usage:
788             #
789             # my $largest_obj = $avltree->pop_largest()
790             #
791             # Removes and returns the largest-valued object in the tree
792             #
793             sub pop_largest
794             {
795 1     1 1 2 my ($self) = @_;
796 1         4 my ($obj) = $self->delete_largest();
797 1         4 return $obj;
798             }
799              
800             #
801             # pop_smallest
802             #
803             # usage:
804             #
805             # my $largest_obj = $avltree->pop_smallest()
806             #
807             # Removes and returns the smallest-valued object in the tree
808             #
809             sub pop_smallest
810             {
811 1     1 1 4 my ($self) = @_;
812 1         5 my ($obj) = $self->delete_smallest();
813 1         4 return $obj;
814             }
815              
816              
817             sub get_key
818             {
819 0     0 0 0 my ($self, $node) = @_;
820 0         0 my $get_key_func = $self->{fget_key};
821 0         0 my $obj = $node->{_obj};
822 0         0 my $key = $get_key_func->($obj);
823 0         0 return $key;
824             }
825              
826              
827             sub get_data
828             {
829 0     0 0 0 my ($self, $node) = @_;
830 0         0 my $get_data_func = $self->{fget_data};
831 0         0 my $obj = $node->{_obj};
832 0         0 my $data = $get_data_func->($obj);
833 0         0 return $data;
834             }
835              
836             sub get_height
837             {
838 7     7 0 482 my ($self, $node) = @_;
839            
840 7         7 my $depth_left = 0;
841 7         6 my $depth_right = 0;
842              
843 7 100       39 if(!$node){
844 2         3 $node = $self->{_node};
845             }
846              
847 7 100 100     24 if(!$node->{_left_node} && !$node->{_right_node}){
848 4         9 return 0;
849             }
850             else
851             {
852 3 100       7 if($node->{_left_node}){
853 2         8 $depth_left = 1 + $self->get_height($node->{_left_node});
854             }
855 3 50       6 if($node->{_right_node}){
856 3         4 $depth_right = 1 + $self->get_height($node->{_right_node});
857             }
858              
859 3 100       10 return $depth_left < $depth_right ? $depth_right : $depth_left;
860             }
861             }
862              
863              
864             #
865             # lookup
866             #
867             # usage: $data = $tree_ref->lookup($object)
868             #
869             sub lookup
870             {
871 0     0 1 0 my ($self,
872             $object,
873             $cmpfunc) = @_;
874              
875 0         0 my $node = $self->{_node};
876              
877 0 0       0 if(!defined($node->{_obj})){ # no root data yet
878 0         0 return;
879             }
880             else{
881            
882 0         0 while($node){
883 0         0 my $node_obj = $node->{_obj};
884 0         0 my $get_key_func = $self->{fget_key};
885 0         0 my $key = $get_key_func->($node_obj);
886              
887 0 0       0 if(!$cmpfunc){
888 0         0 $cmpfunc = $self->{fcompare};
889             }
890 0         0 my $result = $cmpfunc->($node_obj, $object);
891 0 0       0 if($result == 0){ # element is already in tree- return the key.
    0          
892 0         0 return $key;
893             }
894             elsif($result < 0){ # look into right subtree
895 0         0 $node = $node->{_right_node};
896             }
897             else{ # look into left subtree
898 0         0 $node = $node->{_left_node};
899             }
900             } # end while
901 0         0 return;
902             } # end else
903             }
904              
905              
906             #
907             # lookup_obj
908             #
909             # usage: $object = $tree_ref->lookup($object)
910             #
911             sub lookup_obj
912             {
913 0     0 1 0 my ($self,
914             $object,
915             $cmpfunc) = @_;
916              
917 0         0 my $node = $self->{_node};
918              
919 0 0       0 if(!defined($node->{_obj})) # no root data yet
920             {
921 0         0 return;
922             }
923             else
924             {
925 0         0 while($node){
926 0         0 my $node_obj = $node->{_obj};
927            
928 0 0       0 if(!$cmpfunc){
929 0         0 $cmpfunc = $self->{fcompare};
930             }
931 0         0 my $result = $cmpfunc->($node_obj, $object);
932 0 0       0 if($result == 0){ # element is already in tree- return the key.
    0          
933 0         0 return $node_obj;
934             }
935             elsif($result < 0){ # look into right subtree
936 0         0 $node = $node->{_right_node};
937             }
938             else{ # look into left subtree
939 0         0 $node = $node->{_left_node};
940             }
941             } # end while
942 0         0 return;
943             } # end else
944             }
945              
946              
947             #
948             # lookup_node
949             #
950             # usage: $node_hash = $tree_ref->lookup($object)
951             #
952             sub lookup_node
953             {
954 0     0 1 0 my ($self,
955             $object,
956             $cmpfunc) = @_;
957              
958 0         0 my $node = $self->{_node};
959              
960 0 0       0 if(!defined($node->{_obj})) # no root data yet
961             {
962 0         0 return;
963             }
964             else
965             {
966 0         0 while($node){
967 0         0 my $node_obj = $node->{_obj};
968            
969 0 0       0 if(!$cmpfunc){
970 0         0 $cmpfunc = $self->{fcompare};
971             }
972 0         0 my $result = $cmpfunc->($node_obj, $object);
973 0 0       0 if($result == 0){ # element is in tree- return the node.
    0          
974 0         0 return $node;
975             }
976             elsif($result < 0){ # look into right subtree
977 0         0 $node = $node->{_right_node};
978             }
979             else{ # look into left subtree
980 0         0 $node = $node->{_left_node};
981             }
982             } # end while
983 0         0 return;
984             } # end else
985             }
986              
987              
988              
989             #
990             # acc_lookup
991             #
992             # usage: $tree_ref->acc_lookup($object, $partial_cmp_func, $exact_cmp_func)
993             #
994             # accumulative lookup, returns a list of all
995             # items whose keys satisfy the match function for the key for $object.
996             #
997             # For example, if used with a relaxed compare function such as:
998             #
999             # $word->compare_up_to($arg_word);
1000             #
1001             # which returns true if the argument word is a proper 'superstring' of $word
1002             # (meaning that it contains $word followed by one or more characters)
1003             # this will return a list of all the words that are superstrings of
1004             # $word.
1005             #
1006             sub acc_lookup
1007             {
1008 0     0 1 0 my ($self,
1009             $object,
1010             $partial_cmpfunc, # partial comparison function to use
1011             $exact_cmpfunc, # exact comparison function to use
1012             $node,
1013             $acc_results) = @_;
1014            
1015 0 0       0 if(!$node){
1016 0         0 $node = $self->{_node};
1017             }
1018            
1019             # the list of accumulated results
1020 0 0       0 if(!$acc_results){
1021 0         0 $acc_results = ();
1022             }
1023            
1024 0 0 0     0 if(!$partial_cmpfunc || !$exact_cmpfunc){
1025 0         0 return ();
1026             }
1027            
1028 0 0       0 if(!defined($node->{_obj})){ # no root data yet
1029 0         0 return ();
1030             }
1031             else
1032             {
1033 0         0 while($node){
1034 0         0 my $node_obj = $node->{_obj};
1035 0         0 my $get_key_func = $self->{fget_key};
1036 0         0 my $node_key = $get_key_func->($node_obj);
1037 0         0 my $partial_cmp = $partial_cmpfunc->($node_obj, $object);
1038 0         0 my $exact_cmp = $exact_cmpfunc->($node_obj, $object);
1039              
1040 0 0       0 if($partial_cmp == 0){ # found a match on partial cmp
    0          
1041            
1042 0 0       0 if(!$acc_results){
1043 0         0 @$acc_results = ();
1044             }
1045 0         0 push(@$acc_results, $node_key);
1046            
1047 0 0       0 if($exact_cmp == 0){ # any other partial matches will be in right subtree
1048 0         0 $node = $node->{_right_node};
1049             }
1050             else{
1051              
1052 0 0 0     0 if ($node->{_right_node} && $node->{_left_node}){
    0          
    0          
1053 0         0 my $rightnode = $node->{_right_node};
1054 0         0 my $leftnode = $node->{_left_node};
1055            
1056 0         0 return @$acc_results = (Tree::AVL::acc_lookup($self, $object, $partial_cmpfunc,
1057             # do not pass in acc_results here
1058             $exact_cmpfunc, $rightnode),
1059             Tree::AVL::acc_lookup($self, $object, $partial_cmpfunc,
1060             $exact_cmpfunc, $leftnode, \@$acc_results));
1061             }
1062             elsif($node->{_right_node}){
1063 0         0 my $rightnode = $node->{_right_node};
1064 0         0 @$acc_results = (Tree::AVL::acc_lookup($self, $object, $partial_cmpfunc,
1065             $exact_cmpfunc, $rightnode, \@$acc_results));
1066             }
1067             elsif($node->{_left_node}){
1068 0         0 my $leftnode = $node->{_left_node};
1069 0         0 @$acc_results = (Tree::AVL::acc_lookup($self, $object, $partial_cmpfunc,
1070             $exact_cmpfunc, $leftnode, \@$acc_results));
1071             }
1072 0         0 return @$acc_results;
1073             }
1074             }
1075             elsif($partial_cmp < 0){ # look into right subtree
1076 0         0 $node = $node->{_right_node};
1077             }
1078             else{ # look into left subtree
1079 0         0 $node = $node->{_left_node};
1080             }
1081             } # end while
1082 0 0       0 if(scalar @{$acc_results} > 0){
  0         0  
1083 0         0 return @$acc_results;
1084             }
1085 0         0 return;
1086             } # end else determine whether need to look into left or right subtree
1087             }
1088              
1089              
1090             #
1091             # acc_lookup_memo
1092             #
1093             # memoized call to acc_lookup
1094             #
1095             sub acc_lookup_memo
1096             {
1097 0     0 0 0 my ($self,
1098             $object,
1099             $partial_cmpfunc, # partial comparison function to use
1100             $exact_cmpfunc # exact comparison function to use
1101             ) = @_;
1102            
1103 0         0 my $get_key_func = $self->{fget_key};
1104            
1105 0         0 my $obj_key = $get_key_func->($object);
1106 0         0 my $acc_lookup_hash_key = $obj_key . $partial_cmpfunc . $exact_cmpfunc;
1107            
1108            
1109 0 0       0 if($self->{acc_lookup_hash}->{$acc_lookup_hash_key}){
1110 0         0 my $list = $self->{acc_lookup_hash}->{$acc_lookup_hash_key};
1111 0         0 return @$list;
1112             }
1113             else{
1114 0         0 my @results = $self->acc_lookup($object, $partial_cmpfunc, $exact_cmpfunc);
1115 0         0 $self->{acc_lookup_hash}->{$acc_lookup_hash_key} = \@results;
1116 0         0 return @results;
1117             }
1118             }
1119              
1120              
1121             #
1122             # get_list_recursive
1123             #
1124             # usage: @list = $tree_ref->get_list_recursive()
1125             #
1126             # returns an array (list) containing all elements in the tree (in-order).
1127             #
1128             sub get_list_recursive
1129             {
1130 0     0 0 0 my ($self, $node, $lst) = @_;
1131              
1132 0 0       0 if(!$node){
1133 0         0 $node = $self->{_node};
1134             }
1135 0 0       0 if(!$lst){
1136 0         0 $lst = [];
1137             }
1138 0 0       0 if($node->{_left_node}){
1139 0         0 @$lst = Tree::AVL::get_list_recursive($self, $node->{_left_node}, $lst);
1140             }
1141 0         0 my $obj = $node->{_obj};
1142 0 0       0 if($obj){
1143 0         0 push(@$lst, $obj);
1144             }
1145 0 0       0 if($node->{_right_node}){
1146 0         0 Tree::AVL::get_list_recursive($self, $node->{_right_node}, $lst);
1147             }
1148              
1149 0         0 return @$lst;
1150             }
1151              
1152              
1153             #
1154             # get_list
1155             #
1156             # usage: @list = $tree_ref->get_list()
1157             #
1158             # returns an array (list) containing all elements in the tree (in-order).
1159             #
1160             sub get_list
1161             {
1162 0     0 0 0 my ($self) = @_;
1163              
1164 0         0 my $i = 0;
1165 0         0 my @stack;
1166 0         0 my $node = $self->{_node};
1167              
1168 0         0 my @objs = ();
1169              
1170 0         0 while(1){
1171 0         0 while($node){
1172 0         0 $stack[$i] = $node;
1173 0         0 $i++;
1174 0         0 $node = $node->{_left_node};
1175             }
1176 0 0       0 if($i == 0){
1177 0         0 last;
1178             }
1179 0         0 --$i;
1180 0 0       0 if(defined($stack[$i]->{_obj})){
1181 0         0 push(@objs, $stack[$i]->{_obj});
1182             }
1183 0         0 $node = $stack[$i];
1184              
1185 0         0 $node = $node->{_right_node};
1186             }
1187              
1188 0         0 return @objs;
1189             }
1190              
1191             #
1192             # get_root
1193             #
1194             # returns reference to object at root node.
1195             #
1196             #
1197             sub get_root
1198             {
1199 1     1 1 2 my ($self) = @_;
1200 1         3 return $self->{_node}->{_obj};
1201             }
1202              
1203             #
1204             # get_size
1205             #
1206             # returns number of objects in the tree
1207             #
1208             #
1209             sub get_size
1210             {
1211 0     0 0 0 my ($self) = @_;
1212 0         0 my @list = $self->get_list();
1213 0         0 my $size = @list;
1214            
1215 0         0 return $size;
1216             }
1217              
1218             #
1219             # iterator
1220             #
1221             # usage: my $it = $tree_ref->iterator(">") # high-to-low
1222             # my $it = $tree_ref->iterator("<") # low-to-high
1223             #
1224             # returns an iterator over elements in the tree (in order specified).
1225             #
1226             sub iterator
1227             {
1228 2     2 1 3 my ($self, $order) = @_;
1229            
1230 2         2 my $first_dir;
1231             my $second_dir;
1232            
1233 2 100       5 if(!$order){ $order = "<"; }
  1         2  
1234              
1235 2 100       5 if($order eq ">"){ # high to low
1236 1         3 $first_dir = "_right_node";
1237 1         1 $second_dir = "_left_node";
1238             }
1239             else{ # low to high (default)
1240 1         1 $first_dir = "_left_node";
1241 1         2 $second_dir = "_right_node";
1242             }
1243              
1244 2         2 my @stack;
1245 2         2 my $i = 0;
1246 2         4 my $node = $self->{_node};
1247            
1248             return sub{
1249 2     2   1033 while(1){
1250 2         5 while($node){
1251 5         7 $stack[$i] = $node;
1252 5         4 $i++;
1253 5         9 $node = $node->{$first_dir};
1254             }
1255 2 50       5 if($i == 0){
1256 0         0 last;
1257             }
1258 2         3 --$i;
1259 2         3 my $obj = $stack[$i]->{_obj};
1260 2         3 $node = $stack[$i];
1261 2         2 $node = $node->{$second_dir};
1262 2         11 return $obj;
1263             }
1264 0         0 return;
1265             }
1266 2         15 }
1267              
1268              
1269             sub get_keys_recursive
1270             {
1271 0     0 0 0 my ($self, $node) = @_;
1272 0         0 my @keys;
1273              
1274 0 0       0 if(!$node){
1275 0         0 $node = $self->{_node};
1276             }
1277            
1278 0 0       0 if($node->{_left_node}){
1279 0         0 push(@keys, Tree::AVL::get_keys_recursive($self, $node->{_left_node}));
1280             }
1281            
1282 0         0 push(@keys, $self->get_key($node));
1283            
1284 0 0       0 if($node->{_right_node}){
1285 0         0 push(@keys, Tree::AVL::get_keys_recursive($self, $node->{_right_node}));
1286             }
1287 0         0 return @keys;
1288             }
1289              
1290              
1291              
1292             sub get_keys
1293             {
1294 0     0 0 0 my ($self) = @_;
1295 0         0 my $node = $self->{_node};
1296 0         0 my @stack;
1297 0         0 my $i = 0;
1298 0         0 my @keys;
1299              
1300 0         0 while(1){
1301 0         0 while($node){
1302 0         0 $stack[$i] = $node;
1303 0         0 $i++;
1304 0         0 $node = $node->{_left_node};
1305             }
1306 0 0       0 if($i == 0){
1307 0         0 last;
1308             }
1309 0         0 --$i;
1310 0         0 push(@keys, $self->get_key($stack[$i]));
1311 0         0 $node = $stack[$i];
1312              
1313 0         0 $node = $node->{_right_node};
1314             }
1315 0         0 return @keys;
1316             }
1317              
1318              
1319             sub get_keys_iterator
1320             {
1321 0     0 0 0 my ($self) = @_;
1322 0         0 my @stack;
1323 0         0 my $i = 0;
1324 0         0 my $node = $self->{_node};
1325              
1326             return sub{
1327            
1328 0     0   0 while(1){
1329 0         0 while($node){
1330 0         0 $stack[$i] = $node;
1331 0         0 $i++;
1332 0         0 $node = $node->{_left_node};
1333             }
1334 0 0       0 if($i == 0){
1335 0         0 last;
1336             }
1337 0         0 --$i;
1338 0         0 my $key = $self->get_key($stack[$i]);
1339 0         0 $node = $stack[$i];
1340 0         0 $node = $node->{_right_node};
1341 0         0 return $key;
1342             }
1343            
1344 0         0 return;
1345             }
1346 0         0 }
1347              
1348              
1349             ################################################################################
1350             #
1351             # Printing functions
1352             #
1353             #
1354             ################################################################################
1355             sub print
1356             {
1357 0     0 1 0 my ($self, $char, $o_char, $node, $depth) = @_;
1358              
1359 0 0 0     0 if(!$node && !defined($depth)){
1360 0         0 $node = $self->{_node};
1361             }
1362 0 0       0 if(!$depth){ $depth = 0; }
  0         0  
1363 0 0       0 if(!$o_char){
1364 0         0 $o_char = $char;
1365             }
1366            
1367 0         0 my $key = $self->get_key($node);
1368 0         0 my $data = $self->get_data($node);
1369              
1370 0 0       0 if(!defined($self->{_node}->{_obj})){
1371 0         0 print "tree is empty.\n";
1372 0         0 return;
1373             }
1374              
1375 0 0       0 if(!defined($key)){
1376 0         0 croak "get_key() function provided to Tree::AVL object returned a null value\n";
1377             }
1378 0 0       0 if(!defined($data)){
1379 0         0 $data = "";
1380             }
1381              
1382 0         0 print $char . $key . ": " . $data;
1383 0         0 print ": height: " . $self->get_height($node) . ": balance: " . $node->{_balance} . "\n";
1384              
1385 0 0       0 if($node->{_left_node}){
1386 0         0 my $leftnode = $node->{_left_node};
1387 0         0 Tree::AVL::print($self, $char . $o_char, $o_char, $leftnode, $depth+1);
1388             }
1389 0 0       0 if($node->{_right_node}){
1390 0         0 my $rightnode = $node->{_right_node};
1391 0         0 Tree::AVL::print($self, $char . $o_char, $o_char, $rightnode, $depth+1);
1392             }
1393             }
1394              
1395              
1396             sub print_node
1397             {
1398 0     0 0 0 my ($self, $node, $char, $o_char) = @_;
1399              
1400 0 0       0 if(!$o_char){
1401 0         0 $o_char = $char;
1402             }
1403              
1404 0         0 my $key = $self->get_key($node);
1405 0         0 my $data = $self->get_data($node);
1406            
1407 0 0       0 if(!defined($key)){
1408 0         0 croak "get_key() function provided to Tree::AVL object returned a null value\n";
1409             }
1410 0 0       0 if(!defined($data)){
1411 0         0 $data = "";
1412             }
1413              
1414              
1415 0         0 print $char . $key . ": " . $data . ": balance: " . $node->{_balance} . "\n";
1416 0 0       0 if($node->{_left_node}){
1417 0         0 my $leftnode = $node->{_left_node};
1418 0         0 Tree::AVL::print_node($self, $leftnode, $char . $o_char, $o_char);
1419             }
1420 0 0       0 if($node->{_right_node}){
1421 0         0 my $rightnode = $node->{_right_node};
1422 0         0 Tree::AVL::print_node($self, $rightnode, $char . $o_char, $o_char);
1423             }
1424             }
1425              
1426             sub print_iterative
1427             {
1428 0     0 0 0 my ($self) = @_;
1429 0         0 my @stack;
1430              
1431 0         0 my $node = $self->{_node};
1432              
1433 0         0 my $i = 0;
1434              
1435 0         0 while(1){
1436 0         0 while($node){
1437 0         0 $stack[$i] = $node;
1438 0         0 $i++;
1439 0         0 $node = $node->{_left_node};
1440             }
1441              
1442 0 0       0 if($i == 0){
1443 0         0 last;
1444             }
1445 0         0 --$i;
1446 0         0 print $self->get_key($stack[$i]) . "\n";
1447 0         0 $node = $stack[$i];
1448              
1449 0         0 $node = $node->{_right_node};
1450             }
1451             }
1452              
1453             #
1454             # default_cmp_func
1455             #
1456             # default comparison function to use in case none is supplied.
1457             # uses lexical comparator.
1458             #
1459             sub default_cmp_func
1460             {
1461 15     15 0 15 my ($obj1, $obj2) = @_;
1462              
1463 15 100       28 if($obj1 lt $obj2){
    100          
1464 9         12 return -1;
1465             }
1466             elsif($obj1 gt $obj2){
1467 4         8 return 1;
1468             }
1469 2         2 return 0;
1470             }
1471              
1472             sub min
1473             {
1474 7     7 0 7 my ($a, $b) = @_;
1475 7 100       15 return $a < $b ? $a : $b;
1476             }
1477              
1478              
1479             sub max
1480             {
1481 7     7 0 5 my ($a, $b) = @_;
1482 7 50       16 return $a < $b ? $b : $a;
1483             }
1484              
1485              
1486             1;
1487             __END__