File Coverage

blib/lib/Tree/Nary.pm
Criterion Covered Total %
statement 326 515 63.3
branch 126 262 48.0
condition 32 87 36.7
subroutine 41 53 77.3
pod 36 36 100.0
total 561 953 58.8


line stmt bran cond sub pod time code
1             #####################################################################################
2             # $Id: Nary.pm,v 1.3 2004/01/05 10:32:00 soriano Exp $
3             #####################################################################################
4             #
5             # Tree::Nary
6             #
7             # Author: Frederic Soriano
8             # RCS Revision: $Revision: 1.3 $
9             # Date: $Date: 2004/01/05 10:32:00 $
10             #
11             #####################################################################################
12             #
13             # This package is free software and is provided "as is" without express or
14             # implied warranty. It may be used, redistributed and/or modified under the
15             # same terms as Perl itself.
16             #
17             #####################################################################################
18              
19             package Tree::Nary;
20              
21             require 5.003;
22             require Exporter;
23              
24             @ISA = qw(Exporter);
25              
26             $VERSION = '1.3';
27              
28 2     2   1375 use strict;
  2         4  
  2         79  
29 2     2   10 use vars qw($TRUE $FALSE);
  2         3  
  2         145  
30 2     2   10 use vars qw($TRAVERSE_LEAFS $TRAVERSE_NON_LEAFS $TRAVERSE_ALL $TRAVERSE_MASK);
  2         14  
  2         134  
31 2     2   10 use vars qw($IN_ORDER $PRE_ORDER $POST_ORDER $LEVEL_ORDER);
  2         4  
  2         12292  
32              
33             #
34             # Constants
35             #
36              
37             # Booleans
38             *TRUE = \1;
39             *FALSE = \0;
40              
41             # Tree traverse flags
42             *TRAVERSE_LEAFS = \(1 << 0); # Only leaf nodes should be visited.
43             *TRAVERSE_NON_LEAFS = \(1 << 1); # Only non-leaf nodes should be visited.
44             *TRAVERSE_ALL = \($TRAVERSE_LEAFS | $TRAVERSE_NON_LEAFS); # All nodes should be visited.
45             *TRAVERSE_MASK = \0x03;
46              
47             # Tree traverse orders
48             *IN_ORDER = \1;
49             *PRE_ORDER = \2;
50             *POST_ORDER = \3;
51             *LEVEL_ORDER = \4;
52              
53             #
54             # Public methods
55             #
56              
57             # Constructors, destructors
58              
59             # Creates a new Tree::Nary node object, containing the given data, if any.
60             # Used to create the first node in a tree.
61             sub new() {
62              
63 4768     4768 1 7627 my ($that, $newdata) = (shift, shift);
64 4768   33     59000 my $class = ref($that) || $that;
65 4768         22777 my $self = {
66             data => undef,
67             next => undef,
68             prev => undef,
69             parent => undef,
70             children => undef,
71             };
72              
73 4768 100       11954 if(defined($newdata)) {
74 17         30 $self->{data} = $newdata;
75             }
76              
77             # Transform $self into an object of class $class
78 4768         8714 bless $self, $class;
79              
80 4768         11825 return($self);
81             }
82              
83             # Frees allocated memory by removing circular references.
84             sub _free() {
85              
86 0     0   0 my ($self, $node) = (shift, shift);
87 0         0 my $parent = $self->new();
88              
89 0         0 $parent = $node;
90              
91 0         0 while($TRUE) {
92 0 0       0 if(defined($parent->{children})) {
93 0         0 $self->_free($parent->{children});
94             }
95 0 0       0 if(defined($parent->{next})) {
96 0         0 $parent = $parent->{next};
97             } else {
98 0         0 last;
99             }
100             }
101              
102 0         0 return;
103             }
104              
105             # Removes the node and its children from the tree.
106             sub DESTROY() {
107              
108 2702     2702   4651 my ($self, $root) = (shift, shift);
109              
110 2702 50       5521 if(!defined($root)) {
111 2702         22670 return;
112             }
113 0 0       0 if(!$self->is_root($root)) {
114 0         0 $self->unlink($root);
115             }
116              
117 0         0 $self->_free($root);
118              
119 0         0 return;
120             }
121              
122             # Unlinks a node from a tree, resulting in two separate trees.
123             sub unlink() {
124              
125 10     10 1 15 my ($self, $node) = (shift, shift);
126              
127 10 50       20 if(!defined($node)) {
128 0         0 return;
129             }
130              
131 10 100       113 if(defined($node->{prev})) {
    50          
132 7         15 $node->{prev}->{next} = $node->{next};
133             } elsif(defined($node->{parent})) {
134 3         8 $node->{parent}->{children} = $node->{next};
135             }
136              
137 10         392 $node->{parent} = undef;
138              
139 10 100       21 if(defined($node->{next})) {
140 5         11 $node->{next}->{prev} = $node->{prev};
141 5         7 $node->{next} = undef;
142             }
143              
144 10         13 $node->{prev} = undef;
145              
146 10         15 return;
147             }
148              
149             #
150             # Miscellaneous info methods
151             #
152              
153             # Returns TRUE if the given node is a root node.
154             sub is_root() {
155              
156 2077     2077 1 2563 my ($self, $node) = (shift, shift);
157              
158 2077   33     22085 return(!defined($node->{parent}) && !defined($node->{prev}) && !defined($node->{next}));
159             }
160              
161             # Returns TRUE if the given node is a leaf node.
162             sub is_leaf() {
163              
164 78     78 1 105 my ($self, $node) = (shift, shift);
165              
166 78         374 return(!defined($node->{children}));
167             }
168              
169             # Returns TRUE if $node is an ancestor of $descendant.
170             # This is true if node is the parent of descendant, or if node is the grandparent of descendant, etc.
171             sub is_ancestor() {
172              
173 2     2 1 18 my ($self, $node, $descendant) = (shift, shift, shift);
174              
175 2 50       6 if(!defined($node)) {
176 0         0 return($FALSE);
177             }
178 2 50       5 if(!defined($descendant)) {
179 0         0 return($FALSE);
180             }
181              
182 2         5 while(defined($descendant)) {
183 3 100 100     27 if(defined($descendant->{parent}) && ($descendant->{parent} == $node)) {
184 1         4 return($TRUE);
185             }
186              
187 2         7 $descendant = $descendant->{parent};
188             }
189              
190 1         9 return($FALSE);
191             }
192              
193             # Gets the root of a tree.
194             sub get_root() {
195              
196 0     0 1 0 my ($self, $node) = (shift, shift);
197              
198 0 0       0 if(!defined($node)) {
199 0         0 return(undef);
200             }
201              
202 0         0 while(defined($node->{parent})) {
203 0         0 $node = $node->{parent};
204             }
205              
206 0         0 return($node);
207             }
208              
209             # Gets the depth of a node.
210             sub depth() {
211              
212 3     3 1 27 my ($self, $node) = (shift, shift);
213 3         5 my $depth = 0;
214              
215 3         11 while(defined($node)) {
216 6         9 $depth++;
217 6         24 $node = $node->{parent};
218             }
219              
220 3         9 return($depth);
221             }
222              
223             # Reverses the order of the children of a node.
224             sub reverse_children() {
225              
226 2     2 1 15 my ($self, $node) = (shift, shift);
227 2         6 my $child = $self->new();
228 2         6 my $last = $self->new();
229              
230 2 50       7 if(!defined($node)) {
231 0         0 return;
232             }
233              
234 2         3 $child = $node->{children};
235              
236 2         16 while(defined($child)) {
237 7         8 $last = $child;
238 7         10 $child = $last->{next};
239 7         10 $last->{next} = $last->{prev};
240 7         14 $last->{prev} = $child;
241             }
242              
243 2         3 $node->{children} = $last;
244              
245 2         5 return;
246             }
247              
248             # Gets the maximum height of all branches beneath a node.
249             # This is the maximum distance from the node to all leaf nodes.
250             sub max_height() {
251              
252 2067     2067 1 4576 my ($self, $root) = (shift, shift);
253 2067         4862 my $child = $self->new();
254 2067         2630 my $max_height = 0;
255              
256             #
257             # can be safely ignored.
258 2067         8480 local $^W = 0;
259              
260 2067 50       4198 if(!defined($root)) {
261 0         0 return(0);
262             }
263              
264 2067         4059 $child = $root->{children};
265              
266 2067         4644 while(defined($child)) {
267              
268 2063         9877 my $tmp_height = $self->max_height($child);
269              
270 2063 100       5570 if($tmp_height > $max_height) {
271 826         3714 $max_height = $tmp_height;
272             }
273              
274 2063         40940 $child = $child->{next};
275             }
276              
277 2067         6107 return($max_height + 1);
278             }
279              
280             # Gets the number of children of a node.
281             sub n_children() {
282              
283 22     22 1 66 my ($self, $node) = (shift, shift);
284 22         26 my $n = 0;
285              
286 22 50       43 if(!defined($node)) {
287 0         0 return(0);
288             }
289              
290 22         68 $node = $node->{children};
291              
292 22         42 while(defined($node)) {
293 46         41 $n++;
294 46         95 $node = $node->{next};
295             }
296              
297 22         53 return($n);
298             }
299              
300             # Gets the position of a node with respect to its siblings.
301             # $child must be a child of $node.
302             # The first child is numbered 0, the second 1, and so on.
303             sub child_position() {
304              
305 4     4 1 8 my ($self, $node, $child) = (shift, shift, shift);
306 4         7 my $n = 0;
307              
308 4 50       7 if(!defined($node)) {
309 0         0 return(-1);
310             }
311 4 50       9 if(!defined($child)) {
312 0         0 return(-1);
313             }
314 4 50 33     25 if(defined($child->{parent}) && !($child->{parent} == $node)) {
315 0         0 return(-1);
316             }
317              
318 4         6 $node = $node->{children};
319              
320 4         9 while(defined($node)) {
321 10 100       22 if($node == $child) {
322 4         21 return($n);
323             }
324 6         7 $n++;
325 6         14 $node = $node->{next};
326             }
327              
328 0         0 return(-1);
329             }
330              
331             # Gets the position of the first child of a node which contains the given data.
332             sub child_index() {
333              
334 0     0 1 0 my ($self, $node, $data) = (shift, shift, shift);
335 0         0 my $n = 0;
336              
337 0 0       0 if(!defined($node)) {
338 0         0 return(-1);
339             }
340              
341 0         0 $node = $node->{children};
342              
343 0         0 while(defined($node)) {
344 0 0       0 if($node->{data} eq $data) {
345 0         0 return($n);
346             }
347 0         0 $n++;
348 0         0 $node = $node->{next};
349             }
350              
351 0         0 return(-1);
352             }
353              
354             # Gets the first sibling of a node. This could possibly be the node itself.
355             sub first_sibling() {
356              
357 0     0 1 0 my ($self, $node) = (shift, shift);
358              
359 0 0       0 if(!defined($node)) {
360 0         0 return(undef);
361             }
362              
363 0         0 while(defined($node->{prev})) {
364 0         0 $node = $node->{prev};
365             }
366              
367 0         0 return($node);
368             }
369              
370             # Gets the next sibling of a node.
371             sub next_sibling() {
372              
373 0     0 1 0 my ($self, $node) = (shift, shift);
374              
375 0 0       0 if(!defined($node)) {
376 0         0 return(undef);
377             }
378              
379 0         0 return($node->{next});
380             }
381              
382             # Gets the previous sibling of a node.
383             sub prev_sibling() {
384              
385 0     0 1 0 my ($self, $node) = (shift, shift);
386              
387 0 0       0 if(!defined($node)) {
388 0         0 return(undef);
389             }
390              
391 0         0 return($node->{prev});
392             }
393              
394             # Gets the last sibling of a node. This could possibly be the node itself.
395             sub last_sibling() {
396              
397 0     0 1 0 my ($self, $node) = (shift, shift);
398              
399 0 0       0 if(!defined($node)) {
400 0         0 return(undef);
401             }
402              
403 0         0 while(defined($node->{next})) {
404 0         0 $node = $node->{next};
405             }
406              
407 0         0 return($node);
408             }
409              
410             sub _count_func() {
411              
412 2082     2082   4639 my ($self, $node, $flags, $nref) = (shift, shift, shift, shift);
413              
414             # warnings
415             # can be safely ignored.
416 2082         5663 local $^W = 0;
417              
418 2082 100       5828 if(defined($node->{children})) {
    100          
419              
420 422         1127 my $child = $self->new();
421              
422 422 100       806 if($flags & $TRAVERSE_NON_LEAFS) {
423 418         453 $$nref++;
424             }
425              
426 422         645 $child = $node->{children};
427              
428 422         784 while(defined($child)) {
429 2078         5382 $self->_count_func($child, $flags, $nref);
430 2078         5897 $child = $child->{next};
431             }
432              
433             } elsif($flags & $TRAVERSE_LEAFS) {
434 1653         1653 $$nref++;
435             }
436              
437 2082         21961 return;
438             }
439              
440             # Gets the number of nodes in a tree.
441             sub n_nodes() {
442              
443 4     4 1 38 my ($self, $root, $flags) = (shift, shift, shift);
444 4         7 my $n = 0;
445              
446 4 50       14 if(!(defined($root))) {
447 0         0 return(0);
448             }
449 4 50       20 if(!($flags <= $TRAVERSE_MASK)) {
450 0         0 return(0);
451             }
452              
453 4         16 $self->_count_func($root, $flags, \$n);
454              
455 4         13 return($n);
456             }
457              
458             # Gets the first child of a node.
459             sub first_child() {
460              
461 2     2 1 16 my ($self, $node) = (shift, shift);
462              
463 2 50       5 if(!(defined($node))) {
464 0         0 return(undef);
465             }
466              
467 2         14 return($node->{children});
468             }
469              
470             # Gets the last child of a node.
471             sub last_child() {
472              
473 2     2 1 10 my ($self, $node) = (shift, shift);
474              
475 2 50       5 if(!(defined($node))) {
476 0         0 return(undef);
477             }
478              
479 2         4 $node = $node->{children};
480              
481 2 50       5 if(defined($node)) {
482 2         6 while(defined($node->{next})) {
483 6         14 $node = $node->{next};
484             }
485             }
486              
487 2         6 return($node);
488             }
489              
490             # Gets a child of a node, using the given index.
491             # the first child is at index 0.
492             # If the index is too big, 'undef' is returned.
493             sub nth_child() {
494              
495 10     10 1 41 my ($self, $node, $n) = (shift, shift, shift);
496              
497 10 50       19 if(!defined($node)) {
498 0         0 return(undef);
499             }
500              
501 10         13 $node = $node->{children};
502              
503 10 50       93 if(defined($node)) {
504 10   100     53 while(($n-- > 0) && defined($node)) {
505 12         41 $node = $node->{next};
506             }
507             }
508              
509 10         64 return($node);
510             }
511              
512             #
513             # Insert methods
514             #
515              
516             # Inserts a node beneath the parent at the given position.
517             sub insert() {
518              
519 4     4 1 8 my ($self, $parent, $position, $node) = (shift, shift, shift, shift);
520              
521 4 50       10 if(!defined($parent)) {
522 0         0 return($node);
523             }
524 4 50       9 if(!defined($node)) {
525 0         0 return($node);
526             }
527 4 50       9 if(!$self->is_root($node)) {
528 0         0 return($node);
529             }
530              
531 4 100       13 if($position > 0) {
    50          
532 3         10 return($self->insert_before($parent, $self->nth_child($parent, $position), $node));
533             } elsif($position == 0) {
534 1         4 return($self->prepend($parent, $node));
535             } else {
536 0         0 return($self->append($parent, $node));
537             }
538             }
539              
540             # Inserts a node beneath the parent before the given sibling.
541             sub insert_before() {
542              
543 2073     2073 1 3127 my ($self, $parent, $sibling, $node) = (shift, shift, shift, shift);
544              
545 2073 50       4900 if(!defined($parent)) {
546 0         0 return($node);
547             }
548 2073 50       4114 if(!defined($node)) {
549 0         0 return($node);
550             }
551 2073 50       13487 if(!$self->is_root($node)) {
552 0         0 return($node);
553             }
554              
555 2073 100       12673 if(defined($sibling)) {
556 13 50       36 if($sibling->{parent} != $parent) {
557 0         0 return($node);
558             }
559             }
560              
561 2073         3400 $node->{parent} = $parent;
562              
563 2073 100       4160 if(defined($sibling)) {
564 13 100       26 if(defined($sibling->{prev})) {
565 2         86 $node->{prev} = $sibling->{prev};
566 2         6 $node->{prev}->{next} = $node;
567 2         4 $node->{next} = $sibling;
568 2         13 $sibling->{prev} = $node;
569             } else {
570 11         18 $node->{parent}->{children} = $node;
571 11         13 $node->{next} = $sibling;
572 11         15 $sibling->{prev} = $node;
573             }
574             } else {
575 2060 100       4169 if(defined($parent->{children})) {
576 1643         2458 $sibling = $parent->{children};
577              
578 1643         3550 while(defined($sibling->{next})) {
579 2458         5833 $sibling = $sibling->{next};
580             }
581              
582 1643         2302 $node->{prev} = $sibling;
583 1643         2405 $sibling->{next} = $node;
584             } else {
585 417         788 $node->{parent}->{children} = $node;
586             }
587             }
588              
589 2073         5886 return($node);
590             }
591              
592             # Inserts a new node at the given position.
593             sub insert_data() {
594              
595 1     1 1 11 my ($self, $parent, $position, $data) = (shift, shift, shift, shift);
596              
597 1         4 return($self->insert($parent, $position, $self->new($data)));
598             }
599              
600             # Inserts a new node before the given sibling.
601             sub insert_data_before() {
602              
603 0     0 1 0 my ($self, $parent, $sibling, $data) = (shift, shift, shift, shift);
604              
605 0         0 return($self->insert_before($parent, $sibling, $self->new($data)));
606             }
607              
608             # Inserts a node as the last child of the given parent.
609             sub append() {
610              
611 2051     2051 1 3135 my ($self, $parent, $node) = (shift, shift, shift);
612              
613 2051         10261 return($self->insert_before($parent, undef, $node));
614             }
615              
616             # Inserts a new node as the first child of the given parent.
617             sub append_data() {
618              
619 6     6 1 35 my ($self, $parent, $data) = (shift, shift, shift);
620              
621 6         14 return($self->insert_before($parent, undef, $self->new($data)));
622             }
623              
624             # Inserts a node as the first child of the given parent.
625             sub prepend() {
626              
627 13     13 1 29 my ($self, $parent, $node) = (shift, shift, shift);
628              
629 13 50       47 if(!defined($parent)) {
630 0         0 return($node);
631             }
632              
633 13         37 return($self->insert_before($parent, $parent->{children}, $node));
634             }
635              
636             # Inserts a new node as the first child of the given parent.
637             sub prepend_data() {
638              
639 1     1 1 13 my ($self, $parent, $data) = (shift, shift, shift);
640              
641 1         3 return($self->prepend($parent, $self->new($data)));
642             }
643              
644             #
645             # Search methods
646             #
647              
648             sub _traverse_pre_order() {
649              
650 22     22   119 my ($self, $node, $flags, $funcref, $argref) = (shift, shift, shift, shift, shift);
651              
652 22 100 66     167 if(defined($node->{children})) {
    50          
653              
654 8         17 my $child = $self->new();
655              
656 8 50 33     31 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($node, $argref)) {
657 0         0 return($TRUE);
658             }
659              
660 8         97 $child = $node->{children};
661              
662 8         17 while(defined($child)) {
663              
664 20         43 my $current = $self->new();
665              
666 20         24 $current = $child;
667 20         35 $child = $current->{next};
668 20 50       60 if($self->_traverse_pre_order($current, $flags, $funcref, $argref)) {
669 0         0 return($TRUE);
670             }
671             }
672              
673             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($node, $argref)) {
674 0         0 return($TRUE);
675             }
676              
677 22         143 return($FALSE);
678             }
679              
680             sub _depth_traverse_pre_order() {
681              
682 0     0   0 my ($self, $node, $flags, $depth, $funcref, $argref) = (shift, shift, shift, shift, shift, shift);
683              
684 0 0 0     0 if(defined($node->{children})) {
    0          
685              
686 0         0 my $child = $self->new();
687              
688 0 0 0     0 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($node, $argref)) {
689 0         0 return($TRUE);
690             }
691              
692 0         0 $depth--;
693 0 0       0 if(!$depth) {
694 0         0 return($FALSE);
695             }
696              
697 0         0 $child = $node->{children};
698              
699 0         0 while(defined($child)) {
700              
701 0         0 my $current = $self->new();
702              
703 0         0 $current = $child;
704 0         0 $child = $current->{next};
705              
706 0 0       0 if($self->_traverse_pre_order($current, $flags, $depth, $funcref, $argref)) {
707 0         0 return($TRUE);
708             }
709             }
710              
711             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($node, $argref)) {
712 0         0 return($TRUE);
713             }
714              
715 0         0 return($FALSE);
716             }
717              
718             sub _traverse_post_order() {
719              
720 11     11   71 my ($self, $node, $flags, $funcref, $argref) = (shift, shift, shift, shift, shift);
721              
722 11 100 33     46 if(defined($node->{children})) {
    50          
723              
724 4         9 my $child = $self->new();
725              
726 4         6 $child = $node->{children};
727              
728 4         9 while(defined($child)) {
729              
730 10         28 my $current = $self->new();
731              
732 10         15 $current = $child;
733 10         20 $child = $current->{next};
734              
735 10 50       34 if($self->_traverse_post_order($current, $flags, $funcref, $argref)) {
736 0         0 return($TRUE);
737             }
738             }
739              
740 4 50 33     19 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($node, $argref)) {
741 0         0 return($TRUE);
742             }
743              
744             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($node, $argref)) {
745 0         0 return($TRUE);
746             }
747              
748 11         186 return($FALSE);
749             }
750              
751             sub _depth_traverse_post_order() {
752              
753 0     0   0 my ($self, $node, $flags, $depth, $funcref, $argref) = (shift, shift, shift, shift, shift, shift);
754              
755 0 0 0     0 if(defined($node->{children})) {
    0          
756              
757 0         0 $depth--;
758 0 0       0 if($depth) {
759              
760 0         0 my $child = $self->new();
761              
762 0         0 $child = $node->{children};
763              
764 0         0 while(defined($child)) {
765              
766 0         0 my $current = $self->new();
767              
768 0         0 $current = $child;
769 0         0 $child = $current->{next};
770              
771 0 0       0 if($self->_depth_traverse_post_order($current, $flags, $depth, $funcref, $argref)) {
772 0         0 return($TRUE);
773             }
774             }
775             }
776 0 0 0     0 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($node, $argref)) {
777 0         0 return($TRUE);
778             }
779              
780             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($node, $argref)) {
781 0         0 return($TRUE);
782             }
783              
784 0         0 return($FALSE);
785             }
786              
787             sub _traverse_in_order() {
788              
789 21     21   37 my ($self, $node, $flags, $funcref, $argref) = (shift, shift, shift, shift, shift);
790              
791 21 100 66     74 if(defined($node->{children})) {
    100          
792              
793 8         16 my $child = $self->new();
794 8         20 my $current = $self->new();
795              
796 8         15 $child = $node->{children};
797 8         16 $current = $child;
798 8         11 $child = $current->{next};
799              
800 8 100       22 if($self->_traverse_in_order($current, $flags, $funcref, $argref)) {
801 1         3 return($TRUE);
802             }
803 7 50 66     35 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($node, $argref)) {
804 0         0 return($TRUE);
805             }
806              
807 7         56 while(defined($child)) {
808 11         11 $current = $child;
809 11         17 $child = $current->{next};
810 11 100       33 if($self->_traverse_in_order($current, $flags, $funcref, $argref)) {
811 2         5 return($TRUE);
812             }
813             }
814              
815             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($node, $argref)) {
816 1         3 return($TRUE);
817             }
818              
819 17         292 return($FALSE);
820             }
821              
822             sub _depth_traverse_in_order() {
823              
824 0     0   0 my ($self, $node, $flags, $depth, $funcref, $argref) = (shift, shift, shift, shift, shift, shift);
825              
826 0 0 0     0 if(defined($node->{children})) {
    0          
827              
828 0         0 $depth--;
829 0 0 0     0 if($depth) {
    0          
830              
831 0         0 my $child = $self->new();
832 0         0 my $current = $self->new();
833              
834 0         0 $child = $node->{children};
835 0         0 $current = $child;
836 0         0 $child = $current->{next};
837              
838 0 0       0 if($self->_depth_traverse_in_order($current, $flags, $depth, $funcref, $argref)) {
839 0         0 return($TRUE);
840             }
841 0 0 0     0 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($node, $argref)) {
842 0         0 return($TRUE);
843             }
844              
845 0         0 while(defined($child)) {
846 0         0 $current = $child;
847 0         0 $child = $current->{next};
848 0 0       0 if($self->_depth_traverse_in_order($current, $flags, $depth, $funcref, $argref)) {
849 0         0 return($TRUE);
850             }
851             }
852              
853             } elsif(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($node, $argref)) {
854 0         0 return($TRUE);
855             }
856              
857             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($node, $argref)) {
858 0         0 return($TRUE);
859             }
860              
861 0         0 return($FALSE);
862             }
863              
864             sub _traverse_children() {
865              
866 20     20   42 my ($self, $node, $flags, $funcref, $argref) = (shift, shift, shift, shift, shift);
867 20         39 my $child = $self->new();
868              
869 20         28 $child = $node->{children};
870              
871 20         37 while(defined($child)) {
872              
873 50         489 my $current = $self->new();
874              
875 50         58 $current = $child;
876 50         160 $child = $current->{next};
877              
878 50 100 66     224 if(defined($current->{children})) {
    50          
879 15 50 66     51 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($current, $argref)) {
880 0         0 return($TRUE);
881             }
882             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($current, $argref)) {
883 0         0 return($TRUE);
884             }
885             }
886              
887 20         170 $child = $node->{children};
888              
889 20         35 while(defined($child)) {
890              
891 50         94 my $current = $self->new();
892              
893 50         58 $current = $child;
894 50         79 $child = $current->{next};
895              
896 50 50 66     249 if(defined($current->{children}) && $self->_traverse_children($current, $flags, $funcref, $argref)) {
897 0         0 return($TRUE);
898             }
899             }
900              
901 20         122 return($FALSE);
902             }
903              
904             sub _depth_traverse_children() {
905              
906 0     0   0 my ($self, $node, $flags, $depth, $funcref, $argref) = (shift, shift, shift, shift, shift, shift);
907 0         0 my $child = $self->new();
908              
909 0         0 $child = $node->{children};
910              
911 0         0 while(defined($child)) {
912              
913 0         0 my $current = $self->new();
914              
915 0         0 $current = $child;
916 0         0 $child = $current->{next};
917              
918 0 0 0     0 if(defined($current->{children})) {
    0          
919              
920 0 0 0     0 if(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($current, $argref)) {
921 0         0 return($TRUE);
922             }
923              
924             } elsif(($flags & $TRAVERSE_LEAFS) && &$funcref($current, $argref)) {
925 0         0 return($TRUE);
926             }
927             }
928              
929 0         0 $depth--;
930 0 0       0 if(!$depth) {
931 0         0 return($FALSE);
932             }
933              
934 0         0 $child = $node->{children};
935              
936 0         0 while(defined($child)) {
937              
938 0         0 my $current = $self->new();
939              
940 0         0 $current = $child;
941 0         0 $child = $current->{next};
942              
943 0 0 0     0 if(defined($current->{children}) && $self->_depth_traverse_children($current, $flags, $depth, $funcref, $argref)) {
944 0         0 return($TRUE);
945             }
946             }
947              
948 0         0 return($FALSE);
949             }
950              
951             # Traverses a tree starting at the given root node. It calls the given function for each node visited.
952             # The traversal can be halted at any point by returning TRUE from given function.
953             sub traverse() {
954              
955 10     10 1 94 my ($self, $root, $order, $flags, $depth, $funcref, $argref) = (shift, shift, shift, shift, shift, shift, shift);
956              
957 10 50       22 if(!defined($root)) {
958 0         0 return;
959             }
960 10 50       19 if(!defined($funcref)) {
961 0         0 return;
962             }
963 10 50       27 if(!($order <= $LEVEL_ORDER)) {
964 0         0 return;
965             }
966 10 50       20 if(!($flags <= $TRAVERSE_MASK)) {
967 0         0 return;
968             }
969 10 50 33     720 if(!($depth == -1 || $depth > 0)) {
970 0         0 return;
971             }
972              
973             SWITCH: {
974              
975 10 100       11 $order == $PRE_ORDER && do {
  10         23  
976              
977 2 50       6 if($depth < 0) {
978 2         8 $self->_traverse_pre_order($root, $flags, $funcref, $argref);
979             } else {
980 0         0 $self->_depth_traverse_pre_order($root, $flags, $depth, $funcref, $argref);
981             }
982 2         6 last SWITCH;
983             };
984 8 100       14 $order == $POST_ORDER && do {
985              
986 1 50       19 if($depth < 0) {
987 1         6 $self->_traverse_post_order($root, $flags, $funcref, $argref);
988             } else {
989 0         0 $self->_depth_traverse_post_order($root, $flags, $depth, $funcref, $argref);
990             }
991 1         14 last SWITCH;
992             };
993 7 100       14 $order == $IN_ORDER && do {
994              
995 2 50       6 if($depth < 0) {
996 2         8 $self->_traverse_in_order($root, $flags, $funcref, $argref);
997             } else {
998 0         0 $self->_depth_traverse_in_order($root, $flags, $depth, $funcref, $argref);
999             }
1000 2         5 last SWITCH;
1001             };
1002 5 50       11 $order == $LEVEL_ORDER && do {
1003              
1004 5 50       10 if(defined($root->{children})) {
    0          
1005 5 50 66     19 if(!(($flags & $TRAVERSE_NON_LEAFS) && &$funcref($root, $argref))) {
1006 5 50       188 if($depth < 0) {
1007 5         15 $self->_traverse_children($root, $flags, $funcref, $argref);
1008             } else {
1009 0         0 $depth--;
1010 0 0       0 if($depth) {
1011 0         0 $self->_depth_traverse_children($root, $flags, $depth, $funcref, $argref);
1012             }
1013             }
1014             }
1015             } elsif($flags & $TRAVERSE_LEAFS) {
1016 0         0 &$funcref($root, $argref);
1017             }
1018 5         14 last SWITCH;
1019             };
1020             } # End SWITCH
1021             }
1022              
1023             # Finds a node in a tree.
1024             sub find() {
1025              
1026 2     2 1 19 my ($self, $root, $order, $flags, $data) = (shift, shift, shift, shift, shift);
1027 2         3 my @d;
1028              
1029 2 50       7 if(!defined($root)) {
1030 0         0 return(undef);
1031             }
1032 2 50       4 if(!($order <= $LEVEL_ORDER)) {
1033 0         0 return(undef);
1034             }
1035 2 50       6 if(!($flags <= $TRAVERSE_MASK)) {
1036 0         0 return(undef);
1037             }
1038              
1039 2         4 $d[0] = $data;
1040 2         3 $d[1] = undef;
1041              
1042             $self->traverse(
1043             $root,
1044             $order,
1045             $flags,
1046             -1,
1047             sub {
1048 10     10   13 my ($node, $ref_of_array) = (shift, shift);
1049              
1050 10 100       99 if($$ref_of_array[0] ne $node->{data}) {
1051 9         45 return($FALSE);
1052             }
1053              
1054 1         2 $$ref_of_array[1] = $node;
1055              
1056 1         5 return($TRUE);
1057             },
1058             \@d
1059 2         24 );
1060              
1061 2         39 return($d[1]);
1062             }
1063              
1064             # Finds the first child of a node with the given data.
1065             sub find_child() {
1066              
1067 1     1 1 10 my ($self, $node, $flags, $data) = (shift, shift, shift, shift);
1068              
1069 1 50       4 if(!defined($node)) {
1070 0         0 return(undef);
1071             }
1072 1 50       11 if(!($flags <= $TRAVERSE_MASK)) {
1073 0         0 return(undef);
1074             }
1075              
1076 1         3 $node = $node->{children};
1077              
1078 1         3 while(defined($node)) {
1079              
1080 2 100       6 if($node->{data} eq $data) {
1081 1 50       5 if($self->is_leaf($node)) {
1082 0 0       0 if($flags & $TRAVERSE_LEAFS) {
1083 0         0 return($node);
1084             }
1085             } else {
1086 1 50       4 if($flags & $TRAVERSE_NON_LEAFS) {
1087 1         31 return($node);
1088             }
1089             }
1090             }
1091              
1092 1         3 $node = $node->{next};
1093             }
1094              
1095 0         0 return(undef);
1096             }
1097              
1098             # Calls a function for each of the children of a node.
1099             # Note that it doesn't descend beneath the child nodes.
1100             sub children_foreach() {
1101              
1102 12     12 1 25 my ($self, $node, $flags, $funcref, $argref) = (shift, shift, shift, shift, shift);
1103              
1104 12 50       21 if(!defined($node)) {
1105 0         0 return;
1106             }
1107 12 50       23 if(!($flags <= $TRAVERSE_MASK)) {
1108 0         0 return;
1109             }
1110 12 50       22 if(!defined($funcref)) {
1111 0         0 return;
1112             }
1113              
1114 12         28 $node = $node->{children};
1115              
1116 12         24 while(defined($node)) {
1117              
1118 30         60 my $current = $self->new();
1119              
1120 30         45 $current = $node;
1121 30         50 $node = $current->{next};
1122              
1123 30 100       181 if($self->is_leaf($current)) {
1124 23 50       48 if($flags & $TRAVERSE_LEAFS) {
1125 23         31 &$funcref($current, $argref);
1126             }
1127             } else {
1128 7 50       17 if($flags & $TRAVERSE_NON_LEAFS) {
1129 7         13 &$funcref($current, $argref);
1130             }
1131             }
1132             }
1133              
1134 12         17 return;
1135             }
1136              
1137             #
1138             # Sort methods
1139             #
1140              
1141             #_pchild_ref is just gathering references
1142             sub _pchild_ref() {
1143              
1144 30     30   35 my ($node, $aref) = (shift, shift);
1145              
1146 30         111 push @$aref, $node;
1147             }
1148              
1149             # Sort a tree
1150             sub tsort() {
1151              
1152 11     11 1 27 my ($self, $node) = (shift, shift);
1153 11         12 my @back;
1154              
1155 11 100       38 return if($self->is_leaf($node));
1156              
1157             # gather all the children references and sort them
1158             # according to the data field backwards (Z Y X W ...)
1159 4         17 $self->children_foreach($node, $Tree::Nary::TRAVERSE_ALL, \&_pchild_ref, \@back);
1160 4         15 @back = sort { $b->{data} cmp $a->{data} } @back;
  8         20  
1161              
1162 4         12 for (@back) { # for every reference found (in backward order)
1163 10         22 $self->unlink($_); # detach it from parent
1164 10         43 $self->prepend($node, $_); # prepend it 0> first child
1165 10         31 $self->tsort($_); # call tsort recursively for its children
1166             }
1167             }
1168              
1169             #
1170             # Comparison methods
1171             #
1172              
1173             # Generate a normalized tree
1174             sub normalize() {
1175              
1176 12     12 1 17 my ($self, $node) = (shift, shift);
1177              
1178             # Initialize result for a leaf
1179 12         12 my $result = '*';
1180              
1181 12 100       20 if(!$self->is_leaf($node)) {
1182              
1183 4         3 my @childs;
1184             my @chldMaps;
1185              
1186 4         11 $self->children_foreach($node, $Tree::Nary::TRAVERSE_ALL, \&_pchild_ref, \@childs);
1187              
1188 4         8 for(@childs) {
1189 10         31 push @chldMaps, $self->normalize($_);
1190             }
1191              
1192 4         17 $result = '('.join('', sort @chldMaps).')';
1193             }
1194              
1195 12         32 return($result);
1196             }
1197              
1198             # Compares two trees and returns TRUE if they are identical
1199             # in their structures and their contents
1200             sub is_identical() {
1201              
1202 6     6 1 14 my ($self, $t1, $t2) = (shift, shift, shift);
1203 6         7 my $i;
1204             my @t1childs;
1205 0         0 my @t2childs;
1206              
1207             # Exit if one of them is leaf and the other isn't
1208 6 50 66     14 return($FALSE) if(($self->is_leaf($t1) && !$self->is_leaf($t2)) or
      66        
      33        
1209             (!$self->is_leaf($t1) && $self->is_leaf($t2)));
1210              
1211             # Exit if they have different amount of children
1212 6 50       18 return($FALSE) if($self->n_children($t1) != $self->n_children($t2));
1213              
1214             # => HERE BOTH ARE LEAFS OR PARENTS WITH SAME AMOUNT OF CHILDREN
1215              
1216 6 50       17 return($FALSE) if($t1->{data} ne $t2->{data}); # exit if different content
1217 6 100       12 return($TRUE) if($self->is_leaf($t1)); # if T1 is leaf, both are: hey, identical!!
1218              
1219             # => HERE BOTH ARE PARENTS WITH SAME AMOUNT OF CHILDREN
1220              
1221             # get the children references for $t1 and $t2
1222 2         8 $self->children_foreach($t1, $Tree::Nary::TRAVERSE_ALL, \&_pchild_ref, \@t1childs);
1223 2         6 $self->children_foreach($t2, $Tree::Nary::TRAVERSE_ALL,\&_pchild_ref, \@t2childs);
1224              
1225 2         6 for $i (0 .. scalar(@t1childs)-1) { # iterate all children by index
1226 5 50       26 next if($self->is_identical($t1childs[$i], $t2childs[$i]) == $TRUE);
1227 0         0 return($FALSE);
1228             }
1229              
1230 2         8 return($TRUE);
1231             }
1232              
1233             # Compare the structure of two trees by comparing their canonical shapes
1234             sub has_same_struct() {
1235              
1236 1     1 1 7 my ($self, $t1, $t2) = (shift, shift, shift);
1237 1         4 my $t1c = $self->normalize($t1);
1238 1         4 my $t2c = $self->normalize($t2);
1239              
1240 1 50       7 return($TRUE) if($t1c eq $t2c); # if the two canons are identical, structure is same
1241 0           return($FALSE); # structure is different
1242             }
1243              
1244             1;
1245              
1246             __END__