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

Diff of /FigKernelPackages/gjonewicklib.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9, Sun Feb 11 18:55:44 2007 UTC revision 1.15, Sun Sep 6 22:38:32 2009 UTC
# Line 203  Line 203 
203  #  $n_changed = newick_set_all_branches( $node, $x )  #  $n_changed = newick_set_all_branches( $node, $x )
204  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
205  #  $node      = newick_rescale_branches( $node, $factor )  #  $node      = newick_rescale_branches( $node, $factor )
206    #  $node      = newick_modify_branches( $node, \&function )
207    #  $node      = newick_modify_branches( $node, \&function, \@func_parms )
208  #  #
209  #  Modify comments:  #  Modify comments:
210  #  #
# Line 221  Line 223 
223  #  $newtree = reroot_newick_to_node( $tree, @node )  #  $newtree = reroot_newick_to_node( $tree, @node )
224  #  $newtree = reroot_newick_to_node_ref( $tree, $noderef )  #  $newtree = reroot_newick_to_node_ref( $tree, $noderef )
225  #  $newtree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )  #  $newtree = reroot_newick_between_nodes( $tree, $node1, $node2, $fraction )
226    #  $newtree = reroot_newick_to_midpoint( $tree )           # unweighted
227    #  $newtree = reroot_newick_to_midpoint_w( $tree )         # weight by tips
228  #  $newtree = reroot_newick_to_approx_midpoint( $tree )    # unweighted  #  $newtree = reroot_newick_to_approx_midpoint( $tree )    # unweighted
229  #  $newtree = reroot_newick_to_approx_midpoint_w( $tree )  # weight by tips  #  $newtree = reroot_newick_to_approx_midpoint_w( $tree )  # weight by tips
230  #  $newtree = uproot_tip_rooted_newick( $tree )  #  $newtree = uproot_tip_rooted_newick( $tree )
231  #  $newtree = uproot_newick( $tree )  #  $newtree = uproot_newick( $tree )
232  #  #
233  #  $newtree = prune_from_newick( $tree, $tip )  #  $newtree = prune_from_newick( $tree, $tip )
234    #  $newtree = rooted_newick_subtree( $tree,  @tips )
235    #  $newtree = rooted_newick_subtree( $tree, \@tips )
236  #  $newtree = newick_subtree( $tree,  @tips )  #  $newtree = newick_subtree( $tree,  @tips )
237  #  $newtree = newick_subtree( $tree, \@tips )  #  $newtree = newick_subtree( $tree, \@tips )
238    #  $newtree = newick_covering_subtree( $tree,  @tips )
239    #  $newtree = newick_covering_subtree( $tree, \@tips )
240  #  #
241  #  $newtree = collapse_zero_length_branches( $tree )  #  $newtree = collapse_zero_length_branches( $tree )
242  #  #
# Line 339  Line 347 
347          newick_set_all_branches          newick_set_all_branches
348          newick_fix_negative_branches          newick_fix_negative_branches
349          newick_rescale_branches          newick_rescale_branches
350            newick_modify_branches
351    
352          newick_strip_comments          newick_strip_comments
353    
# Line 355  Line 364 
364          reroot_newick_to_node          reroot_newick_to_node
365          reroot_newick_to_node_ref          reroot_newick_to_node_ref
366          reroot_newick_between_nodes          reroot_newick_between_nodes
367            reroot_newick_to_midpoint
368            reroot_newick_to_midpoint_w
369          reroot_newick_to_approx_midpoint          reroot_newick_to_approx_midpoint
370          reroot_newick_to_approx_midpoint_w          reroot_newick_to_approx_midpoint_w
371          uproot_tip_rooted_newick          uproot_tip_rooted_newick
372          uproot_newick          uproot_newick
373    
374          prune_from_newick          prune_from_newick
375            rooted_newick_subtree
376          newick_subtree          newick_subtree
377            newick_covering_subtree
378          collapse_zero_length_branches          collapse_zero_length_branches
379    
380          newick_insert_at_node          newick_insert_at_node
# Line 473  Line 486 
486  #  #
487  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
488    
489  sub newick_desc_ref { $_[0]->[0] }  # = ${$_[0]}[0]  sub newick_desc_ref { ref($_[0]) ? $_[0]->[0] : Carp::confess() }  # = ${$_[0]}[0]
490  sub newick_lbl      { ref($_[0]) ? $_[0]->[1] : Carp::confess() }  sub newick_lbl      { ref($_[0]) ? $_[0]->[1] : Carp::confess() }
491  sub newick_x        { $_[0]->[2] }  sub newick_x        { ref($_[0]) ? $_[0]->[2] : Carp::confess() }
492  sub newick_c1       { $_[0]->[3] }  sub newick_c1       { ref($_[0]) ? $_[0]->[3] : Carp::confess() }
493  sub newick_c2       { $_[0]->[4] }  sub newick_c2       { ref($_[0]) ? $_[0]->[4] : Carp::confess() }
494  sub newick_c3       { $_[0]->[5] }  sub newick_c3       { ref($_[0]) ? $_[0]->[5] : Carp::confess() }
495  sub newick_c4       { $_[0]->[6] }  sub newick_c4       { ref($_[0]) ? $_[0]->[6] : Carp::confess() }
496  sub newick_c5       { $_[0]->[7] }  sub newick_c5       { ref($_[0]) ? $_[0]->[7] : Carp::confess() }
497    
498  sub newick_desc_list {  sub newick_desc_list {
499      my $node = $_[0];      my $node = $_[0];
# Line 1165  Line 1178 
1178      my $imax = newick_n_desc( $node );      my $imax = newick_n_desc( $node );
1179      for ( my $i = 1; $i <= $imax; $i++ ) {      for ( my $i = 1; $i <= $imax; $i++ ) {
1180         @path = path_to_node_ref( newick_desc_i( $node, $i ), $noderef, ( @path0, $i ) );         @path = path_to_node_ref( newick_desc_i( $node, $i ), $noderef, ( @path0, $i ) );
1181         if ( @path ) { return @path }          return @path if @path;
1182      }      }
1183    
1184      ();  #  Not found      ();  #  Not found
# Line 1525  Line 1538 
1538    
1539    
1540  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1541    #  Modify all branch lengths by a function.
1542    #
1543    #     $node = newick_modify_branches( $node, \&function )
1544    #     $node = newick_modify_branches( $node, \&function, \@func_parms )
1545    #
1546    #  Function must have form
1547    #
1548    #     $x2 = &$function( $x1 )
1549    #     $x2 = &$function( $x1, @$func_parms )
1550    #
1551    #-------------------------------------------------------------------------------
1552    sub newick_modify_branches {
1553        my ( $node, $func, $parm ) = @_;
1554    
1555        set_newick_x( $node, &$func( newick_x( $node ), ( $parm ? @$parm : () ) ) );
1556        foreach ( newick_desc_list( $node ) )
1557        {
1558            newick_modify_branches( $_, $func, $parm )
1559        }
1560    
1561        $node;
1562    }
1563    
1564    
1565    #-------------------------------------------------------------------------------
1566  #  Set negative branches to zero.  The original tree is modfied.  #  Set negative branches to zero.  The original tree is modfied.
1567  #  #
1568  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
# Line 1921  Line 1959 
1959      my @path1 = path_to_node( $tree, $node1 ) or return undef;      my @path1 = path_to_node( $tree, $node1 ) or return undef;
1960      my @path2 = path_to_node( $tree, $node2 ) or return undef;      my @path2 = path_to_node( $tree, $node2 ) or return undef;
1961    
1962        reroot_newick_between_nodes_by_path( $tree, \@path1, \@path2, $fraction )
1963    }
1964    
1965    
1966    #-------------------------------------------------------------------------------
1967    #  Reroot a newick tree along the path between 2 nodes:
1968    #
1969    #  $tree = reroot_newick_between_node_refs( $tree, $node1, $node2, $fraction )
1970    #-------------------------------------------------------------------------------
1971    sub reroot_newick_between_node_refs
1972    {
1973        my ( $tree, $node1, $node2, $fraction ) = @_;
1974        array_ref( $tree ) or return undef;
1975    
1976        #  Find the paths to the nodes:
1977    
1978        my @path1 = path_to_node_ref( $tree, $node1 ) or return undef;
1979        my @path2 = path_to_node_ref( $tree, $node2 ) or return undef;;
1980    
1981        reroot_newick_between_nodes_by_path( $tree, \@path1, \@path2, $fraction )
1982    }
1983    
1984    
1985    #-------------------------------------------------------------------------------
1986    #  Reroot a newick tree along the path between 2 nodes defined by paths:
1987    #
1988    #  $tree = reroot_newick_between_nodes_by_path( $tree, $path1, $path2, $fraction )
1989    #-------------------------------------------------------------------------------
1990    sub reroot_newick_between_nodes_by_path
1991    {
1992        my ( $tree, $path1, $path2, $fraction ) = @_;
1993        array_ref( $tree ) and array_ref( $path1 ) and  array_ref( $path2 )
1994           or return undef;
1995        $fraction >= 0 && $fraction <= 1 or return undef;
1996    
1997        my @path1 = @$path1;
1998        my @path2 = @$path2;
1999    
2000      #  Trim the common prefix, saving it:      #  Trim the common prefix, saving it:
2001    
2002      my @prefix = ();      my @prefix = ();
2003      while ( $path1[1] == $path2[1] )      while ( defined( $path1[1] ) && defined( $path2[1] ) && ( $path1[1] == $path2[1] ) )
2004      {      {
2005          push @prefix, splice( @path1, 0, 2 );          push @prefix, splice( @path1, 0, 2 );
2006          splice( @path2, 0, 2 );          splice( @path2, 0, 2 );
# Line 1984  Line 2060 
2060    
2061      my $dists1 = average_to_tips_1( $tree );      my $dists1 = average_to_tips_1( $tree );
2062    
2063      #  Compile average tip to node distances descending, returning midpoint node      #  Compile average tip to node distances descending, returning midpoint
2064        #  cadidates as a list of [ $node1, $node2, $fraction ]
2065    
2066        my @mids = average_to_tips_2( $dists1, undef, undef );
2067    
2068        #  Reroot to first midpoint candidate
2069    
2070        return $tree if ! @mids;
2071        my ( $node1, $node2, $fraction ) = @{ $mids[0] };
2072        reroot_newick_to_node_ref( $tree, $fraction >= 0.5 ? $node2 : $node1 );
2073    }
2074    
2075    
2076      my $node = average_to_tips_2( $dists1, undef, undef );  #-------------------------------------------------------------------------------
2077    #  Move root of tree to a midpoint.
2078    #
2079    #  $newtree = reroot_newick_to_midpoint( $tree )
2080    #-------------------------------------------------------------------------------
2081    sub reroot_newick_to_midpoint {
2082        my ( $tree ) = @_;
2083    
2084      #  Reroot      #  Compile average tip to node distances assending
2085    
2086      $node ? reroot_newick_to_node_ref( $tree, $node ) : $tree      my $dists1 = average_to_tips_1( $tree );
2087    
2088        #  Compile average tip to node distances descending, returning midpoint
2089        #  [ $node1, $node2, $fraction ]
2090    
2091        my @mids = average_to_tips_2( $dists1, undef, undef );
2092    
2093        @mids ? reroot_newick_between_node_refs( $tree, @{ $mids[0] } ) : $tree;
2094  }  }
2095    
2096    
2097    #-------------------------------------------------------------------------------
2098    #  Compile average tip to node distances assending
2099    #-------------------------------------------------------------------------------
2100  sub average_to_tips_1 {  sub average_to_tips_1 {
2101      my ( $node ) = @_;      my ( $node ) = @_;
2102    
# Line 2004  Line 2107 
2107          foreach ( @desc_dists ) { $x_below += $_->[0] }          foreach ( @desc_dists ) { $x_below += $_->[0] }
2108          $x_below /= @desc_dists;          $x_below /= @desc_dists;
2109      }      }
2110    
2111      my $x = newick_x( $node ) || 0;      my $x = newick_x( $node ) || 0;
2112      my $x_net = $x_below + $x;      my $x_net = $x_below + $x;
2113    
# Line 2011  Line 2115 
2115  }  }
2116    
2117    
2118    #-------------------------------------------------------------------------------
2119    #  Compile average tip to node distances descending, returning midpoint as
2120    #  [ $node1, $node2, $fraction_of_dist_between ]
2121    #-------------------------------------------------------------------------------
2122  sub average_to_tips_2 {  sub average_to_tips_2 {
2123      my ( $dists1, $x_above, $anc_node ) = @_;      my ( $dists1, $x_above, $anc_node ) = @_;
2124      my ( undef, $x, $x_below, $desc_list, $node ) = @$dists1;      my ( undef, $x, $x_below, $desc_list, $node ) = @$dists1;
2125    
2126      #  Are we done?  Root is in this node's branch, or "above"?      #  Are we done?  Root is in this node's branch, or "above"?
2127    
2128      # defined( $x_above ) and print STDERR "x_above = $x_above\n";      my @mids = ();
     # print STDERR "x       = $x\n";  
     # print STDERR "x_below = $x_below\n";  
     # print STDERR "n_desc  = ", scalar @$desc_list, "\n\n";  
   
2129      if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )      if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )
2130      {      {
2131          #  At this point the root can only be in this node's branch,          #  At this point the root can only be in this node's branch,
# Line 2033  Line 2137 
2137    
2138          if ( ( $x_below + $x ) >= $x_above )          if ( ( $x_below + $x ) >= $x_above )
2139          {          {
2140              return ( $x_above >= $x_below ) ? $anc_node : $node;              #  We will need to make a new node for the root, $fract of
2141          }              #  the way from $node to $anc_node:
2142          else              my $fract = ( $x > 0 ) ? 0.5 * ( ( $x_above - $x_below ) / $x + 1 )
2143          {                                     : 0.5;
2144              return undef;              push @mids, [ $node, $anc_node, $fract ];
2145          }          }
2146      }      }
2147    
2148      #  The root must be somewhere below this node:      #  The root might be somewhere below this node:
2149    
2150      my $n_1      =   @$desc_list - ( $anc_node ? 0 : 1 );      my $n_1      =   @$desc_list - ( $anc_node ? 0 : 1 );
2151      my $ttl_dist = ( @$desc_list * $x_below ) + ( defined( $x_above ) ? ( $x_above + $x ) : 0 );      my $ttl_dist = ( @$desc_list * $x_below ) + ( defined( $x_above ) ? ( $x_above + $x ) : 0 );
# Line 2051  Line 2155 
2155          #  If input tree is tip_rooted, $n-1 can be 0, so:          #  If input tree is tip_rooted, $n-1 can be 0, so:
2156    
2157          my $above2 = $n_1 ? ( ( $ttl_dist - $_->[0] ) / $n_1 ) : 0;          my $above2 = $n_1 ? ( ( $ttl_dist - $_->[0] ) / $n_1 ) : 0;
2158          my $root = average_to_tips_2( $_, $above2, $node );          push @mids, average_to_tips_2( $_, $above2, $node );
         if ( $root ) { return $root }  
2159      }      }
2160    
2161      #  Was not anywhere below this node (oh-oh):      return @mids;
   
     return undef;  
2162  }  }
2163    
2164    
# Line 2069  Line 2170 
2170  sub reroot_newick_to_approx_midpoint_w {  sub reroot_newick_to_approx_midpoint_w {
2171      my ( $tree ) = @_;      my ( $tree ) = @_;
2172    
2173        #  Compile average tip to node distances assending from tips
2174    
2175        my $dists1 = average_to_tips_1_w( $tree );
2176    
2177        #  Compile average tip to node distances descending, returning midpoints
2178    
2179        my @mids = average_to_tips_2_w( $dists1, undef, undef, undef );
2180    
2181        #  Reroot to first midpoint candidate
2182    
2183        return $tree if ! @mids;
2184        my ( $node1, $node2, $fraction ) = @{ $mids[0] };
2185        reroot_newick_to_node_ref( $tree, $fraction >= 0.5 ? $node2 : $node1 );
2186    }
2187    
2188    
2189    #-------------------------------------------------------------------------------
2190    #  Move root of tree to an approximate midpoint.  Weight by tips.
2191    #
2192    #  $newtree = reroot_newick_to_midpoint_w( $tree )
2193    #-------------------------------------------------------------------------------
2194    sub reroot_newick_to_midpoint_w {
2195        my ( $tree ) = @_;
2196    
2197      #  Compile average tip to node distances assending      #  Compile average tip to node distances assending
2198    
2199      my $dists1 = average_to_tips_1_w( $tree );      my $dists1 = average_to_tips_1_w( $tree );
2200    
2201      #  Compile average tip to node distances descending, returning midpoint node      #  Compile average tip to node distances descending, returning midpoint node
2202    
2203      my $node = average_to_tips_2_w( $dists1, undef, undef, undef );      my @mids = average_to_tips_2_w( $dists1, undef, undef, undef );
2204    
2205      #  Reroot      #  Reroot at first candidate midpoint
2206    
2207      $node ? reroot_newick_to_node_ref( $tree, $node ) : $tree      @mids ? reroot_newick_between_node_refs( $tree, @{ $mids[0] } ) : $tree;
2208  }  }
2209    
2210    
# Line 2100  Line 2225 
2225          }          }
2226          $x_below /= $n_below;          $x_below /= $n_below;
2227      }      }
2228    
2229      my $x = newick_x( $node ) || 0;      my $x = newick_x( $node ) || 0;
2230      my $x_net = $x_below + $x;      my $x_net = $x_below + $x;
2231    
# Line 2113  Line 2239 
2239    
2240      #  Are we done?  Root is in this node's branch, or "above"?      #  Are we done?  Root is in this node's branch, or "above"?
2241    
2242      # defined( $x_above ) and print STDERR "x_above = $x_above\n";      my @mids = ();
     # print STDERR "x       = $x\n";  
     # print STDERR "x_below = $x_below\n";  
     # print STDERR "n_desc  = ", scalar @$desc_list, "\n\n";  
   
2243      if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )      if ( defined( $x_above ) && ( ( $x_above + $x ) >= $x_below ) )
2244      {      {
2245          #  At this point the root can only be in this node's branch,          #  At this point the root can only be in this node's branch,
# Line 2125  Line 2247 
2247          #  would mean that the midpoint is actually down a different          #  would mean that the midpoint is actually down a different
2248          #  path from the root of the current tree).          #  path from the root of the current tree).
2249          #          #
2250          #  Is the root in the current branch?          #  Is their a root in the current branch?
2251    
2252          if ( ( $x_below + $x ) >= $x_above )          if ( ( $x_below + $x ) >= $x_above )
2253          {          {
2254              return ( $x_above >= $x_below ) ? $anc_node : $node;              #  We will need to make a new node for the root, $fract of
2255          }              #  the way from $node to $anc_node:
2256          else              my $fract = ( $x > 0 ) ? 0.5 * ( ( $x_above - $x_below ) / $x + 1 )
2257          {                                     : 0.5;
2258              return undef;              push @mids, [ $node, $anc_node, $fract ];
2259          }          }
2260      }      }
2261    
# Line 2153  Line 2275 
2275    
2276          my $x_above2 = $n_above2 ? ( ( $ttl_w_dist - $n_2 * $_->[0] ) / $n_above2 )          my $x_above2 = $n_above2 ? ( ( $ttl_w_dist - $n_2 * $_->[0] ) / $n_above2 )
2277                                   : 0;                                   : 0;
2278          my $root = average_to_tips_2_w( $_, $x_above2, $n_above2 || 1, $node );          push @mids, average_to_tips_2_w( $_, $x_above2, $n_above2 || 1, $node );
         if ( $root ) { return $root }  
2279      }      }
2280    
2281      #  Was not anywhere below this node (oh-oh):      return @mids;
   
     return undef;  
2282  }  }
2283    
2284    
# Line 2474  Line 2593 
2593    
2594    
2595  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2596    #  Produce a potentially rooted subtree with the desired tips:
2597    #
2598    #     Except for (some) tip nodes, the tree produced is a copy.
2599    #     There is no check that requested tips exist.
2600    #
2601    #  $newtree = rooted_newick_subtree( $tree,  @tips )
2602    #  $newtree = rooted_newick_subtree( $tree, \@tips )
2603    #-------------------------------------------------------------------------------
2604    sub rooted_newick_subtree {
2605        my ( $tr, @tips ) = @_;
2606        if ( @tips == 1 && ref( $tips[0] ) eq "ARRAY" ) { @tips = @{ $tips[0] } }
2607    
2608        if ( @tips < 2 ) { return undef }
2609        my $keephash = { map { ( $_, 1 ) } @tips };
2610        my $tr2 = subtree1( $tr, $keephash );
2611        $tr2->[2] = undef if $tr2;                   # undef root branch length
2612        $tr2;
2613    }
2614    
2615    
2616    #-------------------------------------------------------------------------------
2617  #  Produce a subtree with the desired tips:  #  Produce a subtree with the desired tips:
2618  #  #
2619  #     Except for (some) tip nodes, the tree produced is a copy.  #     Except for (some) tip nodes, the tree produced is a copy.
# Line 2547  Line 2687 
2687  }  }
2688    
2689    
2690    #-------------------------------------------------------------------------------
2691    #  The smallest subtree of rooted tree that includes @tips:
2692    #
2693    #    $node = newick_covering_subtree( $tree,  @tips )
2694    #    $node = newick_covering_subtree( $tree, \@tips )
2695    #-------------------------------------------------------------------------------
2696    
2697    sub newick_covering_subtree {
2698        my $tree = shift;
2699        my %tips = map { $_ => 1 } ( ( ref( $_[0] ) eq 'ARRAY' ) ? @{ $_[0] } : @_ );
2700    
2701        #  Return smallest covering node, if any:
2702    
2703        ( newick_covering_subtree( $tree, \%tips ) )[ 0 ];
2704    }
2705    
2706    
2707    sub newick_covering_subtree_1 {
2708        my ( $node, $tips ) = @_;
2709        my $n_cover = 0;
2710        my @desc = newick_desc_list( $node );
2711        if ( @desc )
2712        {
2713            foreach ( @desc )
2714            {
2715                my ( $subtree, $n ) = newick_covering_subtree_1( $_, $tips );
2716                return ( $subtree, $n ) if $subtree;
2717                $n_cover += $n;
2718            }
2719        }
2720        elsif ( $tips->{ newick_lbl( $node ) } )
2721        {
2722            $n_cover++;
2723        }
2724    
2725        #  If all tips are covered, return node
2726    
2727        ( $n_cover == keys %$tips ) ? ( $node, $n_cover ) : ( undef, $n_cover );
2728    }
2729    
2730    
2731  #===============================================================================  #===============================================================================
2732  #  #
2733  #  Representative subtrees  #  Representative subtrees
# Line 3127  Line 3308 
3308      #  Loop while it is a comment:      #  Loop while it is a comment:
3309      while ( substr( $s, $ind, 1 ) eq "[" ) {      while ( substr( $s, $ind, 1 ) eq "[" ) {
3310          $ind++;          $ind++;
3311            my $depth = 1;
3312            my $ind2  = $ind;
3313    
3314          #  Find end          #  Find end
3315          if ( substr( $s, $ind ) !~ /^([^]]*)\]/ ) {          while ( $depth > 0 )
3316            {
3317                if ( substr( $s, $ind2 ) =~ /^([^][]*\[)/ )     # nested [ ... ]
3318                {
3319                    $ind2 += length( $1 );  #  Points at char just past [
3320                    $depth++;               #  If nested comments are allowed
3321                }
3322                elsif ( substr( $s, $ind2 ) =~ /^([^][]*\])/ )  # close bracket
3323                {
3324                    $ind2 += length( $1 );  #  Points at char just past ]
3325                    $depth--;
3326                }
3327                else
3328                {
3329              treeParseError( "comment missing closing bracket '["              treeParseError( "comment missing closing bracket '["
3330                             . substr( $s, $ind ) . "'" )                             . substr( $s, $ind ) . "'" )
3331          }          }
3332          my $comment = $1;          }
3333    
3334          #  Save if it includes any "text"          my $comment = substr( $s, $ind, $ind2-$ind-1 );
3335          if ( $comment =~ m/\S/ ) { push @clist, $comment }          if ( $comment =~ m/\S/ ) { push @clist, $comment }
3336    
3337          $ind += length( $comment ) + 1;     #  Comment plus closing bracket          $ind = $ind2;
3338    
3339          #  Skip white space          #  Skip white space
3340          if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }          if ( substr( $s, $ind ) =~ /^(\s+)/ ) { $ind += length( $1 ) }
# Line 3157  Line 3353 
3353  #===============================================================================  #===============================================================================
3354  #  Make a printer plot of a tree:  #  Make a printer plot of a tree:
3355  #  #
3356  #     $node   newick tree root node  #  printer_plot_newick( $node, $file, $width, $min_dx, $dy )
3357  #     $file   undef (= \*STDOUT), \*STDOUT, \*STDERR, or a file name.  #  printer_plot_newick( $node, $file, \%options )
3358  #     $width  the approximate characters for the tree without labels  #
3359  #     $min_dx the minimum horizontal branch length  #     $node   # newick tree root node
3360  #     $dy     the vertical space per taxon  #     $file   # undef = \*STDOUT, \*FH, or a file name.
3361    #     $width  # the approximate characters for the tree without labels (D = 68)
3362    #     $min_dx # the minimum horizontal branch length (D = 2)
3363    #     $dy     # the vertical space per taxon (D = 1, most compressed)
3364    #
3365    #  Options:
3366    #
3367    #    dy     => nat_number    # the vertical space per taxon
3368    #    chars  => key           # line drawing character set:
3369    #                            #     html_unicode
3370    #                            #     text (default)
3371    #    min_dx => whole_number  # the minimum horizontal branch length
3372    #    width  => whole_number  # approximate tree width without labels
3373  #  #
 #  printer_plot_newick( $node, $file (D=\*STDOUT), $width (D=68), $min_dx (D=2), $dy (D=1) )  
3374  #===============================================================================  #===============================================================================
3375  sub printer_plot_newick {  sub printer_plot_newick
3376      my ( $node, $file, $width, $min_dx, $dy ) = @_;  {
3377        my ( $node, $file, @opts ) = @_;
3378    
3379      my ( $fh, $close ) = open_output( $file );      my ( $fh, $close ) = open_output( $file );
3380      $fh or return;      $fh or return;
3381    
3382      print $fh join( "\n", text_plot_newick( $node, $width, $min_dx, $dy ) ), "\n";      my $html = $opts[0] && ref($opts[0]) eq 'HASH'
3383                            && $opts[0]->{ chars }
3384                            && $opts[0]->{ chars } =~ /html/;
3385        print $fh '<PRE>' if $html;
3386        print $fh join( "\n", text_plot_newick( $node, @opts ) ), "\n";
3387        print $fh "</PRE>\n" if $html;
3388    
3389      if ( $close ) { close $fh }      if ( $close ) { close $fh }
3390  }  }
3391    
3392    
3393  #===============================================================================  #===============================================================================
3394    #  Character sets for printer plot trees:
3395    #-------------------------------------------------------------------------------
3396    
3397    my %char_set =
3398      ( text1     => { space  => ' ',
3399                       horiz  => '-',
3400                       vert   => '|',
3401                       el_d_r => '/',
3402                       el_u_r => '\\',
3403                       el_d_l => '\\',
3404                       el_u_l => '/',
3405                       tee_l  => '+',
3406                       tee_r  => '+',
3407                       tee_u  => '+',
3408                       tee_d  => '+',
3409                       half_l => '-',
3410                       half_r => '-',
3411                       half_u => '|',
3412                       half_d => '|',
3413                       cross  => '+',
3414                     },
3415        text2     => { space  => ' ',
3416                       horiz  => '-',
3417                       vert   => '|',
3418                       el_d_r => '+',
3419                       el_u_r => '+',
3420                       el_d_l => '+',
3421                       el_u_l => '+',
3422                       tee_l  => '+',
3423                       tee_r  => '+',
3424                       tee_u  => '+',
3425                       tee_d  => '+',
3426                       half_l => '-',
3427                       half_r => '-',
3428                       half_u => '|',
3429                       half_d => '|',
3430                       cross  => '+',
3431                     },
3432        html_box  => { space  => '&nbsp;',
3433                       horiz  => '&#9472;',
3434                       vert   => '&#9474;',
3435                       el_d_r => '&#9484;',
3436                       el_u_r => '&#9492;',
3437                       el_d_l => '&#9488;',
3438                       el_u_l => '&#9496;',
3439                       tee_l  => '&#9508;',
3440                       tee_r  => '&#9500;',
3441                       tee_u  => '&#9524;',
3442                       tee_d  => '&#9516;',
3443                       half_l => '&#9588;',
3444                       half_r => '&#9590;',
3445                       half_u => '&#9589;',
3446                       half_d => '&#9591;',
3447                       cross  => '&#9532;',
3448                     },
3449        utf8_box  => { space  => ' ',
3450                       horiz  => chr(226) . chr(148) . chr(128),
3451                       vert   => chr(226) . chr(148) . chr(130),
3452                       el_d_r => chr(226) . chr(148) . chr(140),
3453                       el_u_r => chr(226) . chr(148) . chr(148),
3454                       el_d_l => chr(226) . chr(148) . chr(144),
3455                       el_u_l => chr(226) . chr(148) . chr(152),
3456                       tee_l  => chr(226) . chr(148) . chr(164),
3457                       tee_r  => chr(226) . chr(148) . chr(156),
3458                       tee_u  => chr(226) . chr(148) . chr(180),
3459                       tee_d  => chr(226) . chr(148) . chr(172),
3460                       half_l => chr(226) . chr(149) . chr(180),
3461                       half_r => chr(226) . chr(149) . chr(182),
3462                       half_u => chr(226) . chr(149) . chr(181),
3463                       half_d => chr(226) . chr(149) . chr(183),
3464                       cross  => chr(226) . chr(148) . chr(188),
3465                     },
3466      );
3467    
3468    %{ $char_set{ html1 } } = %{ $char_set{ text1 } };
3469    $char_set{ html1 }->{ space } = '&nbsp;';
3470    
3471    %{ $char_set{ html2 } } = %{ $char_set{ text2 } };
3472    $char_set{ html2 }->{ space } = '&nbsp;';
3473    
3474    #  Define some synonyms
3475    
3476    $char_set{ html } = $char_set{ html_box };
3477    $char_set{ line } = $char_set{ utf8_box };
3478    $char_set{ symb } = $char_set{ utf8_box };
3479    $char_set{ text } = $char_set{ text1 };
3480    $char_set{ utf8 } = $char_set{ utf8_box };
3481    
3482    #  Define tree formats and synonyms
3483    
3484    my %tree_format =
3485        ( text         => 'text',
3486          tree_tab_lbl => 'tree_tab_lbl',
3487          tree_lbl     => 'tree_lbl',
3488          chrlist_lbl  => 'chrlist_lbl',
3489          raw          => 'chrlist_lbl',
3490        );
3491    
3492    #===============================================================================
3493  #  Make a text plot of a tree:  #  Make a text plot of a tree:
3494  #  #
3495  #     $node   newick tree root node  #  @lines = text_plot_newick( $node, $width, $min_dx, $dy )
3496  #     $width  the approximate characters for the tree without labels  #  @lines = text_plot_newick( $node, \%options )
3497  #     $min_dx the minimum horizontal branch length  #
3498  #     $dy     the vertical space per taxon  #     $node   # newick tree root node
3499    #     $width  # the approximate characters for the tree without labels (D = 68)
3500    #     $min_dx # the minimum horizontal branch length (D = 2)
3501    #     $dy     # the vertical space per taxon (D = 1, most compressed)
3502    #
3503    #  Options:
3504    #
3505    #    chars  => keyword       # the output character set for the tree
3506    #    dy     => nat_number    # the vertical space per taxon
3507    #    format => keyword       # output format of each line
3508    #    min_dx => whole_number  # the minimum horizontal branch length
3509    #    width  => whole_number  # approximate tree width without labels
3510    #
3511    #  Character sets:
3512    #
3513    #    html       #  synonym of html1
3514    #    html_box   #  html encoding of unicode box drawing characters
3515    #    html1      #  text1 with nonbreaking spaces
3516    #    html2      #  text2 with nonbreaking spaces
3517    #    line       #  synonym of utf8_box
3518    #    raw        #  pass out the internal representation
3519    #    symb       #  synonym of utf8_box
3520    #    text       #  synonym of text1 (Default)
3521    #    text1      #  ascii characters: - + | / \ and space
3522    #    text2      #  ascii characters: - + | + + and space
3523    #    utf8       #  synonym of utf8_box
3524    #    utf8_box   #  utf8 encoding of unicode box drawing characters
3525    #
3526    #  Formats for row lines:
3527    #
3528    #    text           #    $textstring              # Default
3529    #    tree_tab_lbl   #    $treestr \t $labelstr
3530    #    tree_lbl       # [  $treestr,  $labelstr ]
3531    #    chrlist_lbl    # [ \@treechar, $labelstr ]   # Forced with raw chars
3532    #    raw            #  synonym of chrlist_lbl
3533  #  #
 #  @textlines = text_plot_newick( $node, $width (D=68), $min_dx (D=2), $dy (D=1) )  
3534  #===============================================================================  #===============================================================================
3535  sub text_plot_newick {  sub text_plot_newick
3536      my ( $node, $width, $min_dx, $dy ) = @_;  {
3537        my $node = shift @_;
3538      array_ref( $node ) || die "Bad node passed to text_plot_newick\n";      array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
3539      defined( $min_dx ) and ( $min_dx >=  0 ) or $min_dx =  2;  
3540      defined(     $dy ) and (     $dy >=  1 ) or     $dy =  1;      my ( $opts, $width, $min_dx, $dy, $chars, $fmt );
3541      defined( $width  )                       or  $width = 68;      if ( $_[0] && ref $_[0] eq 'HASH' )
3542        {
3543            $opts = shift;
3544        }
3545        else
3546        {
3547            ( $width, $min_dx, $dy ) = @_;
3548            $opts = {};
3549        }
3550    
3551        $chars = $opts->{ chars } || '';
3552        my $charH;
3553        $charH = $char_set{ $chars } || $char_set{ 'text1' } if ( $chars ne 'raw' );
3554        my $is_box = $charH eq $char_set{ html_box }
3555                  || $charH eq $char_set{ utf8_box }
3556                  || $chars eq 'raw';
3557    
3558        $fmt = ( $chars eq 'raw' ) ? 'chrlist_lbl' : $opts->{ format };
3559        $fmt = $tree_format{ $fmt || '' } || 'text';
3560    
3561        $dy    ||= $opts->{ dy     } ||  1;
3562        $width ||= $opts->{ width  } || 68;
3563        $min_dx  = $opts->{ min_dx } if ( ! defined $min_dx || $min_dx < 0 );
3564        $min_dx  = $is_box ? 1 : 2   if ( ! defined $min_dx || $min_dx < 0 );
3565    
3566        #  Layout the tree:
3567    
3568      $min_dx = int( $min_dx );      $min_dx = int( $min_dx );
3569      $dy     = int( $dy );      $dy     = int( $dy );
# Line 3200  Line 3572 
3572      my $hash = {};      my $hash = {};
3573      layout_printer_plot( $node, $hash, 0, -0.5 * $dy, $x_scale, $min_dx, $dy );      layout_printer_plot( $node, $hash, 0, -0.5 * $dy, $x_scale, $min_dx, $dy );
3574    
3575      # dump_tree_hash( $node, $hash ); exit;      #  Generate the lines of the tree-one by-one:
   
     #  Generate the lines of the tree one by one:  
3576    
3577      my ( $y1, $y2 ) = @{ $hash->{ $node } };      my ( $y1, $y2 ) = @{ $hash->{ $node } };
3578      map { text_tree_row( $node, $hash, $_, "", "+" ) } ( $y1 .. $y2 );      my @lines;
3579        foreach ( ( $y1 .. $y2 ) )
3580        {
3581            my $line = text_tree_row( $node, $hash, $_, [], 'tee_l' );
3582            my $lbl  = '';
3583            if ( @$line )
3584            {
3585                if ( $line->[-1] eq '' ) { pop @$line; $lbl = pop @$line }
3586                #  Translate tree characters
3587                @$line = map { $charH->{ $_ } } @$line if $chars ne 'raw';
3588  }  }
3589    
3590            # Convert to requested output format:
3591    
3592            push @lines, $fmt eq 'text'         ? join( '', @$line, ( $lbl ? " $lbl" : () ) )
3593                       : $fmt eq 'text_tab_lbl' ? join( '', @$line, "\t", $lbl )
3594                       : $fmt eq 'tree_lbl'     ? [ join( '', @$line ), $lbl ]
3595                       : $fmt eq 'chrlist_lbl'  ? [ $line, $lbl ]
3596                       :                          ();
3597        }
3598    
3599        # if ( $cells )
3600        # {
3601        #     my $nmax = 0;
3602        #     foreach ( @lines ) { $nmax = @$_ if @$_ > $nmax }
3603        #     foreach ( @lines )
3604        #     {
3605        #         @$_ = map { "<TD>$_</TD>" } @$_;
3606        #         my $span = $nmax - @$_ + 1;
3607        #         $_->[-1] =~ s/^<TD>/<TD NoWrap ColSpan=$span>/;
3608        #     }
3609        # }
3610        # elsif ( $tables )
3611        # {
3612        #     my $nmax = 0;
3613        #     foreach ( @lines ) { $nmax = @$_ if @$_ > $nmax }
3614        #     foreach ( @lines )
3615        #     {
3616        #         @$_ = map { "<TD>$_</TD>" } @$_;
3617        #         my $span = $nmax - @$_ + 1;
3618        #         $_->[-1] =~ s/^<TD>/<TD NoWrap ColSpan=$span>/;
3619        #     }
3620        # }
3621    
3622        wantarray ? @lines : \@lines;
3623    }
3624    
3625    
3626  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3627  #  ( $xmax, $ymax, $root_y ) = layout_printer_plot( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy )  #  ( $xmax, $ymax, $root_y ) = layout_printer_plot( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy, $yrnd )
3628  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3629  sub layout_printer_plot {  sub layout_printer_plot
3630      my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy ) = @_;  {
3631        my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy, $yrnd ) = @_;
3632      array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";      array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";
3633      hash_ref(  $hash ) || die "Bad hash ref passed to layout_printer_plot\n";      hash_ref(  $hash ) || die "Bad hash ref passed to layout_printer_plot\n";
3634    
3635      my $dx = newick_x( $node );      my $dx = newick_x( $node );
3636      if ( defined( $dx ) ) {      if ( defined( $dx ) ) {
3637          $dx *= $x_scale;          $dx *= $x_scale;
3638          $dx >= $min_dx or $dx = $min_dx;          $dx = $min_dx if $dx < $min_dx;
3639      }      }
3640      else {      else {
3641          $dx = ( $x0 > 0 ) ? $min_dx : 0;          $dx = ( $x0 > 0 ) ? $min_dx : 0;
# Line 3246  Line 3662 
3662          $ymax = $y0;          $ymax = $y0;
3663    
3664          foreach ( @dl ) {          foreach ( @dl ) {
3665              ( $xmaxi, $ymax, $yi ) = layout_printer_plot( $_, $hash, $x, $ymax, $x_scale, $min_dx, $dy );              ( $xmaxi, $ymax, $yi ) = layout_printer_plot( $_, $hash, $x, $ymax, $x_scale, $min_dx, $dy,
3666                                                              ( 2*@ylist < @dl ? 0.5001 : 0.4999 )
3667                                                            );
3668              push @ylist, $yi;              push @ylist, $yi;
3669              if ( $xmaxi > $xmax ) { $xmax = $xmaxi }              if ( $xmaxi > $xmax ) { $xmax = $xmaxi }
3670          }          }
# Line 3256  Line 3674 
3674    
3675          $yn1 = $ylist[ 0];          $yn1 = $ylist[ 0];
3676          $yn2 = $ylist[-1];          $yn2 = $ylist[-1];
3677          $y = int( 0.5 * ( $yn1 + $yn2 ) + 0.4999 );          $y = int( 0.5 * ( $yn1 + $yn2 ) + ( $yrnd || 0.4999 ) );
3678      }      }
3679    
3680      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );
# Line 3266  Line 3684 
3684  }  }
3685    
3686    
3687  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #  What symbol do we get if we add a leftward line to some other symbol?
 #  Debug routine  
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 sub dump_tree {  
     my ( $node, $prefix ) = @_;  
     defined( $prefix ) or $prefix = "";  
     print STDERR $prefix, join(", ", @$node), "\n";  
     my @dl = $node->[0] ? @{$node->[0]} : ();  
     foreach ( @dl ) { dump_tree( $_, $prefix . "  " ) }  
     $prefix or print STDERR "\n";  
 }  
   
   
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 #  Debug routine  
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 sub dump_tree_hash {  
     my ( $node, $hash, $prefix ) = @_;  
     defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";  
     print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";  
     my @dl = $node->[0] ? @{$node->[0]} : ();  
     foreach (@dl) { dump_tree_hash( $_, $hash, $prefix . "  " ) }  
 }  
3688    
3689    my %with_left_line = ( space  => 'half_l',
3690                           horiz  => 'horiz',
3691                           vert   => 'tee_l',
3692                           el_d_r => 'tee_d',
3693                           el_u_r => 'tee_u',
3694                           el_d_l => 'el_d_l',
3695                           el_u_l => 'el_u_l',
3696                           tee_l  => 'tee_l',
3697                           tee_r  => 'cross',
3698                           tee_u  => 'tee_u',
3699                           tee_d  => 'tee_d',
3700                           half_l => 'half_l',
3701                           half_r => 'horiz',
3702                           half_u => 'el_u_l',
3703                           half_d => 'el_d_l',
3704                           cross  => 'cross',
3705                         );
3706    
3707  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3708  #  $line = text_tree_row( $node, $hash, $row, $line, $symb )  #  Produce a description of one line of a printer plot tree.
3709    #
3710    #  \@line = text_tree_row( $node, $hash, $row, \@line, $symb )
3711    #
3712    #     \@line is the character descriptions accumulated so far, one per array
3713    #          element, except for a label, which can be any number of characters.
3714    #          Labels are followed by an empty string, so if $line->[-1] eq '',
3715    #          then $line->[-2] is a label. The calling program translates the
3716    #          symbol names to output characters.
3717    #
3718    #     \@node is a newick tree node
3719    #     \%hash contains tree layout information
3720    #      $row  is the row number (y value) that we are building
3721    #      $symb is the plot symbol proposed for the current x and y position
3722    #
3723  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3724  sub text_tree_row {  sub text_tree_row
3725    {
3726      my ( $node, $hash, $row, $line, $symb ) = @_;      my ( $node, $hash, $row, $line, $symb ) = @_;
3727    
3728      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };
3729      if ( $row < $y1 || $row > $y2 ) { return $line }      if ( $row < $y1 || $row > $y2 ) { return $line }
3730    
3731      if ( length( $line ) < $x0 ) { $line .= " " x ( $x0 - length( $line ) ) }      if ( @$line < $x0 ) { push @$line, ('space') x ( $x0 - @$line ) }
3732    
3733      if ( $row == $y ) {      if ( $row == $y ) {
3734          $line = substr( $line, 0, $x0 ) . $symb . (( $x > $x0 ) ? "-" x ($x - $x0) : "");          while ( @$line > $x0 ) { pop @$line }  # Actually 0-1 times
3735            push @$line, $symb,
3736                         ( ( $x > $x0 ) ? ('horiz') x ($x - $x0) : () );
3737      }      }
3738    
3739      elsif ( $row > $yn1 && $row < $yn2 ) {      elsif ( $row > $yn1 && $row < $yn2 ) {
3740          if ( length( $line ) < $x ) { $line .= " " x ( $x - length( $line ) ) . "|" }          if ( @$line < $x ) { push @$line, ('space') x ( $x - @$line ), 'vert' }
3741          else { substr( $line, $x ) = "|" }          else               { $line->[$x] = 'vert' }
3742      }      }
3743    
3744      my @dl = newick_desc_list( $node );      my @dl = newick_desc_list( $node );
3745    
3746      if ( @dl < 1 ) {      if ( @dl < 1 ) { push @$line, ( newick_lbl( $node ) || '' ), '' }
         $line .= " " . $node->[1];  
     }  
3747    
3748      else {      else {
3749          my @list = map { [ $_, "+" ] } @dl;  #  Print symbol for line          my @list = map { [ $_, 'tee_r' ] } @dl;  # Line to the right
3750          $list[ 0]->[1] = "/";          if ( @list > 1 ) { #  Fix top and bottom sympbols
3751          $list[-1]->[1] = "\\";              $list[ 0]->[1] = 'el_d_r';
3752                $list[-1]->[1] = 'el_u_r';
3753            }
3754            elsif ( @list ) {  # Only one descendent
3755                $list[ 0]->[1] = 'half_r';
3756            }
3757          foreach ( @list ) {          foreach ( @list ) {
3758              my ( $n, $s ) = @$_;              my ( $n, $s ) = @$_;
3759              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {
# Line 3329  Line 3761 
3761              }              }
3762           }           }
3763    
3764          if ( $row == $y ) { substr( $line, $x, 1 ) = "+" }          if ( $row == $y ) {
3765                $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'
3766                                                         : $with_left_line{ $line->[$x] };
3767            }
3768      }      }
3769    
3770      return $line;      return $line;
3771  }  }
3772    
3773    
3774    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3775    #  Debug routine
3776    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3777    sub dump_tree {
3778        my ( $node, $prefix ) = @_;
3779        defined( $prefix ) or $prefix = "";
3780        print STDERR $prefix, join(", ", @$node), "\n";
3781        my @dl = $node->[0] ? @{$node->[0]} : ();
3782        foreach ( @dl ) { dump_tree( $_, $prefix . "  " ) }
3783        $prefix or print STDERR "\n";
3784    }
3785    
3786    
3787    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3788    #  Debug routine
3789    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3790    sub dump_tree_hash {
3791        my ( $node, $hash, $prefix ) = @_;
3792        defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";
3793        print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";
3794        my @dl = $node->[0] ? @{$node->[0]} : ();
3795        foreach (@dl) { dump_tree_hash( $_, $hash, $prefix . "  " ) }
3796    }
3797    
3798    
3799  #===============================================================================  #===============================================================================
3800  #  Open an input file stream:  #  Open an input file stream:
3801  #  #

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.15

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3