[Bio] / FigKernelPackages / FIGtree.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/FIGtree.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download) (as text)

1 : golsen 1.1 package FIGtree;
2 :    
3 :     # use Carp;
4 :     # use strict;
5 :    
6 :     require Exporter;
7 :     our @ISA = qw(Exporter);
8 :     our @EXPORT = qw(
9 :     FIGtree_to_newick
10 :     FIGtree_to_overbeek
11 :     newick_to_FIGtree
12 :     overbeek_to_FIGtree
13 :    
14 :     FIG_build_tree_from_subtrees
15 :     FIG_chop_tree
16 :     FIG_closest_common_ancestor
17 :     FIG_collapse_node_node
18 :     FIG_collapse_node_tip
19 :     FIG_copy_tree
20 :     FIG_dist_node_to_node
21 :     FIG_dist_tip_to_tip
22 :     FIG_dist_to_first_tip
23 :     FIG_dist_to_node
24 :     FIG_dist_to_root
25 :     FIG_dist_to_tip
26 :     FIG_duplicate_tips
27 :     FIG_duplicate_nodes
28 :     FIG_first_tip
29 :     FIG_max_label
30 :     FIG_min_label
31 :     FIG_nodes_of_tree
32 :     FIG_nodes_within_dist
33 :     FIG_num_nodes
34 :     FIG_num_tips
35 :     FIG_path_to_first_tip
36 :     FIG_path_to_node
37 :     FIG_path_to_node_ref
38 :     FIG_path_to_root
39 :     FIG_path_to_tip
40 :     FIG_prefix_of
41 :     FIG_print_node
42 :     FIG_print_tree
43 :     FIG_prune_node
44 :     FIG_prune_tip
45 :     FIG_random_order_tree
46 :     FIG_representative_tree
47 :     FIG_reverse_tree
48 :     FIG_shared_tips
49 :     FIG_steps_to_node
50 :     FIG_steps_to_root
51 :     FIG_steps_to_fist_tip
52 :     FIG_steps_to_tip
53 :     FIG_tips_of_tree
54 :     FIG_tips_within_dist
55 :     FIG_tips_within_steps
56 :     FIG_tree_length
57 :     add_FIG_branch_attrib
58 :     add_FIG_desc
59 :     add_FIG_node_attrib
60 :     build_tip_count_hash
61 :     collapse_FIG_tree
62 :     collect_all_tips
63 :     collect_all_nodes
64 :     delete_elm
65 :     delete_FIG_branch_attrib
66 :     delete_FIG_descRef
67 :     delete_FIG_ith_desc
68 :     delete_FIG_node_attrib
69 :     delete_FIG_node
70 :     delete_FIG_tip
71 :     distance_along_path
72 :     distance_along_path_2
73 :     fill_FIGtree_parents
74 :     fill_overbeek_parents
75 :     first_tip_ref
76 :     get_FIG_X
77 :     get_FIG_branch_attrib
78 :     get_FIG_context
79 :     get_FIG_descList
80 :     get_FIG_descRef
81 :     get_FIG_ith_desc
82 :     get_FIG_ith_branch_attribute
83 :     get_FIG_ith_node_attribute
84 :     get_FIG_label
85 :     get_FIG_max_desc
86 :     get_FIG_max_desc_ref
87 :     get_FIG_max_label
88 :     get_FIG_min_desc
89 :     get_FIG_min_desc_ref
90 :     get_FIG_min_label
91 :     get_FIG_node_attrib
92 :     get_FIG_num_branch_attrib
93 :     get_FIG_num_node_attrib
94 :     get_FIG_numDesc
95 :     get_FIG_parent
96 :     get_FIG_root
97 :     get_FIG_tipref
98 :     get_path_to_first_tip
99 :     get_path_to_root
100 :     has_cycles
101 :     is_FIG_bifurcating
102 :     is_FIG_node
103 :     is_FIG_root
104 :     is_FIG_rooted
105 :     is_FIG_tip
106 :     is_FIG_tip_rooted
107 :     is_FIG_unrooted
108 :     is_desc_of_FIGnode
109 :     is_tip_in_FIG
110 :     layout_FIG_tree
111 :     maxref_of_subtree
112 :     minref_of_subtree
113 :     most_distant_tip_path
114 :     most_distant_tip_name
115 :     most_distant_tip_ref
116 :     most_distant_tip_path
117 :     normalize_FIG_tree
118 :     nodes_down_within_dist
119 :     nodes_up_within_dist
120 :     print_attrib_hash
121 :     read_FIG_from_str
122 :     rearrange_FIG_largest_out
123 :     rearrange_FIG_smallest_out
124 :     reorder_FIG_against_tip_count
125 :     reorder_FIG_by_tip_count
126 :     reroot_FIG_by_path
127 :     reroot_FIG_next_to_tip
128 :     reroot_FIG_to_node
129 :     reroot_FIG_to_node_ref
130 :     reroot_FIG_to_tip
131 :    
132 :     set_FIG_label
133 :     set_FIG_X
134 :     set_FIG_parent
135 :     set_FIG_descRef
136 :     set_FIG_node_attrib
137 :     set_FIG_branch_attrib
138 :     set_FIG_ith_desc
139 :     set_FIG_descList
140 :     set_FIG_ith_node_attrib
141 :     set_FIG_ith_branch_attrib
142 :     set_FIG_undef_branch
143 :     std_unrooted_FIG
144 :     tips_down_within_steps
145 :     tips_up_within_steps
146 :     tot_nodes_within_dist
147 :     tot_tips_within_steps
148 :     uproot_FIG
149 :     uproot_tip_to_node
150 :     write_FIG_to_Newick
151 :     );
152 :    
153 :     our @EXPORT_OK = qw(
154 :     get_FIG_label
155 :     get_FIG_X
156 :     get_FIG_parent
157 :     get_FIG_node_attributes
158 :     get_FIG_branch_attributes
159 :     get_FIG_descList
160 :     get_FIG_ith_desc
161 :     get_FIG_ith_node_attribute
162 :     set_FIG_label
163 :     set_FIG_X
164 :     set_FIG_parent
165 :     set_FIG_descRef
166 :     set_FIG_node_attrib
167 :     set_FIG_branch_attrib
168 :     set_FIG_ith_desc
169 :     set_FIG_ith_node_attrib
170 :     set_FIG_ith_branch_attrib
171 :     add_FIG_desc
172 :     add_FIG_node_attrib
173 :     add_FIG_branch_attrib
174 :     delete_FIG_ith_desc
175 :     delete_FIG_ith_node_attrib
176 :     delete_FIG_ith_branch_attrib
177 :     delete_FIG_descRef
178 :     );
179 :    
180 :     use gjolists qw(
181 :     common_prefix
182 :     common_and_unique
183 :     unique_suffixes
184 :     unique_set
185 :     duplicates
186 :     random_order
187 :     union
188 :     intersection
189 :     set_difference
190 :     );
191 :    
192 :     use gjonewicklib qw(
193 :     writeNewickTree
194 :     fwriteNewickTree
195 :     strNewickTree
196 :     formatNewickTree
197 :    
198 :     parse_newick_tree_str
199 :    
200 :     layout_tree
201 :     );
202 :    
203 :     #=============================================================================
204 :     # FIG tree
205 :     #
206 :     # Tree is:
207 :     #
208 :     # [ Label,
209 :     # X, # distance to parent
210 :     # ParentPointer,
211 :     # [ ChildPointer1, ... ],
212 :     # %NodeAttributes,
213 :     # %BranchAttributes
214 :     # ]
215 :     #
216 :     # Overbeek tree:
217 :     #
218 :     # [ Label,
219 :     # DistanceToParent,
220 :     # [ ParentPointer, ChildPointer1, ... ],
221 :     # [ Name1\tVal1, Name2\Val2, ... ]
222 :     # ]
223 :     #
224 :     # Olsen "newick" representation in perl:
225 :     #
226 :     # $tree = \@rootnode;
227 :     #
228 :     # @node = ( \@desc, # reference to list of descendants
229 :     # $label, # node label
230 :     # $x, # branch length
231 :     # \@c1, # reference to comment list 1
232 :     # \@c2, # reference to comment list 2
233 :     # \@c3, # reference to comment list 3
234 :     # \@c4, # reference to comment list 4
235 :     # \@c5 # reference to comment list 5
236 :     # )
237 :     #
238 :     #
239 :     #-------------------------------------------------------------------------
240 :     # Internally used definitions
241 :     #-------------------------------------------------------------------------
242 :    
243 :     sub array_ref { ref( $_[0] ) eq "ARRAY" }
244 :     sub hash_ref { ref( $_[0] ) eq "HASH" }
245 :     sub by_distance { return ($a->[1] <=> $b->[1]); }
246 :     sub by_name { return ($a->[0] <=> $b->[0]); }
247 :    
248 :     sub delete_elm {
249 :     # deletes $elm from @$list";
250 :     my ($list, $elm) = @_;
251 :     array_ref( $list ) && defined($elm) || undef;
252 :     if (scalar @$list == 1 ) { $list->[0] eq $elm ? () : undef; }
253 :     for (my $i = 0 ; $i < scalar @$list; $i++) {
254 :     if ($list->[$i] eq $elm) { splice (@$list, $i, 1) }
255 :     }
256 :     $list;
257 :     }
258 :    
259 :     #=============================================================================
260 :     # FIGtree's get operations
261 :     #=========================================================================
262 :     #
263 :     # Note: there is a distinction between fig-node and fig-tip
264 :     # a fig-node is a node with descendants and no label
265 :     # a fig-tip is a node without descendants and label.
266 :     # when necessary, you will find separate functions for each
267 :     #=========================================================================
268 :     sub get_FIG_label { $_[0]->[0] }
269 :     sub get_FIG_X { $_[0]->[1] }
270 :     sub get_FIG_parent { $_[0]->[2] }
271 :     sub get_FIG_descRef { $_[0]->[3] }
272 :     sub get_FIG_node_attrib { $_[0]->[4] }
273 :     sub get_FIG_branch_attrib { $_[0]->[5] }
274 :    
275 :     sub get_FIG_numDesc {
276 :     # $numDesc = get_FIG_numDesc($node)
277 :     my ($FIG_node) = @_;
278 :     my $i = $FIG_node->[3];
279 :     ! array_ref( $FIG_node)? undef :
280 :     ! array_ref( $i ) ? undef :
281 :     (scalar @$i) <= 0 ? 0 :
282 :     scalar @$i ;
283 :     }
284 :    
285 :     sub get_FIG_descList {
286 :     my $node = $_[0];
287 :     ! array_ref( $node ) ? undef :
288 :     array_ref( $node->[3] ) ? @{ $node->[3] } :
289 :     () ;
290 :     }
291 :    
292 :     sub get_FIG_ith_desc {
293 :     my ( $FIG_node, $i ) = @_;
294 :     ! array_ref( $FIG_node ) ? undef :
295 :     array_ref( $FIG_node->[3] ) ?
296 :     $FIG_node->[3]->[$i-1] :
297 :     undef ;
298 :     }
299 :    
300 :     sub get_FIG_num_node_attrib {
301 :     my ($FIG_node) = @_;
302 :     my $i = $FIG_node->[4];
303 :     ! array_ref( $FIG_node) ? undef :
304 :     ! hash_ref( $i ) ? undef :
305 :     (scalar keys %$i) <= 0 ? 0 :
306 :     scalar keys %$i ;
307 :     }
308 :    
309 :     sub get_FIG_num_branch_attrib {
310 :     my ($FIG_node) = @_;
311 :     my $i = $FIG_node->[5];
312 :     ! array_ref( $FIG_node) ? undef :
313 :     ! hash_ref( $i ) ? undef :
314 :     (scalar keys %$i) <= 0 ? 0 :
315 :     scalar keys %$i ;
316 :     }
317 :    
318 :     sub get_FIG_ith_node_attribute {
319 :     my ( $FIG_node, $i ) = @_;
320 :     ! array_ref( $FIG_node ) ? undef :
321 :     array_ref( $FIG_node->[4] ) ?
322 :     $FIG_node->[4]->[$i-1] :
323 :     undef ;
324 :     }
325 :    
326 :     sub get_FIG_ith_branch_attribute {
327 :     my ( $FIG_node, $i ) = @_;
328 :     ! array_ref( $FIG_node ) ? undef :
329 :     array_ref( $FIG_node->[5] ) ?
330 :     $FIG_node->[5]->[$i-1] :
331 :     undef ;
332 :     }
333 :    
334 :     sub get_FIG_tipref {
335 :     my ($tree, $tipname) = @_;
336 :     array_ref($tree) && defined($tipname) || undef;
337 :     my @path = FIG_path_to_tip($tree, $tipname);
338 :     scalar @path > 0 ? pop @path : undef;
339 :     }
340 :    
341 :     sub get_FIG_root {
342 :     my ($node) = @_;
343 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
344 :     ! $node->[2] ? return $node :
345 :     return &get_FIG_root($node->[2]);
346 :     }
347 :    
348 :     #------------------------------------------------------------------
349 :     # boolean functions
350 :     #------------------------------------------------------------------
351 :     sub is_FIG_node {
352 :     # A node with nonempty descend list
353 :     my $FIG_node = $_[0];
354 :     ! array_ref( $FIG_node ) ? undef :
355 :     ( array_ref( $FIG_node->[3] ) &&
356 :     ( @{ $FIG_node->[3] } > 0 ) ) ?
357 :     1 : undef
358 :     ;
359 :     }
360 :    
361 :     sub is_FIG_root {
362 :     # A node with no parent ref
363 :     my $FIG_node = $_[0];
364 :     ! array_ref( $FIG_node ) ? undef :
365 :     ( array_ref( $FIG_node->[2] ) &&
366 :     ( @{ $FIG_node->[2] } == 0 ) ) ?
367 :     1 : undef
368 :     ;
369 :     }
370 :    
371 :     sub is_desc_of_FIGnode {
372 :     # tests if $descref is descendant of $noderef
373 :     my ($noderef, $descref) = @_;
374 :     array_ref( $noderef ) && array_ref( $descref ) || undef;
375 :     my @children = get_FIG_descList($noderef);
376 :     my $found = "n";
377 :     my $child;
378 :     foreach $child (@children) { $found = "y" if ($child eq $descref); }
379 :     $found eq "y" ? 1 : 0 ;
380 :     }
381 :    
382 :     sub is_FIG_tip {
383 :     # input is a noderef
384 :     my $FIG_node = $_[0];
385 :     ! array_ref( $FIG_node ) ? undef :
386 :     ( @{ $FIG_node->[3] } == 0 ) ?
387 :     1 : undef
388 :     ;
389 :     }
390 :    
391 :     sub is_tip_in_FIG {
392 :     # input: treeref and tip label. tests if tip label is in tree
393 :     my ($tree , $tipname) = @_;
394 :     my $tipref = get_FIG_tipref($tree , $tipname);
395 :     $tipref ? 1 : undef
396 :     ;
397 :     }
398 :    
399 :     sub is_FIG_rooted {
400 :     # tests if root node has two children
401 :     my ($root) = @_;
402 :     ! array_ref( $root ) ? undef :
403 :     array_ref( $root->[3] ) ? @{ $root->[3] } == 2 :
404 :     0 ;
405 :     }
406 :    
407 :     sub is_FIG_unrooted {
408 :     # tests if root node has three children
409 :     my ($root) = @_;
410 :     ! array_ref( $root ) ? undef :
411 :     array_ref( $root->[3] ) ? @{ $root->[3] } == 3 :
412 :     0 ;
413 :     }
414 :    
415 :     sub is_FIG_tip_rooted {
416 :     my $node = $_[0];
417 :     ! array_ref( $node ) ? undef : # Not a node ref
418 :     array_ref( $node->[3] ) ? @{ $node->[3] } == 1 : # 1 branch
419 :     0 ; # No descend list
420 :     }
421 :    
422 :     sub is_FIG_bifurcating {
423 :     my ($node, $notroot) = @_;
424 :     if ( ! array_ref( $node ) ) { return undef } # Bad arg
425 :    
426 :     my $n = get_FIG_numDesc($node);
427 :    
428 :     $n == 0 && ! $notroot ? 0 :
429 :     $n == 1 && $notroot ? 0 :
430 :     $n == 3 && $notroot ? 0 :
431 :     $n > 3 ? 0 :
432 :     $n > 2 && ! is_FIG_bifurcating(get_FIG_ith_desc($node,3,1)) ? 0 :
433 :     $n > 1 && ! is_FIG_bifurcating(get_FIG_ith_desc($node,2,1)) ? 0 :
434 :     $n > 0 && ! is_FIG_bifurcating(get_FIG_ith_desc($node,1,1)) ? 0 : $n
435 :     }
436 :    
437 :     sub has_cycles {
438 :     # assumes path was acyclic when last insertion was made
439 :     # we only have to check if last insertion created a cycle
440 :     # note: path is a list of node refs
441 :     my ($path) = @_;
442 :     my $size = scalar @$path;
443 :     my $last = $path->[$size-1];
444 :     my $i=0,$found="no";
445 :     while (($i<= ($size-2)) && ( $found == "no"))
446 :     { if ($path->[$i] eq $last) {$found="yes";}
447 :     $i++; }
448 :     $found eq "yes" ? 1 : undef;
449 :     }
450 :    
451 :     #-------------------------------------------------------------------------
452 :     # update (i.e. set,add,delete) functions
453 :     #-------------------------------------------------------------------------
454 :    
455 :     sub set_FIG_label { $_[0]->[0] = $_[1] }
456 :     sub set_FIG_X { $_[0]->[1] = $_[1] }
457 :     sub set_FIG_parent{ $_[0]->[2] = $_[1] }
458 :     sub set_FIG_descRef { $_[0]->[3] = $_[1] }
459 :     sub set_FIG_node_attrib { $_[0]->[4] = $_[1] }
460 :     sub set_FIG_branch_attrib {$_[0]->[5] = $_[1] }
461 :    
462 :     sub set_FIG_descList {
463 :     # input: node, newList. Sets node's descList to newList
464 :     my $node = shift;
465 :     array_ref( $node ) || return;
466 :     if ( array_ref( $node->[3] ) ) { @{ $node->[3] } = @_ }
467 :     else { $node->[3] = [ @_ ] }
468 :     }
469 :    
470 :     sub set_FIG_ith_desc {
471 :     # sets node1's ith-desc to arrayref of node2
472 :     my ($node1, $i, $node2) = @_;
473 :     array_ref( $node1 ) && array_ref( $node2 ) || return;
474 :     if ( array_ref( $node1->[3] ) ) { $node1->[3]->[$i-1] = $node2 }
475 :     else { $node1->[3] = [ $node2 ] }
476 :     }
477 :    
478 :     sub set_FIG_undef_branch {
479 :     # searches in entire subtree rooted at $node for nodes w/undefined X
480 :     # and changes them to $x; returns number of nodes whose vals were reset
481 :     my ($node, $x, $tot) = @_;
482 :     array_ref($node) && defined($x) || return 0;
483 :    
484 :     if ( ! defined( get_FIG_X( $node ) ) ){
485 :     set_FIG_X( $node, $x );
486 :     $tot++;
487 :     }
488 :     if (is_FIG_tip($node)) {return $tot;}
489 :    
490 :     my $n = $tot;
491 :     foreach $child (@{$node->[3]}) {
492 :     $n += set_FIG_undef_branch( $child, $x, 0 );
493 :     }
494 :     $tot+= $n;
495 :     return $tot;
496 :     }
497 :    
498 :     sub add_FIG_desc {
499 :     # adds a descendant [$child] to node's descList
500 :     my ($node, $child) = @_;
501 :     my $numDesc = $node->[3];
502 :     array_ref( $node ) && array_ref( $child ) || return;
503 :     if ( array_ref( $node->[3] ) )
504 :     { $node->[3]->[ scalar @$numDesc ] = $child }
505 :     else
506 :     { $node->[3] = [ $child ] }
507 :     }
508 :    
509 :     sub add_FIG_node_attrib {
510 :     # adds a node attribute to node
511 :     my ($node, $attrib) = @_;
512 :     my ($key, $val);
513 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
514 :     while (($key, $val) = each %$attrib) {
515 :     push( @{ $node->[4]{ $key } }, $val);
516 :     #print "$key, $val";
517 :     }
518 :     }
519 :     }
520 :    
521 :     sub add_FIG_branch_attrib {
522 :     # adds a branch attribute to node
523 :     my ($node, $attrib) = @_;
524 :     my ($key, $val);
525 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
526 :     while (($key, $val) = each %$attrib) {
527 :     push( @{ $node->[5]{ $key } }, $val);
528 :     # print "$key, $val";
529 :     }
530 :     }
531 :     }
532 :     sub delete_FIG_ith_desc {
533 :     # deletes node's ith descendant
534 :     my ( $node, $i ) = @_;
535 :     if ((! array_ref( $node )) && (! array_ref( $node->[3])) )
536 :     { return undef }
537 :     elsif ($i == 1) { pop(@{$node->[3]}) }
538 :     else { splice(@{$node->[3]},$ith-1,1) }
539 :     }
540 :    
541 :     sub delete_FIG_descRef{
542 :     #deletes $noderef from node's desclist
543 :     my ($node, $noderef) = @_;
544 :     array_ref( $node ) && defined($noderef) || undef;
545 :     my $numdesc = scalar @{$node->[3]};
546 :     $numdesc || undef;
547 :    
548 :     if ($numdesc == 1 ) { shift(@{$node->[3]}) }
549 :     elsif ($node->[3]->[$numdesc-1] eq $noderef ) { pop(@{$node->[3]}) }
550 :     else
551 :     { for ( my $i = 0; $i < $numdesc; $i++ ) {
552 :     if ($node->[3]->[$i] eq $noderef)
553 :     { splice(@{$node->[3]},$i,1) }
554 :     }
555 :     }
556 :     $node->[3];
557 :     }
558 :    
559 :     sub delete_FIG_node_attrib {
560 :     # deletes node attribute from node's list
561 :     my ($node, $attrib) = @_;
562 :     my ($key, $val);
563 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
564 :     while ( ($key,$val) = each %$attrib) {
565 :     my $val1 = $node->[4]{$key};
566 :     if (!array_ref($val1) )
567 :     { delete $node->[4]{ $key } ; return ; }
568 :     else
569 :     {
570 :     for (my $i=0;$i < scalar @$val1; $i++) {
571 :     if ($val1->[$i] eq $val) { splice @$val1,i,1 }
572 :     }
573 :     if (scalar @$val1 == 0) {
574 :     delete $node->[4]{ $key }; return ; }
575 :     }
576 :     }
577 :     }
578 :     else { undef }
579 :     }
580 :    
581 :     sub delete_FIG_branch_attrib {
582 :     # deletes branch attribute from node's list
583 :     my ($node, $attrib) = @_;
584 :     my ($key, $val);
585 :     if ( array_ref( $node ) && hash_ref( $attrib ) ) {
586 :     while ( ($key,$val) = each %$attrib) {
587 :     my $val1 = $node->[5]{$key};
588 :     if (!array_ref($val1) )
589 :     { delete $node->[5]{ $key } ; return ; }
590 :     else
591 :     {
592 :     for (my $i=0;$i < scalar @$val1; $i++) {
593 :     if ($val1->[$i] eq $val) { splice @$val1,i,1 }
594 :     }
595 :     if (scalar @$val1 == 0) {
596 :     delete $node->[5]{ $key }; return ; }
597 :     }
598 :     }
599 :     }
600 :     else { undef }
601 :     }
602 :    
603 :     sub delete_FIG_tip {
604 :     # tip node is deleted. resulting tree is NOT normalized
605 :     my ($tree, $tip1) = @_;
606 :     array_ref($tree) && defined($tip1) || undef;
607 :     if (! array_ref($tip1) )
608 :     { # arg 2 is a tipname; we need a tipref
609 :     $tip1 = get_FIG_tipref($tree,$tip1);
610 :     }
611 :     is_FIG_tip($tip1) || undef;
612 :     my $parent = $tip1->[2];
613 :     array_ref($parent) || undef;
614 :     delete_FIG_descRef($parent,$tip1);
615 :     $parent;
616 :     }
617 :    
618 :     sub delete_FIG_node {
619 :     # node1 is deleted from $tree; its descedants are added to
620 :     # the parent's descList. Resulting $tree is NOT normalized
621 :     my ($tree, $node1) = @_;
622 :     is_FIG_node($node1) || undef;
623 :     if (is_FIG_root($node1)) { return uproot_FIG($node1) }
624 :     my $parent = $node1->[2];
625 :     my $children = $node1->[3];
626 :     if (@$children == 0) {
627 :     delete_FIG_descRef($parent,$node1);
628 :     return $parent;
629 :     }
630 :     delete_FIG_descRef($parent,$node1);
631 :     my $child;
632 :     foreach $child (@$children) {
633 :     add_FIG_desc($parent, $child);
634 :     }
635 :     $parent;
636 :     }
637 :    
638 :     #------------------------------------------------------------------
639 :     # statistics functions -- tree operations without side effects
640 :     #------------------------------------------------------------------
641 :     sub FIG_tree_length {
642 :     my ($node, $notroot) = @_;
643 :     array_ref( $node) || return;
644 :     my $x = $notroot ? get_FIG_X( $node ) : 0;
645 :     defined( $x ) || ( $x = 1 );
646 :    
647 :     my $imax = get_FIG_numDesc($node);
648 :     for ( my $i = 1; $i <= $imax; $i++ ) {
649 :     $x += FIG_tree_length( get_FIG_ith_desc($node, $i), 1 );
650 :     }
651 :     $x;
652 :     }
653 :    
654 :     sub FIG_nodes_of_tree {
655 :     # returns list of non-tip node references
656 :     &collect_all_nodes( @_ );
657 :     }
658 :    
659 :     sub FIG_tips_of_tree {
660 :     # returns list of tip labels of tree rooted at tree
661 :     map { get_FIG_label($_) } collect_all_tips( @_ );
662 :     }
663 :    
664 :     sub get_FIG_max_label {
665 :     # finds max of tree rooted at $tree
666 :     my ($tree) = @_;
667 :     my @tips = collect_all_tips($tree);
668 :     my ($maxref, $max );
669 :     $max = @tips->[0]->[1];
670 :     $maxref = @tips->[0];
671 :     for ($i=1; $i < @tips; $i++) {
672 :     if ( @tips->[$i]->[1] > $max) {
673 :     $max = @tips->[$i]->[1];
674 :     $maxref = @tips->[$i] ;
675 :     }
676 :     }
677 :     ($maxref, $max );
678 :     }
679 :    
680 :     sub get_FIG_min_label {
681 :     # finds min of tree rooted at $tree
682 :     my ($tree) = @_;
683 :     my @tips = collect_all_tips($tree);
684 :     my ($minref, $min);
685 :     $min = @tips->[0]->[1];
686 :     $minref = @tips->[0];
687 :     for ($i=1; $i < @tips; $i++) {
688 :     if ( @tips->[$i]->[1] < $min) {
689 :     $min = @tips->[$i]->[1] ;
690 :     $minref = @tips->[$i] ;
691 :     }
692 :     }
693 :     ($minref, $min);
694 :     }
695 :    
696 :    
697 :     sub get_FIG_min_desc {
698 :     # ($minref,$min) = get_FIG_min_desc($node)
699 :     my ( $FIG_node ) = @_;
700 :     if ((! array_ref( $FIG_node)) && (! array_ref( $FIG_node->[3] ) ) )
701 :     { return undef }
702 :     my ($minref,$min);
703 :     $min = $FIG_node->[3]->[0][1];
704 :     $minref = $FIG_node->[3]->[0];
705 :     my $i=1;
706 :     while ($i < @{$FIG_node->[3]}) {
707 :     if ( $FIG_node->[3]->[$i][1] < $min)
708 :     { $min = $FIG_node->[3]->[$i][1] ;
709 :     $minref = $FIG_node->[3]->[$i] ; }
710 :     $i++;
711 :     }
712 :     ($minref,$min);
713 :     }
714 :    
715 :     sub get_FIG_max_desc {
716 :     # ($maxref,$max) = get_FIG_max_desc($node)
717 :     my ( $FIG_node ) = @_;
718 :     if ((! array_ref( $FIG_node)) && (! array_ref( $FIG_node->[3] ) ) )
719 :     { return undef }
720 :     my ($maxref,$max);
721 :     $max = $FIG_node->[3]->[0][1];
722 :     $maxref = $FIG_node->[3]->[0];
723 :     my $i;
724 :     foreach $i (1 ..@{$FIG_node->[3]}) {
725 :     if ( $FIG_node->[3]->[$i][1] > $max)
726 :     { $max = $FIG_node->[3]->[$i][1] ;
727 :     $maxref = $FIG_node->[3]->[$i] ; }
728 :     }
729 :     ($maxref,$max);
730 :     }
731 :    
732 :     sub FIG_tips_within_dist {
733 :     # collecting all tips in neighborhood of $tree
734 :     # dist is defined by val of node->X
735 :     my ($tree, $dis, $ttips) = @_;
736 :     array_ref($tree) && defined($dis) || undef;
737 :     my $l1 = tips_down_within_dist($tree, $dis, $ttips);
738 :     my $l2 = tips_up_within_dist($tree, $dis, $ttips);
739 :     push(@$ttips,@$l1);
740 :     push(@$ttips,@$l2);
741 :     return $ttips;
742 :     }
743 :    
744 :     sub FIG_nodes_within_dist {
745 :     # collecting all non-tip nodes in neighborhood of tree
746 :     my ($tree, $dis, $tnodes) = @_;
747 :     array_ref($tree) && defined($dis) || undef;
748 :     my $l1 = nodes_down_within_dist($tree, $dis, $tnodes);
749 :     my $l2 = nodes_up_within_dist($tree, $dis, $tnodes);
750 :     shift @$l1;
751 :     push(@$tnodes,@$l1);
752 :     push(@$tnodes,@$l2);
753 :     return $tnodes;
754 :     }
755 :    
756 :     sub FIG_tips_within_steps {
757 :     # collecting all tips in neighborhood of tree
758 :     # one step = one jump from a node to next node in same branch
759 :     my ($tree, $step, $ttips) = @_;
760 :     array_ref($tree) && defined($step) || undef;
761 :     my $l1 = tips_down_within_steps($tree, $step, $ttips);
762 :     my $l2 = tips_up_within_steps($tree, $step, $ttips);
763 :     push(@$ttips,@$l1);
764 :     push(@$ttips,@$l2);
765 :     return $ttips;
766 :     }
767 :    
768 :     sub FIG_duplicate_tips {
769 :     # collects duplicate tips of subtree rooted at $fig
770 :     my ($fig) = @_;
771 :     my @listTips = collect_all_tips( $fig );
772 :     duplicates(@listTips);
773 :     }
774 :    
775 :     sub FIG_duplicate_nodes {
776 :     # collects duplicate non-tip nodes of subtree rooted at $fig
777 :     my ($fig) = @_;
778 :     my @listNodes = collect_all_nodes($fig);
779 :     duplicates(@listNodes);
780 :     }
781 :    
782 :     sub FIG_shared_tips {
783 :     # duplicate tips of two trees
784 :     my ($Tree1, $Tree2) = @_;
785 :     my ( @Tips1 ) = FIG_tips_of_tree( $Tree1 );
786 :     my ( @Tips2 ) = FIG_tips_of_tree( $Tree2 );
787 :     intersection( \@Tips1, \@Tips2 );
788 :     }
789 :    
790 :     sub FIG_num_tips {
791 :     # tot tips of tree rooted at $fig
792 :     ($fig)= @_;
793 :     my $tips = &collect_all_tips($fig, []);
794 :     return scalar @$tips;
795 :     }
796 :    
797 :     sub FIG_num_nodes {
798 :     # tot non-tip nodes of tree rooted at $fig
799 :     ($fig) = @_;
800 :     my $nodes = &collect_all_nodes($fig, []);
801 :     return scalar @$nodes;
802 :     }
803 :    
804 :     sub FIG_first_tip {
805 :     #first tip along path of $node
806 :     my ($node) = @_;
807 :     my $tipref = first_tip_ref($node);
808 :     get_FIG_label($tipref);
809 :     }
810 :    
811 :     sub first_tip_ref {
812 :     my ($node) = @_;
813 :     my $child;
814 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
815 :     if (&is_FIG_tip( $node ) ) { return $node; }
816 :     else {
817 :     foreach $child (@{$node->[3]}) {
818 :     &is_FIG_tip( $child ) ? return $child :
819 :     return &first_tip_ref ($child) ;
820 :     }
821 :     }
822 :     }
823 :    
824 :     sub FIG_dist_to_first_tip {
825 :     # distance from $node to first tip along that path
826 :     my ($node) = @_;
827 :     my $path = &get_path_to_first_tip($node);
828 :     distance_along_path(@$path);
829 :     }
830 :    
831 :     sub FIG_steps_to_fist_tip {
832 :     # steps needed to reach first tip from current pos at $node
833 :     my ($node) = @_;
834 :     my $path = get_path_to_first_tip($node);
835 :     return scalar @$path -1;
836 :     }
837 :    
838 :     sub FIG_prefix_of {
839 :     # input: treeref, tipname
840 :     # returns all non-tip nodes along path from root to tip
841 :     my @path = FIG_path_to_tip(@_[0],@_[1]);
842 :     pop @path; #delete tipref from path
843 :     @path;
844 :     }
845 :    
846 :     sub FIG_dist_to_tip {
847 :     # caclulates distance from tree's root to tip
848 :     my ($tree, $tip) = @_;
849 :     my @path = FIG_path_to_tip($tree, $tip);
850 :     distance_along_path(@path);
851 :     }
852 :    
853 :     sub FIG_steps_to_tip {
854 :     # calculates steps from root to tip
855 :     my ($tree, $tip) = @_;
856 :     my @path = FIG_path_to_tip($tree, $tip);
857 :     return scalar @path - 1;
858 :     }
859 :    
860 :     sub FIG_dist_to_node {
861 :     # calculates distance from root to non-tip node
862 :     my ($tree, $node) = @_;
863 :     my @path = FIG_path_to_node_ref( $tree, $node);
864 :     distance_along_path(@path);
865 :     }
866 :    
867 :     sub FIG_steps_to_node {
868 :     # calculates steps from root to non-tip node
869 :     my ($tree, $node) = @_;
870 :     my @path = FIG_path_to_node_ref( $tree, $node);
871 :     return scalar @path -1;
872 :     }
873 :    
874 :     sub FIG_dist_to_root {
875 :     #calculates distance from noderef to root
876 :     my ($tree, $node) = @_;
877 :     FIG_dist_to_node($tree, $node);
878 :     }
879 :    
880 :     sub FIG_steps_to_root {
881 :     #calculates steps from noderef to root
882 :     my ($tree, $node) = @_;
883 :     FIG_steps_to_node($tree, $node);
884 :     }
885 :    
886 :     sub FIG_path_to_first_tip {
887 :     my ($node) = @_;
888 :     &get_path_to_first_tip($node,[]);
889 :     }
890 :    
891 :    
892 :     sub collect_all_tips {
893 :     # collects tiprefs of subtree rooted at $node
894 :     ($node , $tipList) = @_;
895 :     my $child;
896 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef }
897 :     if (&is_FIG_tip( $node ) ) { push( @$tipList, $node )}
898 :     else {
899 :     foreach $child (@{$node->[3]})
900 :     { &collect_all_tips($child,$tipList); }
901 :     }
902 :     return (@$tipList);
903 :     }
904 :    
905 :     sub collect_all_nodes {
906 :     # collects all non-tip noderefs of subtree rooted at $node
907 :     ($node , $nodeList) = @_;
908 :     my $child;
909 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
910 :     if (&is_FIG_tip( $node ) ) { undef }
911 :     else {
912 :     push (@$nodeList, $node);
913 :     foreach $child (@{$node->[3]})
914 :     { &collect_all_nodes($child,$nodeList); }
915 :     }
916 :     return ($nodeList);
917 :     }
918 :    
919 :    
920 :     sub tips_down_within_dist {
921 :     # collects tips of tree rooted at $node that are within $dist
922 :     my ($node, $dist) = @_;
923 :     array_ref($node) && defined($dist) || undef;
924 :     tot_tips_within_dist($node, $dist);
925 :     }
926 :    
927 :     sub tips_up_within_dist {
928 :     # collects tips of tree that end at this node and that are within $dist
929 :     my ($node, $dist, $list) = @_;
930 :     ! array_ref($node) ? return undef : 1;
931 :     if ($dist < 0 ) { return undef }
932 :     my $parent = $node->[2];
933 :     if ( ! $parent) { return undef }
934 :     my $vl;
935 :     if ($parent->[3]->[0] eq $node ) {
936 :     $vl = tot_tips_within_dist($parent->[3]->[1],
937 :     ($dist- ($node->[1]+ $parent->[3]->[1]->[1])), $list); }
938 :     else {
939 :     $vl = tot_tips_within_dist($parent->[3]->[0],
940 :     ($dist- ($node->[1]+ $parent->[3]->[0]->[1])), $list) ; }
941 :     push(@$list, @$vl);
942 :     tips_up_within_dist($parent, $dist - $node->[1], $list);
943 :     return $list;
944 :     }
945 :    
946 :     sub tot_tips_within_dist {
947 :     ($node, $dist1, $tot) = @_;
948 :     array_ref($node) || undef;
949 :     my ($child,$len);
950 :     $len = $dist1;
951 :     if ($len < 0 ) { return () }
952 :     if ( is_FIG_tip($node) ) {
953 :     if ($len >= 0 ) { return push(@$tot,$node->[0]); }
954 :     else { return (); }
955 :     }
956 :     foreach $child (@{$node->[3]}) {
957 :     tot_tips_within_dist($child,$len-$child->[1],$tot);
958 :     }
959 :     $tot? $tot : undef;
960 :     }
961 :    
962 :    
963 :     sub nodes_down_within_dist {
964 :     # collects non-tip nodes of tree rooted at $node that are within $dist
965 :     my ($node, $dist) = @_;
966 :     array_ref($node) && defined($dist) || undef;
967 :     tot_nodes_within_dist($node, $dist, []);
968 :     }
969 :    
970 :     sub nodes_up_within_dist {
971 :     # collects nodes of tree that end at this node and that are within $dist
972 :     my ($node, $dist, $list) = @_;
973 :     ! array_ref($node) ? return undef : 1;
974 :     $dist < 0 ? return undef : push(@$list,$node) ;
975 :     my $parent = $node->[2];
976 :     if ( ! $parent) { return }
977 :     my $vl;
978 :     if ($parent->[3]->[0] eq $node ) {
979 :     $vl = tot_nodes_within_dist($parent->[3]->[1],
980 :     ($dist- ($node->[1]+ $parent->[3]->[1]->[1])) ); }
981 :     else {
982 :     $vl = tot_nodes_within_dist($parent->[3]->[0],
983 :     ($dist- ($node->[1]+ $parent->[3]->[0]->[1])) ) ; }
984 :     push(@$list, @$vl);
985 :     nodes_up_within_dist($parent, $dist - $node->[1], $list);
986 :     return $list;
987 :     }
988 :    
989 :     sub tot_nodes_within_dist {
990 :     ($node, $dist, $tot) = @_;
991 :     if ($dist < 0 ) { return undef }
992 :     if ( is_FIG_root($node) ) { return push(@$tot, $node); }
993 :     if ( is_FIG_tip($node) ) { return (); }
994 :     push(@$tot, $node);
995 :     my ($child,$len);
996 :     $len = $dist;
997 :     foreach $child (@{$node->[3]}) {
998 :     if ( ($len >= $child->[1]) && (! is_FIG_tip($child)))
999 :     { push(@$tot, $child) }
1000 :     tot_nodes_within_dist($child,$len-$child->[1],$tot);
1001 :     }
1002 :     $tot ? $tot : undef ;
1003 :     }
1004 :    
1005 :     sub tips_down_within_steps {
1006 :     #
1007 :     my ($node, $steps) = @_;
1008 :     array_ref($node) && defined($steps) || undef;
1009 :     tot_tips_within_steps($node, $steps);
1010 :     }
1011 :    
1012 :     sub tips_up_within_steps {
1013 :     my ($node, $steps, $list) = @_;
1014 :     print "\ngetting tips up from node=$node steps left=$steps tips=$list";
1015 :     ! array_ref($node) ? return undef : 1;
1016 :     if ($steps < 0 ) { return undef }
1017 :     my $parent = $node->[2];
1018 :     if ( ! $parent) { return undef }
1019 :     my $vl;
1020 :     if ($parent->[3]->[0] eq $node ) {
1021 :     $vl = tot_tips_within_steps($parent->[3]->[1], ($steps-2), $list); }
1022 :     else {
1023 :     $vl = tot_tips_within_steps($parent->[3]->[0], ($steps-2), $list); }
1024 :     if (@$vl) { push(@$list, @$vl); }
1025 :     tips_up_within_steps($parent, --$steps, $list);
1026 :     return $list;
1027 :     }
1028 :    
1029 :     sub tot_tips_within_steps {
1030 :     ($node, $steps1, $tot) = @_;
1031 :     array_ref($node) || undef;
1032 :     print "\ntot_tips start: node=$node tot=$tot stepsleft=$steps1";
1033 :     my ($child,$len);
1034 :     $len = $steps1;
1035 :     if ($len < 0 ) { return (); }
1036 :     if ( is_FIG_tip($node) ) {
1037 :     $len >= 0 ? return push(@$tot,$node->[0]) : return ();
1038 :     }
1039 :     foreach $child (@{$node->[3]}) {
1040 :     tot_tips_within_steps($child,$len-1,$tot);
1041 :     }
1042 :     print "\ntot_tips end: node=$node tot=$tot stepsleft=$steps1";
1043 :     $tot? $tot : undef;
1044 :     }
1045 :    
1046 :     sub get_path_to_first_tip {
1047 :     ($node, $path) = @_;
1048 :     my $child;
1049 :     array_ref($node) || undef;
1050 :     push(@$path,$node);
1051 :     is_FIG_tip( $node ) ?
1052 :     return $path :
1053 :     return get_path_to_first_tip($node->[3]->[0],$path);
1054 :     }
1055 :    
1056 :     sub FIG_path_to_tip {
1057 :     my ($node, $tip, @path0) = @_;
1058 :     array_ref( $node ) && defined( $tip ) || return undef;
1059 :     push( @path0, $node);
1060 :     my $imax = get_FIG_numDesc($node);
1061 :     if ( $imax < 1 ) {
1062 :     return ( $node->[0] eq $tip ) ? @path0 : () }
1063 :     my @path;
1064 :     for (my $i = 1; $i <= $imax; $i++ ) {
1065 :     @path = FIG_path_to_tip( get_FIG_ith_desc($node, $i),$tip,@path0);
1066 :     if ( @path ) { return @path }
1067 :     }
1068 :    
1069 :     (); # Not found
1070 :     }
1071 :    
1072 :     sub FIG_path_to_root {
1073 :     # input could be noderef or tipname
1074 :     my ($tree, $node) = @_;
1075 :     array_ref($tree) || undef;
1076 :     array_ref($node) ? get_path_to_root($node,[]):
1077 :     reverse FIG_path_to_tip($tree, $node) ;
1078 :     }
1079 :    
1080 :     sub get_path_to_root {
1081 :     ($node, @path) = @_;
1082 :     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef; }
1083 :     push(@path, $node);
1084 :     if (!$node->[2]) { return @path; }
1085 :     else {
1086 :     get_path_to_root($node->[2],$path);
1087 :     }
1088 :     }
1089 :    
1090 :    
1091 :     sub FIG_path_to_node_ref {
1092 :     # it only works when noderef is in node's subtree
1093 :     my ($node, $noderef, @path0) = @_;
1094 :     push( @path0, $node);
1095 :     if ( $node eq $noderef ) { return @path0 }
1096 :    
1097 :     my @path;
1098 :     my $imax = get_FIG_numDesc($node);
1099 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1100 :     @path =
1101 :     FIG_path_to_node_ref( get_FIG_ith_desc($node, $i), $noderef,@path0);
1102 :     if ( @path ) { return @path }
1103 :     }
1104 :    
1105 :     (); # Not found
1106 :     }
1107 :    
1108 :     sub FIG_path_to_node {
1109 :     # node could be $tipname | [$tipname] | $t1 $t2 $t3
1110 :     my ($node, $tip1, $tip2, $tip3) = @_;
1111 :     print "\nargs node= $node t1= $tip1 t2= $tip2 t3= $tip3";
1112 :     array_ref( $node ) && defined( $tip1 ) || return ();
1113 :    
1114 :     # Allow arg 2 to be an array reference
1115 :     if ( array_ref( $tip1 ) ) { ( $tip1, $tip2, $tip3 ) = @$tip1 }
1116 :    
1117 :     my @p1 = FIG_path_to_tip($node, $tip1);
1118 :     @p1 || return ();
1119 :     print "\npatht1= @p1";
1120 :     defined( $tip2 ) && defined( $tip3 ) || return @p1;
1121 :    
1122 :     my @p2 = FIG_path_to_tip($node, $tip2);
1123 :     my @p3 = FIG_path_to_tip($node, $tip3);
1124 :    
1125 :     @p2 && @p3 || return ();
1126 :     print "\npatht2= @p2 patht3= @p3";
1127 :     # Find the common prefix for each pair of paths
1128 :     my @p12 = common_prefix( \@p1, \@p2 );
1129 :     my @p13 = common_prefix( \@p1, \@p3 );
1130 :     my @p23 = common_prefix( \@p2, \@p3 );
1131 :    
1132 :     # Return the longest common prefix of any two paths
1133 :     ( @p12 >= @p13 && @p12 >= @p23 ) ? @p12 :
1134 :     ( @p13 >= @p23 ) ? @p13 :
1135 :     @p23 ;
1136 :     }
1137 :    
1138 :     sub distance_along_path {
1139 :     # paths with format: [noderef1, noderef2,...]
1140 :     my $node = shift;
1141 :     array_ref( $node ) || return undef;
1142 :     my $d1 = get_FIG_X( $node );
1143 :     my $d2 = @_ ? distance_along_path(@_) : 0;
1144 :     defined($d1) && defined($d2) ? $d1 + $d2 : undef;
1145 :     }
1146 :    
1147 :     sub distance_along_path_2 {
1148 :     # paths with format: [descIndex1, nodeRef1, descRef2, nodeRef2,...]
1149 :     shift; # Discard descendant number
1150 :     my $node = shift;
1151 :     array_ref( $node ) || return undef;
1152 :     my $d1 = get_FIG_X( $node );
1153 :     my $d2 = @_ ? distance_along_path_2(@_) : 0;
1154 :     defined($d1) && defined($d2) ? $d1 + $d2 : undef;
1155 :     }
1156 :    
1157 :     sub most_distant_tip_path {
1158 :     my ($node, $notroot) = @_;
1159 :    
1160 :     my $imax = get_FIG_numDesc( $node );
1161 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
1162 :     my @pmax = ();
1163 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1164 :     my ($x, @path) = most_distant_tip_path(get_FIG_ith_desc($node, $i),1 );
1165 :     if ( $x > $xmax ) { $xmax = $x; @pmax = @path; }
1166 :     }
1167 :    
1168 :     my $x = $notroot ? get_FIG_X( $node ) : 0;
1169 :     $xmax += defined( $x ) ? $x : 0; # Convert undefined to 1
1170 :     ( $xmax, $node, @pmax );
1171 :     }
1172 :    
1173 :     sub most_distant_tip_ref {
1174 :     my ($node, $notroot) = @_;
1175 :    
1176 :     my $imax = get_FIG_numDesc( $node );
1177 :     my $xmax = ( $imax > 0 ) ? -1 : 0;
1178 :     my $tmax = $node;
1179 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1180 :     my ($t, $x) = most_distant_tip_ref(get_FIG_ith_desc($node, $i), 1 );
1181 :     if ( $x > $xmax ) { $xmax = $x; $tmax = $t }
1182 :     }
1183 :    
1184 :     my $x = $notroot ? get_FIG_X( $node ) : 0;
1185 :     $xmax += defined( $x ) ? $x : 0;
1186 :     ( $tmax, $xmax );
1187 :     }
1188 :    
1189 :     sub most_distant_tip_name {
1190 :     my ($tipref, $xmax) = most_distant_tip_ref( $_[0] );
1191 :     ( get_FIG_label( $tipref ), $xmax )
1192 :     }
1193 :    
1194 :    
1195 :     sub FIG_dist_tip_to_tip {
1196 :     my ($node, $tip1, $tip2) = @_;
1197 :    
1198 :     array_ref( $node ) && defined( $tip1 )
1199 :     && defined( $tip2 ) || return undef;
1200 :    
1201 :     my @p1 = FIG_path_to_tip($node, $tip1);
1202 :     my @p2 = FIG_path_to_tip($node, $tip2);
1203 :     @p1 && @p2 || return undef;
1204 :    
1205 :     # Find the unique suffixes of the two paths
1206 :     my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );
1207 :    
1208 :     my $d1 = @$suf1 ? distance_along_path( $suf1 ) : 0;
1209 :     my $d2 = @$suf2 ? distance_along_path( $suf2 ) : 0;
1210 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1211 :     }
1212 :    
1213 :     sub FIG_dist_node_to_node {
1214 :     # both node1 and node2 must be in node's subtree
1215 :     # node1 ,node2 could be= $tipname | [$tipname] | $t1 $t2 $t3
1216 :     my ($node, $node1, $node2) = @_;
1217 :    
1218 :     array_ref( $node ) && defined( $node1 )
1219 :     && defined( $node2 ) || return undef;
1220 :     my @p1 = FIG_path_to_node($node, $node1);
1221 :     my @p2 = FIG_path_to_node($node, $node2);
1222 :     @p1 && @p2 || return undef;
1223 :    
1224 :     # Find the unique suffixes of the two paths
1225 :     my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );
1226 :     my $d1 = @$suf1 ? distance_along_path( @$suf1 ) : 0;
1227 :     my $d2 = @$suf2 ? distance_along_path( @$suf2 ) : 0;
1228 :     defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1229 :     }
1230 :    
1231 :     sub get_FIG_context {
1232 :     # gets tips and nodes within $dist of current $node
1233 :     my($node,$dist) = @_;
1234 :     array_ref($node) && defined($n) || 0;
1235 :     my $tips = FIG_tips_within_dist($node, $dist);
1236 :     my $nodes = FIG_nodes_within_dist($node, $dist);
1237 :     return @$tips + @$nodes;
1238 :     }
1239 :    
1240 :     sub FIG_closest_common_ancestor {
1241 :     # finds common ancestor of up to three tips
1242 :     my ($tree, @tips) = @_;
1243 :     array_ref($tree) || return undef;
1244 :     (scalar @tips > 0) || return undef;
1245 :    
1246 :     my @paths;
1247 :     foreach $tip (@tips) {
1248 :     push( @paths, [ FIG_path_to_tip($tree,$tip) ]);
1249 :     }
1250 :     #simple cases first
1251 :     if (scalar @paths == 1)
1252 :     { my $p = @paths[0];
1253 :     return @$p; }
1254 :     if (scalar @paths == 2)
1255 :     { return common_prefix( @paths[0], @paths[1]) ; }
1256 :     if (scalar @paths == 3)
1257 :     {
1258 :     my @p12 = common_prefix( @paths[0], @paths[1]) ;
1259 :     my @p13 = common_prefix( @paths[0], @paths[2]) ;
1260 :     my @p23 = common_prefix( @paths[1], @paths[2]) ;
1261 :    
1262 :     # Return the shortest common prefix
1263 :     return common_prefix(\@p12,[common_prefix(\@p13,\@p23)]);
1264 :     }
1265 :     # more than three tips. Not processed here
1266 :     undef;
1267 :     }
1268 :    
1269 :    
1270 :     #==================================================================
1271 :     # Tree manipulations
1272 :     # Note: most funtions in this section will alter the tree
1273 :     #==================================================================
1274 :     sub FIG_copy_tree {
1275 :     # creates a copy of the subtree rooted at $node
1276 :     my ($node, $parent) = @_;
1277 :     array_ref( $node ) || return undef;
1278 :     my ( $label, $X, $p, $FIG_desc_list, $node_attrib, $branch_attrib )
1279 :     = @$node;
1280 :    
1281 :     # copying hashes
1282 :     my $nattrib_ref = [];
1283 :     my $battrib_ref = [];
1284 :    
1285 :     my ( $key, $val);
1286 :     if ( hash_ref( $node_attrib ) ) {
1287 :     @$nattrib_ref = map {
1288 :     $key = $_;
1289 :     $val = $node_attrib->{$key};
1290 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val" ;
1291 :     } keys %$node_attrib;
1292 :     }
1293 :     if ( hash_ref( $branch_attrib ) ) {
1294 :     push( @$battrib_ref, map {
1295 :     $key = $_;
1296 :     $val = $branch_attrib->{$key};
1297 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val";
1298 :     } keys %$branch_attrib );
1299 :     }
1300 :    
1301 :     # creating fig node
1302 :     my $nfig=[ $label,$X,$parent,undef,$nattrib_ref,$battrib_ref];
1303 :    
1304 :     # doing the same for each child in descendants list
1305 :     if ( $FIG_desc_list && @$FIG_desc_list ) {
1306 :     my $desc_ref = [ map {FIG_copy_tree( $_, $nfig )} @$FIG_desc_list ];
1307 :     foreach ( @$desc_ref[ 1 .. @$desc_ref-1 ] ) {
1308 :     ( ref( $_ ) eq "ARRAY" ) || return undef
1309 :     }
1310 :     $nfig->[3] = $desc_ref;
1311 :     }
1312 :     else {
1313 :     $nfig->[3] = [ ];
1314 :     }
1315 :    
1316 :     $nfig;
1317 :     }
1318 :    
1319 :     sub FIG_build_tree_from_subtrees {
1320 :     # creates a root node and appends the trees to its descList
1321 :     my($tree1,$tree2, $label, $x) = @_;
1322 :     array_ref($tree1) && array_ref($tree2) || undef;
1323 :     my $nfig = [$label,$x, undef, undef,[],[]];
1324 :     $tree1->[2] = $nfig;
1325 :     $tree2->[2] = $nfig;
1326 :     $nfig->[3]->[0]= $tree1;
1327 :     $nfig->[3]->[1]= $tree2;
1328 :     return $nfig;
1329 :     }
1330 :    
1331 :     sub FIG_reverse_tree {
1332 :     # reverses order of tree [in place]
1333 :     my ($node) = @_;
1334 :    
1335 :     my $imax = get_FIG_numDesc( $node );
1336 :     if ( $imax > 0 ) {
1337 :     set_FIG_descList( $node, reverse get_FIG_descList( $node ) );
1338 :     for ( my $i = 1; $i <= $imax; $i++ ) {
1339 :     FIG_reverse_tree( get_FIG_ith_desc( $node, $i ) );
1340 :     }
1341 :     }
1342 :     $node;
1343 :     }
1344 :    
1345 :     sub FIG_top_tree {
1346 :     # creates a copy of a tree, then truncates all subtrees so all branches
1347 :     # will have lengths no larger than $depth
1348 :     my ($tree, $depth) = @_;
1349 :     array_ref($tree) && defined($depth) || undef;
1350 :     my $newtree = FIG_copy_tree($tree);
1351 :     FIG_chop_tree($newtree, $depth);
1352 :     }
1353 :    
1354 :     sub FIG_chop_tree {
1355 :     # chops branches [i.e. tip and/or complete subtrees]
1356 :     # of tree rooted at $node; resulting branch-lengths are <= $depth
1357 :     my ($node,$depth) = @_;
1358 :     array_ref($node) && defined($depth) || undef;
1359 :     my $sz = FIG_tree_length($node);
1360 :     if ($sz <= $depth)
1361 :     { print "\n nothing to chop depth > treeLength";
1362 :     return undef; }
1363 :     #my $root = get_FIG_root($node);
1364 :     chop_tree($node, $node, $depth);
1365 :     }
1366 :    
1367 :     sub chop_tree {
1368 :     # chops entire sections of the tree rooted at $node
1369 :     # whose branch-lengths are larger than $depth
1370 :     ($tree, $node,$depth) = @_;
1371 :     array_ref($node) && array_ref($root) && defined($depth)|| undef;
1372 :     my ($child, $len);
1373 :     $len = $depth;
1374 :     if ($len < 0)
1375 :     {
1376 :     #need to chop at this point.
1377 :     is_FIG_tip($node) ? return FIG_prune_tip($tree, $node) :
1378 :     return FIG_prune_node($tree, $node);
1379 :     }
1380 :     foreach $child (@{$node->[3]}) {
1381 :     chop_tree($tree, $child, $len-$child->[1]);
1382 :     }
1383 :     }
1384 :    
1385 :     sub FIG_representative_tree {
1386 :     # thins the tree off of small tips until tree is of specified size
1387 :     my ($tree, $size) = @_;
1388 :     array_ref($tree) && defined($size) || undef;
1389 :     my @tips = collect_all_tips( $tree );
1390 :     my @sortedtips = sort by_distance @tips;
1391 :     my $to_remove = @tips - $size;
1392 :     if ($to_remove <= 0) { return $tree }
1393 :     while ($to_remove > 0)
1394 :     {
1395 :     my $tip = shift @sortedtips;
1396 :     FIG_prune_tip($tree,$tip);
1397 :     $to_remove--;
1398 :     }
1399 :     $tree;
1400 :     }
1401 :    
1402 :     sub collapse_FIG_tree {
1403 :     # searches entire tree rooted at $tree and collapses unneces. branches.
1404 :     # there are two cases:
1405 :     # node-tip -> tip collapse
1406 :     # node-node -> node collapse
1407 :     my ($tree) = @_;
1408 :     array_ref($tree) || undef;
1409 :     if ( is_FIG_tip($tree) ) { return; }
1410 :     if ( (! is_FIG_tip($tree) ) && ( get_FIG_numDesc($tree) == 1) )
1411 :     {
1412 :     is_FIG_tip($tree->[3]->[0]) ?
1413 :     FIG_collapse_node_tip($tree) :
1414 :     FIG_collapse_node_node($tree) ;
1415 :     }
1416 :     my $child;
1417 :     foreach $child (@{$tree->[3]}) {
1418 :     collapse_FIG_tree($child);
1419 :     }
1420 :     $tree;
1421 :     }
1422 :     sub FIG_collapse_node_tip {
1423 :     # $node has one descendant which is a tip
1424 :     # we collapse both node and tip into one [tip]
1425 :     my ($node) = @_;
1426 :     array_ref($node) || undef;
1427 :     my $child = $node->[3];
1428 :     if (scalar @$child > 1) { #stop. more than one child
1429 :     return undef; }
1430 :     my $tip = shift @$child;
1431 :     is_FIG_tip($tip) || undef;
1432 :    
1433 :     # collapsing tip and node into one tip";
1434 :     $node->[0] = join($node->[0],$tip->[0]);
1435 :     $node->[1] += $tip->[1];
1436 :     $node->[3] = [];
1437 :     add_FIG_node_attrib($node, $tip->[4]);
1438 :     add_FIG_branch_attrib($node, $tip->[5]);
1439 :    
1440 :     $node;
1441 :     }
1442 :    
1443 :     sub FIG_collapse_node_node {
1444 :     # $node has one descendant which is NOT a tip
1445 :     # we collapse both nodes into one [node]
1446 :     my ($node) = @_;
1447 :     array_ref($node1) || undef;
1448 :    
1449 :     my $child = $node->[3];
1450 :     if (scalar @$child > 1) { return undef; }
1451 :     my $child = shift @$child;
1452 :     if (is_FIG_tip($child) ) { return FIG_collapse_node_tip($node) }
1453 :    
1454 :     # collapsing two nodes into one
1455 :     $node->[0] = join($node->[0],$child->[0]);
1456 :     $node->[1] += $child->[1];
1457 :     $node->[3] = $child->[3];
1458 :     add_FIG_node_attrib($node,$child->[4]);
1459 :     add_FIG_branch_attrib($node,$child->[5]);
1460 :    
1461 :     $node;
1462 :     }
1463 :    
1464 :     sub FIG_prune_tip {
1465 :     # tip node is deleted, then tree is normalized w/ local operations
1466 :     # input could be tipref or tipname
1467 :     my ($tree, $tip1) = @_;
1468 :     array_ref($tree) && defined($tip1) || undef;
1469 :     if (! array_ref($tip1) )
1470 :     { # arg 2 is a tipname; we need a tipref
1471 :     $tip1 = get_FIG_tipref($tree,$tip1);
1472 :     }
1473 :     is_FIG_tip($tip1) || undef;
1474 :     my $parent = $tip1->[2];
1475 :     array_ref($parent) || undef;
1476 :     my $tips = $parent->[3];
1477 :     my $tip2;
1478 :     if ( (@$tips == 3) || (@$tips == 1) )
1479 :     {
1480 :     # just delete tip from the parent's descList
1481 :     delete_FIG_descRef($parent,$tip1);
1482 :     }
1483 :     elsif (@$tips == 2)
1484 :     {
1485 :     # need to collapse tip2 and tip1's parent into one
1486 :     $tip2 = ($tips->[0] eq $tip1) ? $tips->[1] : $tips->[0];
1487 :     $parent->[0] = join($parent->[0],$tip2->[0]);
1488 :     $parent->[1] += $tip2->[1];
1489 :     $parent->[3] = [];
1490 :     add_FIG_node_attrib($parent, $tip2->[4]);
1491 :     add_FIG_branch_attrib($parent, $tip2->[5]);
1492 :     }
1493 :     else {return undef }
1494 :     $parent;
1495 :     }
1496 :    
1497 :    
1498 :     sub FIG_prune_node {
1499 :     # entire subtree rooted at $node1 is deleted,
1500 :     # resulting $tree is normalized with local operations
1501 :     my ($tree, $node1) = @_;
1502 :     is_FIG_node($node1) || undef;
1503 :     if (is_FIG_root($node1)) { return uproot_FIG($node1) }
1504 :     my $parent = $node1->[2];
1505 :     my $grandp = $parent->[2];
1506 :     my $children = $parent->[3];
1507 :     my $node2;
1508 :     if ( ! $grandp)
1509 :     { # close to root; just delete it from parent's desc list
1510 :     delete_FIG_descRef($parent,$node1);
1511 :     return $parent;
1512 :     }
1513 :     if (@$children == 2)
1514 :     { # need to collapse parent and sibling into one";
1515 :     $node2 = ($children->[0] eq $node1) ?
1516 :     $children->[1] : $children->[0];
1517 :     $node2->[0] = join($node2->[0],$parent->[0]);
1518 :     $node2->[1] += $parent->[1];
1519 :     $node2->[2] = $grandp;
1520 :     add_FIG_node_attrib($node2,$parent->[4]);
1521 :     add_FIG_branch_attrib($node2,$parent->[5]);
1522 :     delete_FIG_descRef($grandp,$parent);
1523 :     add_FIG_desc($grandp,$node2);
1524 :     }
1525 :     else {return undef }
1526 :     $node2;
1527 :     }
1528 :    
1529 :     sub normalize_FIG_tree {
1530 :     my ($node) = @_;
1531 :    
1532 :     my @descends = get_FIG_descList( $node );
1533 :     if ( @descends == 0 ) { return ( $node, lc get_FIG_label( $node ) ) }
1534 :    
1535 :     my %hash = map { (normalize_FIG_tree( $_ ))[1] => $_ } @descends;
1536 :     my @keylist = sort { $a cmp $b } keys %hash;
1537 :     set_FIG_descList( $node, map { $hash{$_} } @keylist );
1538 :    
1539 :     ($node, $keylist[0]);
1540 :     }
1541 :    
1542 :     sub std_unrooted_FIG {
1543 :     my ($tree) = @_;
1544 :     my ($mintip) = sort { lc $a cmp lc $b } FIG_tips_of_tree( $tree );
1545 :     ( normalize_FIG_tree( reroot_next_to_tip( $tree, $mintip ) ) )[0];
1546 :     }
1547 :    
1548 :    
1549 :     sub build_tip_count_hash {
1550 :     my ($node, $cntref) = @_;
1551 :     my ($i, $imax, $cnt);
1552 :    
1553 :     $imax = get_FIG_numDesc($node);
1554 :     if ($imax < 1) { $cnt = 1 }
1555 :     else {
1556 :     $cnt = 0;
1557 :     for ( $i = 1; $i <= $imax; $i++ ) {
1558 :     $cnt += build_tip_count_hash(get_FIG_ith_desc($node, $i),$cntref );
1559 :     }
1560 :     }
1561 :    
1562 :     $cntref->{$node} = $cnt;
1563 :     $cnt;
1564 :     }
1565 :    
1566 :     sub FIG_random_order_tree {
1567 :     my ($node) = @_;
1568 :     my $nd = get_FIG_numDesc($node);
1569 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1570 :     # Reorder this subtree:
1571 :     my $dl_ref = get_FIG_descRef($node);
1572 :     @$dl_ref = random_order( @$dl_ref );
1573 :     # Reorder descendants:
1574 :     for ( my $i = 0; $i < $nd; $i++ ) {
1575 :     FIG_random_order_tree( $dl_ref->[$i] );
1576 :     }
1577 :     $node;
1578 :     }
1579 :    
1580 :     sub reorder_FIG_by_tip_count {
1581 :     my ($node, $cntref, $dir) = @_;
1582 :    
1583 :     my $nd = get_FIG_numDesc($node);
1584 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1585 :    
1586 :     # Reorder this subtree:
1587 :    
1588 :     my $dl_ref = get_FIG_descRef($node);
1589 :     if ( $dir < 0 ) { # Big group first
1590 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1591 :     }
1592 :     elsif ( $dir > 0 ) { # Small group first
1593 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1594 :     }
1595 :    
1596 :     # Reorder within descendant subtrees:
1597 :    
1598 :     my $step = 0;
1599 :     if (abs($dir) < 1e5) {
1600 :     $dir = 1 - $nd; # Midgroup => as is
1601 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1602 :     $step = 2;
1603 :     }
1604 :    
1605 :     for ( my $i = 0; $i < $nd; $i++ ) {
1606 :     reorder_FIG_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1607 :     $dir += $step;
1608 :     }
1609 :    
1610 :     $node;
1611 :     }
1612 :    
1613 :     sub reorder_FIG_against_tip_count {
1614 :     my ($node, $cntref, $dir) = @_;
1615 :    
1616 :     my $nd = get_FIG_numDesc($node);
1617 :     if ( $nd < 1 ) { return $node } # Do nothing to a tip
1618 :    
1619 :     # Reorder this subtree:
1620 :    
1621 :     my $dl_ref = get_FIG_descRef($node);
1622 :     if ( $dir > 0 ) { # Big group first
1623 :     @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1624 :     }
1625 :     elsif ( $dir < 0 ) { # Small group first
1626 :     @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;
1627 :     }
1628 :    
1629 :     # Reorder within descendant subtrees:
1630 :    
1631 :     my $step = 0;
1632 :     if (abs($dir) < 1e5) {
1633 :     $dir = 1 - $nd; # Midgroup => as is
1634 :     # $dir = 1 - $nd + ( $dir < 0 ? -0.5 : 0.5 ); # Midgroup => outward
1635 :     $step = 2;
1636 :     }
1637 :    
1638 :     for ( my $i = 0; $i < $nd; $i++ ) {
1639 :     reorder_FIG_by_tip_count( $dl_ref->[$i], $cntref, $dir );
1640 :     $dir += $step;
1641 :     }
1642 :    
1643 :     $node;
1644 :     }
1645 :    
1646 :     sub rearrange_FIG_smallest_out {
1647 :     my ($tree, $dir) = @_;
1648 :     my %cnt;
1649 :    
1650 :     $dir = ! $dir ? 0 : # Undefined or zero
1651 :     $dir <= -2 ? -1000000 :
1652 :     $dir < 0 ? -1 :
1653 :     $dir >= 2 ? 1000000 :
1654 :     1 ;
1655 :     build_tip_count_hash( $tree, \%cnt );
1656 :     reorder_FIG_against_tip_count( $tree, \%cnt, $dir );
1657 :     }
1658 :    
1659 :     sub rearrange_FIG_largest_out {
1660 :     my ($tree, $dir) = @_;
1661 :     my %cnt;
1662 :    
1663 :     $dir = ! $dir ? 0 : # Undefined or zero
1664 :     $dir <= -2 ? -1000000 :
1665 :     $dir < 0 ? -1 :
1666 :     $dir >= 2 ? 1000000 :
1667 :     1 ;
1668 :     build_tip_count_hash( $tree, \%cnt );
1669 :     reorder_FIG_by_tip_count( $tree, \%cnt, $dir );
1670 :     }
1671 :    
1672 :    
1673 :     sub reroot_FIG_by_path {
1674 :     my ($node1, @rest) = @_;
1675 :     array_ref( $node1 ) || return undef;
1676 :    
1677 :     @rest || return $node1;
1678 :    
1679 :     my $node2 = $rest[0];
1680 :     is_desc_of_FIGnode($node1, $node2) || return undef;
1681 :    
1682 :     #removing node2 from node1's descendant list
1683 :     my $dl1 = delete_elm( $node1->[3], $node2 );
1684 :     my $nd1 = @$dl1;
1685 :    
1686 :     # Append node 1 to node 2 descendant list (does not alter numbering):
1687 :     my $dl2 = get_FIG_descRef( $node2 );
1688 :     if ( array_ref($dl2) ) { push (@$dl2, $node1 )}
1689 :     else { set_FIG_descList( $node2, [ $node1 ] ) }
1690 :    
1691 :     # Move c1 comments from node 1 to node 2:
1692 :    
1693 :     my $C11 = $node1->[4]->{ "Newick_C1" };
1694 :     my $C12 = $node2->[4]->{ "Newick_C1" };
1695 :     ! defined( $C11 ) || set_FIG_node_attrib( $node1,( 'Newick_C1' =>undef ));
1696 :     if ( $C12 && @$C12 ) {
1697 :     if ( $C11 && @$C11 ) { unshift @$C12, @$C11 }
1698 :     }
1699 :     elsif ( $C11 && @$C11 ) {set_FIG_node_attrib($node2,('Newick_C1'=>$C11))}
1700 :    
1701 :     # Swap branch lengths and comments for reversal of link direction:
1702 :    
1703 :     my $x1 = get_FIG_X( $node1 );
1704 :     my $x2 = get_FIG_X( $node2 );
1705 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_FIG_X( $node1, $x2 );
1706 :     ! defined( $x1 ) && ! defined ( $x2 ) || set_FIG_X( $node2, $x1 );
1707 :    
1708 :     my $c41 = $node1->[5]->{ "Newick_C4" };
1709 :     my $c42 = $node2->[5]->{ "Newick_C4" };
1710 :     ! defined( $c42 ) || ! @$c42 ||
1711 :     set_FIG_branch_attrib($node1,('Newick_C4'=>$c42)) ;
1712 :     ! defined( $c41 ) || ! @$c41 ||
1713 :     set_FIG_branch_attrib($node2,('Newick_C4'=>$c41)) ;
1714 :    
1715 :    
1716 :     my $c51 = $node1->[5]->{ "Newick_C5" };
1717 :     my $c52 = $node2->[5]->{ "Newick_C5" };
1718 :     ! defined( $c52 ) || ! @$c52 ||
1719 :     set_FIG_branch_attrib($node1,('Newick_C5'=>$c52)) ;
1720 :    
1721 :     ! defined( $c51 ) || ! @$c51 ||
1722 :     set_FIG_branch_attrib($node2,('Newick_C5'=>$c51)) ;
1723 :    
1724 :     reroot_FIG_by_path( @rest );
1725 :     }
1726 :    
1727 :     sub reroot_FIG_to_tip {
1728 :     my ($tree, $tipname) = @_;
1729 :     my @path = FIG_path_to_tip( $tree, $tipname );
1730 :     reroot_FIG_by_path(@path);
1731 :     }
1732 :     sub reroot_FIG_next_to_tip {
1733 :     my ($tree, $tipname) = @_;
1734 :     my @path = FIG_path_to_tip( $tree, $tipname );
1735 :     @path || return undef;
1736 :     @path == 1 ? reroot_FIG_by_path( $tree, 1,get_FIG_ith_desc( $tree, 1 ) )
1737 :     : reroot_FIG_by_path( @path[0 .. @path-3] );
1738 :     }
1739 :     sub reroot_FIG_to_node {
1740 :     reroot_FIG_by_path( FIG_path_to_node( @_ ) );
1741 :     }
1742 :     sub reroot_FIG_to_node_ref {
1743 :     my ($tree, $node) = @_;
1744 :     reroot_FIG_by_path( FIG_path_to_node_ref( $tree, $node ) );
1745 :     }
1746 :    
1747 :     sub uproot_tip_to_node {
1748 :     my ($node) = @_;
1749 :     is_FIG_tip_rooted( $node ) || return $node;
1750 :    
1751 :     # Path to the sole descendant:
1752 :     reroot_FIG_by_path( $node, 1, get_FIG_ith_desc( $node, 1 ) );
1753 :     }
1754 :    
1755 :     sub uproot_FIG {
1756 :     # removes bifurcating tree
1757 :     my ($node0) = @_;
1758 :     is_FIG_rooted( $node0 ) || return $node0;
1759 :    
1760 :     my $node1 = get_FIG_ith_desc( $node0, 1 );
1761 :     my $node2 = get_FIG_ith_desc( $node0, 2 );
1762 :    
1763 :     # Ensure that node1 has at least 1 descendant
1764 :     if (get_FIG_numDesc($node1) ) { }
1765 :     elsif (get_FIG_numDesc($node2) ) { ($node1,$node2) = ($node2, $node1) }
1766 :     else { die "uproot_FIG requires more that 2 taxa\n" }
1767 :    
1768 :     push(@{ get_FIG_descRef($node1) }, $node2);
1769 :    
1770 :     # Prefix node1 branch to that of node2:
1771 :    
1772 :     add_FIG_branch_attrib($node2,get_FIG_branch_attrib($node1));
1773 :     set_FIG_X($node2, $node2->[1]+$node1->[1]);
1774 :    
1775 :     set_FIG_X($node1, undef);
1776 :     set_FIG_branch_attrib($node1, undef);
1777 :    
1778 :    
1779 :     # Tree prefix comment lists (as references):
1780 :     my $C10 = $node0->[4]->{ "Newick_C1" };
1781 :     my $C11 = $node1->[4]->{ "Newick_C1" };
1782 :    
1783 :     if ( $C11 && @$C11 ) {
1784 :     if ( $C10 && @$C10 ) { unshift @$C11, @$C10 }
1785 :     }
1786 :     else { set_FIG_node_attrib($node1,('Newick_C1'=>$C10)) }
1787 :     set_FIG_node_attrib($node0,('Newick_C1'=>undef));
1788 :    
1789 :     $node1;
1790 :     }
1791 :    
1792 :    
1793 :     #------------------------------------------------------------------
1794 :     # I/O [parse/print] functions
1795 :     #------------------------------------------------------------------
1796 :    
1797 :     sub FIG_print_node_attrib {
1798 :     my ($FIG_node) = @_;
1799 :     my ( $label, $X, $parent, $FIG_desc_list, $node_attrib, $branch_attrib )
1800 :     = @$FIG_node;
1801 :     my ($key, $val);
1802 :     if ( hash_ref( $node_attrib ) ) {
1803 :     while ($key = each %$node_attrib)
1804 :     {
1805 :     $val = $node_attrib->{$key};
1806 :     if (@$val > 0) { print "$key: "; map {print "$_, " } @$val;}
1807 :     else { print "$key: ",$val ; }
1808 :     }
1809 :     }
1810 :     }
1811 :    
1812 :     sub FIG_print_branch_attrib {
1813 :     my ($FIG_node) = @_;
1814 :     my ( $label, $X, $parent, $FIG_desc_list, $node_attrib, $branch_attrib )
1815 :     = @$FIG_node;
1816 :     my ($key, $val);
1817 :     if ( hash_ref( $branch_attrib ) ) {
1818 :     while ($key = each %$branch_attrib)
1819 :     {
1820 :     $val = $branch_attrib->{$key};
1821 :     if (@$val > 0) { print "$key: "; map {print "$_, " } @$val;}
1822 :     else { print "$key: ",$val ; }
1823 :     }
1824 :     }
1825 :    
1826 :     }
1827 :    
1828 :     sub print_attrib_hash {
1829 :     my ($hash) = @_;
1830 :     my ($key, $val);
1831 :     if ( hash_ref( $hash ) ) {
1832 :     while ($key = each %$hash)
1833 :     {
1834 :     $val = $hash->{$key};
1835 :     @$val > 1 ? print "$key: ",@$val : print "$key: ",$val ;
1836 :     }
1837 :     }
1838 :     else { print "\nnot a hash table" }
1839 :     }
1840 :    
1841 :     sub FIG_print_node {
1842 :     my ($FIG_node) = @_;
1843 :     my ( $label, $X, $parent, $FIG_desc_list, $node_attrib, $branch_attrib )
1844 :     = @$FIG_node;
1845 :     my $child;
1846 :     print "\nnode info= \n";
1847 :     print "ref : $FIG_node lbl: $label len: $X par: $parent ";
1848 :     print " node?: ", &is_FIG_node($FIG_node);
1849 :     print " leaf?: ", &is_FIG_tip($FIG_node);
1850 :     print "\nnumChildren: ", &get_FIG_numDesc($FIG_node);
1851 :     print " childrenRefs: @$FIG_desc_list ";
1852 :     print "\nnAtt: $node_attrib len = ",&get_FIG_num_node_attrib;
1853 :     print " key:vals= "; print FIG_print_node_attrib($FIG_node);
1854 :     print "\nbAtt: $branch_attrib len =", &get_FIG_num_branch_attrib;
1855 :     print " key:vals= "; print FIG_print_branch_attrib($FIG_node);
1856 :     }
1857 :    
1858 :     sub FIG_print_tree {
1859 :     my ($FIG_node) = @_;
1860 :     my $child;
1861 :     &FIG_print_node($FIG_node);
1862 :     foreach $child (@{$FIG_node->[3]}) { &FIG_print_tree($child); }
1863 :     }
1864 :    
1865 :     sub write_FIG_to_Newick {
1866 :     # writes to file the FIG tree in Newick format
1867 :     my ($figtree) = @_;
1868 :     open $fh, ">newickOut";
1869 :     writeNewickTree( FIGtree_to_newick($figtree), $fh );
1870 :     close $fh;
1871 :     }
1872 :    
1873 :     sub read_FIG_from_str {
1874 :     # reads a string and creates a fig tree with it
1875 :     my ($string) = @_;
1876 :     my $newick = parse_newick_tree_str( $string );
1877 :     my $fig = newick_to_FIGtree( $newick );
1878 :     $fig;
1879 :     }
1880 :    
1881 :     sub layout_FIG_tree {
1882 :     my ($fignode) = @_;
1883 :     layout_tree( FIGtree_to_newick($fignode) );
1884 :     }
1885 :    
1886 :     #=========================================================================
1887 :     # Interconverting Overbeek tree and FIG_tree:
1888 :     #=========================================================================
1889 :     # overbeek_to_FIGtree
1890 :     #-------------------------------------------------------------------------
1891 :     sub overbeek_to_FIGtree {
1892 :     my ( $ro_node, $parent ) = @_;
1893 :     ( ref( $ro_node ) eq "ARRAY" ) && ( @$ro_node ) || return undef;
1894 :    
1895 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = undef );
1896 :    
1897 :     my ( $label, $X, $ro_desc_list, $ro_attrib_list ) = @$ro_node;
1898 :     ( array_ref($ro_desc_list) && ( @$ro_desc_list ) ) || return undef;
1899 :    
1900 :     # Process the node attribute list key value pairs. Newick comments are
1901 :     # special case in that they always go in a list, not a standalone value.
1902 :     # Comments 4 and 5 are branch properties in a FIGtree.
1903 :    
1904 :     my $n_attrib_ref = undef;
1905 :     my $b_attrib_ref = undef;
1906 :    
1907 :     if ( ref( $ro_attrib_list ) eq "ARRAY" ) {
1908 :     my %n_attribs = ();
1909 :     my %b_attribs = ();
1910 :     my ( $key, $val );
1911 :    
1912 :     foreach ( @$ro_attrib_list ) {
1913 :     if ( $_ =~ /^([^\t]+)\t(.*)$/ ) {
1914 :     ( $key, $val ) = ( $1, $2 );
1915 :     if ( $key =~ /^Newick_C[1-3]$/ ) {
1916 :     if ( $n_attribs{ $key } ) { push @{ $n_attribs{ $key } }, $val }
1917 :     else { $n_attribs{ $key } = [ $val ] }
1918 :     }
1919 :     elsif ( $key =~ /^Newick_C[45]$/ ) {
1920 :     if ( $b_attribs{ $key } ) { push @{ $b_attribs{ $key } }, $val }
1921 :     else { $b_attribs{ $key } = [ $val ] }
1922 :     }
1923 :     else {
1924 :     $n_attribs{ $key } = $val;
1925 :     }
1926 :     }
1927 :     }
1928 :     if ( %n_attribs ) { $n_attrib_ref = \%n_attribs }
1929 :     if ( %b_attribs ) { $b_attrib_ref = \%b_attribs }
1930 :     }
1931 :    
1932 :     # We need to create the FIGtree node reference before we can create the
1933 :     # children:
1934 :    
1935 :     my $FIG_node = [ $label,
1936 :     $X,
1937 :     $parent,
1938 :     undef,
1939 :     $b_attrib_ref ? ( $n_attrib_ref, $b_attrib_ref )
1940 :     : $n_attrib_ref ? ( $n_attrib_ref )
1941 :     : ()
1942 :     ];
1943 :    
1944 :     # Build the descendent list, and check that all child nodes are defined:
1945 :    
1946 :     if ( @$ro_desc_list > 1 ) {
1947 :     my $desc_ref = [ map { overbeek_to_FIGtree( $_, $FIG_node )
1948 :     } @$ro_desc_list[ 1 .. @$ro_desc_list-1 ]
1949 :     ];
1950 :     foreach ( @$desc_ref ) { ( ref( $_ ) eq "ARRAY" ) || return undef }
1951 :     $FIG_node->[3] = $desc_ref;
1952 :     }
1953 :    
1954 :     $FIG_node;
1955 :     }
1956 :    
1957 :    
1958 :     #-------------------------------------------------------------------------
1959 :     # FIGtree_to_overbeek
1960 :     #-------------------------------------------------------------------------
1961 :    
1962 :     sub FIGtree_to_overbeek {
1963 :     my ( $FIG_node, $parent ) = @_;
1964 :     ( ref( $FIG_node ) eq "ARRAY" ) && ( @$FIG_node ) || return undef;
1965 :    
1966 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = 0 );
1967 :    
1968 :     my ( $label, $X, undef, $FIG_desc_list, $node_attrib, $branch_attrib ) = @$FIG_node;
1969 :     ( ! $FIG_desc_list ) || ( ref( $FIG_desc_list ) eq "ARRAY" ) || return undef;
1970 :    
1971 :     # Build attribute key-value pairs. Expand lists into multiple
1972 :     # instances of same key:
1973 :    
1974 :     my $attrib_ref = [];
1975 :     my ( $key, $val);
1976 :     if ( ref( $node_attrib ) eq "HASH" ) {
1977 :     @$attrib_ref = map {
1978 :     $key = $_;
1979 :     $val = $node_attrib->{$key};
1980 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val"
1981 :     } keys %$node_attrib;
1982 :     }
1983 :     if ( ref( $branch_attrib ) eq "HASH" ) {
1984 :     push( @$attrib_ref, map {
1985 :     $key = $_;
1986 :     $val = $branch_attrib->{$key};
1987 :     ref( $val ) eq "ARRAY" ? map { "$key\t$_" } @$val : "$_\t$val"
1988 :     } keys %$branch_attrib);
1989 :     }
1990 :    
1991 :     # Create the Overbeek node so that we have parent reference for the
1992 :     # children:
1993 :    
1994 :     my $ro_node = [ $label, $X, undef, $attrib_ref ];
1995 :    
1996 :     # Build the descendent list, with the parent node as the first element:
1997 :    
1998 :     if ( $FIG_desc_list && @$FIG_desc_list ) {
1999 :     my $desc_ref = [ $parent,
2000 :     map { FIGtree_to_overbeek( $_, $ro_node ) } @$FIG_desc_list
2001 :     ];
2002 :     foreach ( @$desc_ref[ 1 .. @$desc_ref-1 ] ) {
2003 :     ( ref( $_ ) eq "ARRAY" ) || return undef
2004 :     }
2005 :     $ro_node->[2] = $desc_ref;
2006 :     }
2007 :     else {
2008 :     $ro_node->[2] = [ $parent ];
2009 :     }
2010 :    
2011 :     $ro_node;
2012 :     }
2013 :    
2014 :    
2015 :     #=========================================================================
2016 :     # Parent node references in FIG trees and Overbeek trees.
2017 :     #
2018 :     # Both FIG trees and Overbeek trees include a reference back to the
2019 :     # parent node. We should condsider it it is worth routinely maintaining
2020 :     # these values (creating them as the tree is created), or wether to fill
2021 :     # them in only when needed (which will be very fast).
2022 :     #
2023 :     # The following two routines add/update the values in an existing tree.
2024 :     #=========================================================================
2025 :     # fill_FIGtree_parents
2026 :     #-------------------------------------------------------------------------
2027 :    
2028 :     sub fill_FIGtree_parents {
2029 :     my ( $FIG_node, $parent ) = @_;
2030 :     ( ref( $FIG_node ) eq "ARRAY" ) && ( @$FIG_node ) || return undef;
2031 :    
2032 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = undef );
2033 :     $FIG_node->[2] = $parent;
2034 :    
2035 :     # Work through the descendent list:
2036 :    
2037 :     my $desc_list = $FIG_node->[3];
2038 :     if ( ref( $desc_list ) eq "ARRAY" ) {
2039 :     foreach ( @$desc_list ) {
2040 :     fill_FIGtree_parents( $_, $FIG_node ) || return undef;
2041 :     }
2042 :     }
2043 :    
2044 :     $FIG_node;
2045 :     }
2046 :    
2047 :    
2048 :     #-------------------------------------------------------------------------
2049 :     # fill_overbeek_parents
2050 :     #-------------------------------------------------------------------------
2051 :    
2052 :     sub fill_overbeek_parents {
2053 :     my ( $ro_node, $parent ) = @_;
2054 :     ( ref( $ro_node ) eq "ARRAY" ) && ( @$ro_node ) || return undef;
2055 :    
2056 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = 0 );
2057 :    
2058 :     my $desc_list = $ro_node->[2];
2059 :     if ( ! $desc_list ) {
2060 :     $ro_node->[2] = [ $parent ];
2061 :     }
2062 :     else {
2063 :     ( ref( $desc_list ) eq "ARRAY" ) || return undef;
2064 :     $desc_list->[0] = $parent;
2065 :    
2066 :     # Work through the rest of the descendent list:
2067 :    
2068 :     my $last_index = @$desc_list - 1;
2069 :     foreach ( @$desc_list[ 1 .. $last_index ] ) {
2070 :     fill_overbeek_parents( $_, $ro_node ) || return undef;
2071 :     }
2072 :     }
2073 :    
2074 :     $ro_node;
2075 :     }
2076 :    
2077 :    
2078 :     #=========================================================================
2079 :     # Interconverting Newick tree and FIG_tree:
2080 :     #=========================================================================
2081 :     # newick_to_FIGtree
2082 :     #-------------------------------------------------------------------------
2083 :    
2084 :     sub newick_to_FIGtree {
2085 :     my ( $newick_node, $parent ) = @_;
2086 :     ( ref( $newick_node ) eq "ARRAY" ) && ( @$newick_node ) || return undef;
2087 :    
2088 :     ( ref( $parent ) eq "ARRAY" ) || ( $parent = undef );
2089 :    
2090 :     my ( $desc_list, $label, $X, $c1, $c2, $c3, $c4, $c5 ) = @$newick_node;
2091 :    
2092 :     # Put C1, C2 and C3 values in the node attribute list, with the key
2093 :     # "Newick_CN". Check C1 comments for "FIG_tree_node_attribute"
2094 :     # values. These are pulled out of the Newick comment and are made
2095 :     # into node key-value pairs.
2096 :    
2097 :     my $node_attrib = undef;
2098 :     if ( $c1 || $c2 || $c3 ) {
2099 :     $node_attrib = {};
2100 :     if ( $c1 ) {
2101 :     ( ref( $c1 ) eq "ARRAY" ) || return undef;
2102 :     my @c1b = ();
2103 :     foreach ( @$c1 ) {
2104 :     if ( ( ref( $_ ) eq "ARRAY" )
2105 :     && ( $_->[0] eq "FIG_tree_node_attribute" )
2106 :     ) {
2107 :     $node_attrib->{ $_->[1] } = $_->[2];
2108 :     }
2109 :     else {
2110 :     push @c1b, $_;
2111 :     }
2112 :     }
2113 :     if ( @c1b ) {
2114 :     $node_attrib->{ "Newick_C1" } = ( @$c1 == @c1b ) ? $c1 : \@c1b;
2115 :     }
2116 :     }
2117 :     if ( $c2 ) { $node_attrib->{ "Newick_C2" } = $c2 }
2118 :     if ( $c3 ) { $node_attrib->{ "Newick_C3" } = $c3 }
2119 :     }
2120 :    
2121 :     # Put C4 and C5 values in the branch attribute list, with the key
2122 :     # "Newick_CN". Check C4 comments for "FIG_tree_branch_attribute"
2123 :     # values. These are pulled out of the Newick comment and are made
2124 :     # into branch key-value pairs.
2125 :    
2126 :     my $branch_attrib = undef;
2127 :     if ( $c4 || $c5 ) {
2128 :     $branch_attrib = {};
2129 :     if ( $c4 ) {
2130 :     ( ref( $c4 ) eq "ARRAY" ) || return undef;
2131 :     my @c4b = ();
2132 :     foreach ( @$c4 ) {
2133 :     if ( ( ref( $_ ) eq "ARRAY" )
2134 :     && ( $_->[0] eq "FIG_tree_branch_attribute" )
2135 :     ) {
2136 :     $branch_attrib->{ $_->[1] } = $_->[2];
2137 :     }
2138 :     else {
2139 :     push @c4b, $_;
2140 :     }
2141 :     }
2142 :     if ( @c4b ) {
2143 :     $branch_attrib->{ "Newick_C4" } = ( @$c4 == @c4b ) ? $c4 : \@c4b;
2144 :     }
2145 :     }
2146 :     if ( $c5 ) { $branch_attrib->{ "Newick_C5" } = $c5 }
2147 :     }
2148 :    
2149 :     # We need a FIG node reference before we can create the children
2150 :    
2151 :     my $FIG_node = [ $label,
2152 :     $X,
2153 :     $parent,
2154 :     undef,
2155 :     ( $node_attrib || $branch_attrib ? $node_attrib : () ),
2156 :     ( $branch_attrib ? $branch_attrib : () )
2157 :     ];
2158 :    
2159 :     # Make the descendent list and check that all the children are defined:
2160 :    
2161 :     if ( $desc_list ) {
2162 :     ( ref( $desc_list ) eq "ARRAY" ) || return undef;
2163 :     if ( @$desc_list ) {
2164 :     my $FIG_desc_ref = [ map { newick_to_FIGtree( $_, $FIG_node ) }
2165 :     @$desc_list
2166 :     ];
2167 :     foreach ( @$FIG_desc_ref ) { ( ref( $_ ) eq "ARRAY" ) || return undef }
2168 :     $FIG_node->[3] = $FIG_desc_ref;
2169 :     }
2170 :     }
2171 :    
2172 :     $FIG_node;
2173 :     }
2174 :    
2175 :    
2176 :     #-------------------------------------------------------------------------
2177 :     # FIGtree_to_newick
2178 :     #-------------------------------------------------------------------------
2179 :    
2180 :     sub FIGtree_to_newick {
2181 :     my ( $FIG_node ) = @_;
2182 :     ( ref( $FIG_node ) eq "ARRAY" ) && ( @$FIG_node ) || return undef;
2183 :    
2184 :     my ( $label, $X, undef, $FIG_desc_list, $node_attrib, $branch_attrib ) = @$FIG_node;
2185 :     ( ! $FIG_desc_list ) || ( ref( $FIG_desc_list ) eq "ARRAY" ) || return undef;
2186 :    
2187 :     my ( $c1, $c2, $c3, $c4, $c5 );
2188 :     if ( ref( $node_attrib ) eq "HASH" ) {
2189 :     if ( $node_attrib->{ "Newick_C1" } ) {
2190 :     $c1 = $node_attrib->{ "Newick_C1" };
2191 :     ! defined( $c1 ) || ( ref( $c1 ) eq "ARRAY" ) || ( $c1 = [ $c1 ] );
2192 :     }
2193 :     if ( $node_attrib->{ "Newick_C2" } ) {
2194 :     $c2 = $node_attrib->{ "Newick_C2" };
2195 :     ! defined( $c2 ) || ( ref( $c2 ) eq "ARRAY" ) || ( $c2 = [ $c2 ] );
2196 :     }
2197 :     if ( $node_attrib->{ "Newick_C3" } ) {
2198 :     $c3 = $node_attrib->{ "Newick_C3" };
2199 :     ! defined( $c3 ) || ( ref( $c3 ) eq "ARRAY" ) || ( $c3 = [ $c3 ] );
2200 :     }
2201 :     if ( $node_attrib->{ "Newick_C4" } ) {
2202 :     $c4 = $node_attrib->{ "Newick_C4" };
2203 :     ! defined( $c4 ) || ( ref( $c4 ) eq "ARRAY" ) || ( $c4 = [ $c4 ] );
2204 :     }
2205 :     if ( $node_attrib->{ "Newick_C5" } ) {
2206 :     $c5 = $node_attrib->{ "Newick_C5" };
2207 :     ! defined( $c5 ) || ( ref( $c5 ) eq "ARRAY" ) || ( $c5 = [ $c5 ] );
2208 :     }
2209 :    
2210 :     # Any node attributes that are not newick comments, will get
2211 :     # pushed on C1 as 3-element lists with first element eq
2212 :     # "FIG_tree_node_attribute"
2213 :    
2214 :     my @keys = map { /^Newick_C[1-5]$/ ? () : $_ } keys %$node_attrib;
2215 :     if ( @keys ) {
2216 :     my @c1b = $c1 ? @$c1 : ();
2217 :     push @c1b, map { [ "FIG_tree_node_attribute", $_, $node_attrib->{ $_ } ]
2218 :     } @keys;
2219 :     $c1 = \@c1b;
2220 :     }
2221 :     }
2222 :    
2223 :     if ( ref( $branch_attrib ) eq "HASH" ) {
2224 :     if ( $branch_attrib->{ "Newick_C4" } ) {
2225 :     $c4 = $branch_attrib->{ "Newick_C4" };
2226 :     ! defined( $c4 ) || ( ref( $c4 ) eq "ARRAY" ) || ( $c4 = [ $c4 ] );
2227 :     }
2228 :     if ( $branch_attrib->{ "Newick_C5" } ) {
2229 :     $c5 = $branch_attrib->{ "Newick_C5" };
2230 :     ! defined( $c5 ) || ( ref( $c5 ) eq "ARRAY" ) || ( $c5 = [ $c5 ] );
2231 :     }
2232 :    
2233 :     # Any branch attributes that are not newick comments, will get
2234 :     # pushed on C4 as 3-element lists with first element eq
2235 :     # "FIG_tree_branch_attribute"
2236 :    
2237 :     my @keys = map { /^Newick_C[45]$/ ? () : $_ } keys %$branch_attrib;
2238 :     if ( @keys ) {
2239 :     my @c4b = $c4 ? @$c4 : ();
2240 :     push @c4b, map { [ "FIG_tree_branch_attribute", $_, $branch_attrib->{ $_ } ]
2241 :     } @keys;
2242 :     $c4 = \@c4b;
2243 :     }
2244 :     }
2245 :    
2246 :     my $desc_ref = undef;
2247 :     if ( $FIG_desc_list && @$FIG_desc_list ) {
2248 :     $desc_ref = [ map { FIGtree_to_newick( $_ ) } @$FIG_desc_list ];
2249 :     foreach ( @$desc_ref ) { array_ref( $_ ) || return undef }
2250 :     }
2251 :    
2252 :     [ $desc_ref, $label, $X, $c5 ? ( $c1, $c2, $c3, $c4, $c5 )
2253 :     : $c4 ? ( $c1, $c2, $c3, $c4 )
2254 :     : $c3 ? ( $c1, $c2, $c3 )
2255 :     : $c2 ? ( $c1, $c2 )
2256 :     : $c1 ? ( $c1 )
2257 :     : ()
2258 :     ];
2259 :     }
2260 :    
2261 :    
2262 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3