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

Annotation of /FigKernelPackages/gjosegmentlib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : golsen 1.1 # gjosegmentlib.pm
2 :     #
3 :     # A library of functions for finding the interval in which a coordinate falls.
4 :     # Intervals are placed end to end. Each has an id and a length.
5 :     #
6 :     # Usage:
7 :     #
8 :     # use gjosegmentlib
9 :     #
10 :     # $tree = $rootnode
11 :     # $node = [ $id, $seglen, $lref, $rref, $h, $llen, $mlen, $tlen ]
12 :     #
13 :     # $id an arbitrary id, which can be a reference to arbitrary data
14 :     # (the tree is in $id order)
15 :     # $seglen the length of the segment represented by the node (>= 0)
16 :     # $lref reference to left descendent or undef
17 :     # $rref reference to right descendent or undef
18 :     # $h height of node, for balancing
19 :     # $llen start point of length interval (length of left subtree)
20 :     # $mlen endpoint of length interval (= $llen + $seglen)
21 :     # $tlen total node length (= $mlen + length of right subtree)
22 :     #
23 :     # Whole tree functions:
24 :     #
25 :     # $tree = segment_new_tree( @pairs ) # make a tree with [ id, length ] pairs
26 :     # $n = segment_count( $tree ) # number of nodes in the tree
27 :     # $length = segment_total( $tree ) # total length of segments in tree
28 :     # @pairs = segment_flatten( $tree ) # return all [ id, length ] pairs
29 :     #
30 :     # segment_debug( $node )
31 :     # segment_print( $tree ) # print ordered id and length pairs
32 :     #
33 :     # Tree element functions:
34 :     #
35 :     # $length = segment_length( $id, $tree ) # return length at segment node with given id
36 :     # $node = segment_raw_search( $id, $tree) # return reference to segment node with given id
37 :     # $id = segment_next_id( $query, $tree ) # first id > query
38 :     # $id = segment_prev_id( $query, $tree ) # first id < query
39 :     # $tree = segment_add( $id, $length, $tree ) # insert new id and length into segment tree
40 :     # $tree = segment_del( $id, $tree ) # delete an id and length from segment tree
41 :     #
42 :     # Coordinate-based functions:
43 :     #
44 :     # $id = segment_by_coord( $coord, $tree )
45 :     # ( $tree, $id ) = segment_del_by_coord( $coord, $tree )
46 :     # ( $tree, $id ) = segment_del_random( $tree )
47 :     #
48 :     # Node information functions:
49 :     #
50 :     # $id = segment_id( $node )
51 :     # $seglen = segment_len( $node )
52 :     # $lref = segment_l( $node )
53 :     # $rref = segment_r( $node )
54 :     # $h = segment_h( $node )
55 :     # $llen = segment_llen( $node )
56 :     # $mlen = segment_mlen( $node )
57 :     # $tlen = segment_tlen( $node )
58 :     #
59 :    
60 :     package gjosegmentlib;
61 :    
62 :     use strict;
63 :    
64 :     require Exporter;
65 :     our @ISA = qw(Exporter);
66 :     our @EXPORT = qw(
67 :     segment_new_tree
68 :     segment_count
69 :     segment_total
70 :     segment_flatten
71 :     segment_print
72 :     segment_debug
73 :     segment_length
74 :     segment_next_id
75 :     segment_prev_id
76 :     segment_add
77 :     segment_del
78 :     segment_by_coord
79 :     segment_del_by_coord
80 :     segment_del_random
81 :     );
82 :    
83 :     our @EXPORT_OK = qw(
84 :     segment_raw_search
85 :     segment_balance
86 :     segment_join
87 :     segment_r_tip
88 :     segment_l_tip
89 :     segment_id
90 :     segment_len
91 :     segment_l
92 :     segment_r
93 :     segment_h
94 :     segment_llen
95 :     segment_mlen
96 :     segment_tlen
97 :     set_id
98 :     set_len
99 :     set_l
100 :     set_r
101 :     set_h
102 :     set_llen
103 :     set_mlen
104 :     set_tlen
105 :     segment_new_tip
106 :     segment_update_h
107 :     );
108 :    
109 :     #-----------------------------------------------------------------------------
110 :     # Count nodes in segment tree
111 :     #-----------------------------------------------------------------------------
112 :    
113 :     sub segment_count
114 :     {
115 :     my ( $node ) = @_;
116 :     is_node( $node ) ? 1 + segment_count( segment_l( $node ) )
117 :     + segment_count( segment_r( $node ) )
118 :     : 0
119 :     }
120 :    
121 :    
122 :     #-----------------------------------------------------------------------------
123 :     # Total length of segments
124 :     #-----------------------------------------------------------------------------
125 :    
126 :     sub segment_total
127 :     {
128 :     my ( $node ) = @_;
129 :     is_node( $node ) ? segment_tlen( $node ) : undef
130 :     }
131 :    
132 :    
133 :     #-----------------------------------------------------------------------------
134 :     # Return ordered id and length pairs from segment tree
135 :     #-----------------------------------------------------------------------------
136 :    
137 :     sub segment_flatten
138 :     {
139 :     my ( $node ) = @_;
140 :     is_node( $node ) ? ( segment_flatten( segment_l( $node ) ),
141 :     [ segment_id( $node ), segment_len( $node ) ],
142 :     segment_flatten( segment_r( $node ) )
143 :     )
144 :     : ()
145 :     }
146 :    
147 :    
148 :     #-----------------------------------------------------------------------------
149 :     # Print the id value pair in the tree
150 :     #-----------------------------------------------------------------------------
151 :    
152 :     sub segment_print
153 :     {
154 :     print join( "\n", map { "$_->[0] => $_->[1]" }
155 :     segment_flatten( @_ )
156 :     ), "\n"
157 :     }
158 :    
159 :    
160 :     #-----------------------------------------------------------------------------
161 :     # Print the tree nodes in order
162 :     #-----------------------------------------------------------------------------
163 :    
164 :     sub segment_debug
165 :     {
166 :     my ( $node ) = @_;
167 :     is_node( $node ) || return;
168 :    
169 :     segment_debug( segment_l( $node ) );
170 :     print STDERR join( "\t", $node, @$node ), "\n";
171 :     segment_debug( segment_r( $node ) );
172 :     }
173 :    
174 :    
175 :     #-----------------------------------------------------------------------------
176 :     # Return length at segment node with given id, or null if not found
177 :     #-----------------------------------------------------------------------------
178 :    
179 :     sub segment_length
180 :     {
181 :     my ( $id, $tree ) = @_;
182 :     return segment_len( segment_raw_search( $id, $tree ) );
183 :     }
184 :    
185 :    
186 :     #-----------------------------------------------------------------------------
187 :     # Return index of segment node with given id, or null if not found
188 :     #-----------------------------------------------------------------------------
189 :    
190 :     sub segment_raw_search
191 :     {
192 :     my ( $id, $node ) = @_;
193 :     is_node( $node ) || return undef;
194 :    
195 :     my $dir = $id cmp segment_id( $node );
196 :    
197 :     $dir < 0 ? segment_raw_search( $id, segment_l( $node ) ) :
198 :     $dir > 0 ? segment_raw_search( $id, segment_r( $node ) ) :
199 :     $node;
200 :     }
201 :    
202 :    
203 :     #-----------------------------------------------------------------------------
204 :     # Return the next id > id in a segment tree, or undef if there is none
205 :     #
206 :     # $nextid = segment_next_id( $id, $tree )
207 :     #-----------------------------------------------------------------------------
208 :    
209 :     sub segment_next_id
210 :     {
211 :     my ($id, $node, $nextid) = @_;
212 :     is_node( $node ) || return $nextid;
213 :    
214 :     my $nodeid = segment_id( $node );
215 :     my $dir = $id cmp $nodeid;
216 :     $dir < 0 ? segment_next_id( $id, segment_l( $node ), $nodeid )
217 :     : segment_next_id( $id, segment_r( $node ), $nextid );
218 :     }
219 :    
220 :    
221 :     #-----------------------------------------------------------------------------
222 :     # Return the prev id < id in a segment tree, or undef if there is none
223 :     #
224 :     # $prev_id = segment_prev_id( $id, $tree )
225 :     #-----------------------------------------------------------------------------
226 :    
227 :     sub segment_prev_id
228 :     {
229 :     my ($id, $node, $previd) = @_;
230 :     is_node( $node ) || return $previd;
231 :    
232 :     my $nodeid = segment_id( $node );
233 :     my $dir = $id cmp $nodeid;
234 :     $dir > 0 ? segment_prev_id( $id, segment_r( $node ), $nodeid )
235 :     : segment_prev_id( $id, segment_l( $node ), $previd );
236 :     }
237 :    
238 :    
239 :     #-----------------------------------------------------------------------------
240 :     # Insert new id and length into segment tree, returning tree (and status)
241 :     #
242 :     # ( $tree, $added ) = segment_add( $id, $length, $tree )
243 :     # $tree = segment_add( $id, $length, $tree )
244 :     #-----------------------------------------------------------------------------
245 :    
246 :     sub segment_add
247 :     {
248 :     my ( $id, $length, $node ) = @_;
249 :     my $added = 0;
250 :    
251 :     if ( is_node( $node ) )
252 :     {
253 :     my $dir = $id cmp $node;
254 :    
255 :     if ( $dir < 0 )
256 :     {
257 :     my $nl = segment_l( $node );
258 :    
259 :     if ( ! $nl )
260 :     {
261 :     set_l( $node, segment_new_tip( $id, $length ) );
262 :     segment_update_h( $node );
263 :     $added = 1;
264 :     }
265 :     else
266 :     {
267 :     my $n2;
268 :     ( $n2, $added ) = segment_add( $id, $length, $nl );
269 :     $node = segment_balance( $n2, segment_r( $n2 ), $node );
270 :     }
271 :     }
272 :    
273 :     elsif ( $dir > 0 )
274 :     {
275 :     my $nr = segment_r( $node );
276 :     if ( ! $nr )
277 :     {
278 :     set_r( $node, segment_new_tip( $id, $length ) );
279 :     segment_update_h( $node );
280 :     $added = 1;
281 :     }
282 :     else
283 :     {
284 :     my $n4;
285 :     ( $n4, $added ) = segment_add( $id, $length, $nr );
286 :     $node = segment_balance( $node, segment_l( $n4 ), $n4 );
287 :     }
288 :     }
289 :    
290 :     # If already exists, silently do nothing
291 :     }
292 :    
293 :     else # This is adding to an empty tree
294 :     {
295 :     $node = segment_new_tip( $id, $length );
296 :     $added = 1;
297 :     }
298 :    
299 :     wantarray ? ( $node, $added ) : $node;
300 :     }
301 :    
302 :    
303 :     #-----------------------------------------------------------------------------
304 :     # delete an id and length from segment tree, returning pointer to tree
305 :     #
306 :     # ( $tree, $found ) = segment_del( $id, $tree )
307 :     #-----------------------------------------------------------------------------
308 :    
309 :     sub segment_del
310 :     {
311 :     my ( $id, $node ) = @_;
312 :     my $found = 0;
313 :    
314 :     if ( is_node( $node ) )
315 :     {
316 :     my $dir = $id cmp segment_id( $node );
317 :    
318 :     if ( $dir < 0 )
319 :     {
320 :     my $nl;
321 :     ( $nl, $found ) = segment_del( $id, segment_l( $node ) );
322 :     if ( $found )
323 :     {
324 :     set_l( $node, $nl );
325 :     my $n4 = segment_r( $node );
326 :     $node = segment_balance( $node, segment_l( $n4 ), $n4 );
327 :     }
328 :     }
329 :    
330 :     elsif ( $dir > 0 )
331 :     {
332 :     my $nr;
333 :     ( $nr, $found ) = segment_del( $id, segment_r( $node ) );
334 :     if ( $found )
335 :     {
336 :     set_r( $node, $nr );
337 :     my $n2 = segment_l($node);
338 :     $node = segment_balance( $n2, segment_r( $n2 ), $node );
339 :     }
340 :     }
341 :    
342 :     else { # Found it
343 :     $node = segment_join( segment_l( $node ), segment_r( $node ) );
344 :     $found = 1;
345 :     }
346 :     }
347 :    
348 :     wantarray ? ( $node, $found ) : $node;
349 :     }
350 :    
351 :    
352 :     #-----------------------------------------------------------------------------
353 :     # Coordinate-based functions:
354 :     #
355 :     # $id = segment_by_coord( $coord, $tree )
356 :     # ( $tree, $id ) = segment_del_by_coord( $coord, $tree )
357 :     # ( $tree, $id ) = segment_del_random( $tree )
358 :     #-----------------------------------------------------------------------------
359 :    
360 :     sub segment_by_coord
361 :     {
362 :     my ( $coord, $node ) = @_;
363 :     is_node( $node ) and ( $coord >= 0 ) and ( $coord <= segment_tlen( $node ) ) or return undef;
364 :    
365 :     if ( segment_llen( $node ) > $coord )
366 :     {
367 :     my $l = segment_l( $node );
368 :     return $l ? segment_by_coord( $coord, $l ) : segment_id( $node );
369 :     }
370 :     my $ml = segment_mlen( $node );
371 :    
372 :     if ( $ml < $coord )
373 :     {
374 :     my $r = segment_r( $node );
375 :     return $r ? segment_by_coord( $coord-$ml, $r ) : segment_id( $node );
376 :     }
377 :    
378 :     segment_id( $node )
379 :     }
380 :    
381 :    
382 :     sub segment_del_by_coord
383 :     {
384 :     my ( $coord, $tree ) = @_;
385 :     my $id = segment_by_coord( $coord, $tree );
386 :     $id ? ( ( segment_del( $id, $tree ) )[0], $id ) : ( $tree, undef )
387 :     }
388 :    
389 :    
390 :     sub segment_del_random
391 :     {
392 :     my ( $tree ) = @_;
393 :     return undef if ! is_node( $tree );
394 :    
395 :     my $id = segment_by_coord( rand() * segment_tlen( $tree ), $tree );
396 :     $id ? ( ( segment_del( $id, $tree ) )[0], $id ) : ( $tree, undef )
397 :     }
398 :    
399 :    
400 :     #-----------------------------------------------------------------------------
401 :     #
402 :     # n2 n4
403 :     # / . . \
404 :     # n1 n3 n5
405 :     # / \
406 :     # n3l n3r
407 :     #
408 :     # $h1 >= $h3 $h5 >= $h3
409 :     # ! $n2 ! $n4 $h1 >= $h5 $h5 >= $h1 otherwise
410 :     # -------- -------- ----------- ----------- --------------
411 :     # n4 n2 n2 n4 n3
412 :     # / \ / \ / \ / \ / \
413 :     # n3 n5 n1 n3 n1 n4 n2 n5 n2 n4
414 :     # / \ / \ / \ / \
415 :     # n3 n5 n1 n3 n1 n3l n3r n5
416 :     #
417 :     #-----------------------------------------------------------------------------
418 :     # root segment subtrees to maintain balance
419 :     #-----------------------------------------------------------------------------
420 :    
421 :     sub segment_balance
422 :     {
423 :     my ( $n2, $n3, $n4 ) = @_;
424 :    
425 :     if ( ! is_node( $n2 ) )
426 :     {
427 :     if ( ! is_node( $n4 ) ) { return $n3 }
428 :     set_l( $n4, $n3 );
429 :     segment_update_h( $n4 );
430 :     return $n4;
431 :     }
432 :    
433 :     if ( ! is_node( $n4 ) )
434 :     {
435 :     set_r( $n2, $n3 );
436 :     segment_update_h( $n2 );
437 :     return $n2;
438 :     }
439 :    
440 :     my ($n1, $n3l, $n3r, $n5, $h1, $h3, $h5);
441 :     $n1 = segment_l( $n2 );
442 :     $h1 = segment_h( $n1 );
443 :     $h3 = segment_h( $n3 );
444 :     $n5 = segment_r( $n4 );
445 :     $h5 = segment_h( $n5 );
446 :    
447 :     if ( $h1 >= $h3 && $h1 >= $h5 )
448 :     {
449 :     set_r( $n2, $n4 );
450 :     set_l( $n4, $n3 );
451 :     segment_update_h( $n4 );
452 :     segment_update_h( $n2 );
453 :     return $n2;
454 :     }
455 :    
456 :     if ($h5 >= $h3 && $h5 >= $h1)
457 :     {
458 :     set_r( $n2, $n3 );
459 :     set_l( $n4, $n2 );
460 :     segment_update_h( $n2 );
461 :     segment_update_h( $n4 );
462 :     return $n4;
463 :     }
464 :    
465 :     else
466 :     {
467 :     $n3l = segment_l( $n3 );
468 :     $n3r = segment_r( $n3 );
469 :     set_r( $n2, $n3l );
470 :     set_l( $n3, $n2 );
471 :     set_r( $n3, $n4 );
472 :     set_l( $n4, $n3r );
473 :     segment_update_h( $n2 );
474 :     segment_update_h( $n4 );
475 :     segment_update_h( $n3 );
476 :     return $n3;
477 :     }
478 :     }
479 :    
480 :    
481 :     #-----------------------------------------------------------------------------
482 :     #
483 :     # / \
484 :     # nl nr
485 :     #
486 :     #-----------------------------------------------------------------------------
487 :     # Join 2 segment subtrees for which common parent has been deleted
488 :     #-----------------------------------------------------------------------------
489 :    
490 :     sub segment_join
491 :     {
492 :     my ($nl, $nr) = @_;
493 :    
494 :     is_node( $nl ) || return $nr; # Correctly handles n3 = undef
495 :     is_node( $nr ) || return $nl;
496 :    
497 :     ( segment_h( $nl ) >= segment_h( $nr ) )
498 :     ? segment_balance( segment_r_tip( $nl, undef ), segment_l( $nr ), $nr )
499 :     : segment_balance( $nl, segment_r( $nl ), segment_l_tip( $nr, undef ) );
500 :     }
501 :    
502 :    
503 :     #-----------------------------------------------------------------------------
504 :     # Remove rightmost tip from segment tree and return it to the top
505 :     #-----------------------------------------------------------------------------
506 :    
507 :     sub segment_r_tip
508 :     {
509 :     my ($node, $parent) = @_;
510 :     $node || return undef;
511 :    
512 :     my ($rtip, $nl, $nr, $n3, $new);
513 :     $nr = segment_r( $node );
514 :     if (! $nr ) { # This is "tip"
515 :     if ( $parent )
516 :     {
517 :     set_r( $parent, segment_l( $node ) );
518 :     set_l( $node, undef);
519 :     }
520 :     return $node;
521 :     }
522 :    
523 :     $rtip = segment_r_tip( $nr, $node ); # Continue descent into right subtree
524 :     $rtip || die "segment_r_tip: bad tree\n";
525 :    
526 :     $nl = segment_l( $node );
527 :     $n3 = segment_r( $nl );
528 :     $new = segment_balance( $nl, $n3, $node );
529 :    
530 :     if ( ! $parent ) { set_l( $rtip, $new ) }
531 :     elsif ( $new ne $node ) { set_r( $parent, $new ) }
532 :    
533 :     $rtip;
534 :     }
535 :    
536 :    
537 :     #-----------------------------------------------------------------------------
538 :     # Remove leftmost tip from segment tree and return it to the top
539 :     #-----------------------------------------------------------------------------
540 :    
541 :     sub segment_l_tip
542 :     {
543 :     my ($node, $parent) = @_;
544 :     $node || return undef;
545 :    
546 :     my ($ltip, $nl, $nr, $n3, $new);
547 :     $nl = segment_l( $node );
548 :     if ( ! $nl ) { # This is "tip"
549 :     if ( $parent )
550 :     {
551 :     set_l( $parent, segment_r( $node ) );
552 :     set_r( $node, undef);
553 :     }
554 :     return $node;
555 :     }
556 :    
557 :     $ltip = segment_l_tip( $nl, $node ); # Continue descent into left subtree
558 :     $ltip || die "segment_l_tip: bad tree\n";
559 :    
560 :     $nr = segment_r( $node );
561 :     $n3 = segment_l( $nr );
562 :     $new = segment_balance( $node, $n3, $nr );
563 :    
564 :     if ( ! $parent ) { set_r( $ltip, $new ) }
565 :     elsif ( $new ne $node) { set_l( $parent, $new ) }
566 :    
567 :     $ltip;
568 :     }
569 :    
570 :    
571 :     #-----------------------------------------------------------------------------
572 :     # Update the height and coordinate data for a node after an edit of the tree
573 :     #-----------------------------------------------------------------------------
574 :    
575 :     sub segment_update_h
576 :     {
577 :     my ($n) = @_;
578 :     ref( $n) eq "ARRAY" || return undef;
579 :    
580 :     my $nl = segment_l( $n );
581 :     my ( $hl, $ll ) = $nl ? ( segment_h( $nl ), segment_tlen( $nl ) ) : ( 0, 0 );
582 :     my $nr = segment_r( $n );
583 :     my ( $hr, $lr ) = $nr ? ( segment_h( $nr ), segment_tlen( $nr ) ) : ( 0, 0 );
584 :     my $mlen = $ll + segment_len( $n );
585 :    
586 :     set_h( $n, max( $hl, $hr ) + 1 );
587 :     set_llen( $n, $ll );
588 :     set_mlen( $n, $mlen );
589 :     set_tlen( $n, $mlen + $lr )
590 :     }
591 :    
592 :    
593 :     #-----------------------------------------------------------------------------
594 :     # Is the arguement a valid node?
595 :     #-----------------------------------------------------------------------------
596 :    
597 :     sub is_node
598 :     {
599 :     my ( $n ) = @_;
600 :     ref( $n ) eq "ARRAY" && defined( $n->[0] ) && defined( $n->[4] )
601 :     }
602 :    
603 :    
604 :     #-----------------------------------------------------------------------------
605 :     # Extract id, length, lnode, rnode, height, llen, mlen or tlen
606 :     #
607 :     # $node = [ $id, $seglen, $lref, $rref, $h, $llen, $mlen, $tlen ]
608 :     #-----------------------------------------------------------------------------
609 :    
610 :     sub segment_id { ref( $_[0] ) eq "ARRAY" ? $_[0]->[0] : undef }
611 :     sub segment_len { ref( $_[0] ) eq "ARRAY" ? $_[0]->[1] : undef }
612 :     sub segment_l { ref( $_[0] ) eq "ARRAY" ? $_[0]->[2] : undef }
613 :     sub segment_r { ref( $_[0] ) eq "ARRAY" ? $_[0]->[3] : undef }
614 :     sub segment_h { ref( $_[0] ) eq "ARRAY" ? $_[0]->[4] : 0 }
615 :     sub segment_llen { ref( $_[0] ) eq "ARRAY" ? $_[0]->[5] : 0 }
616 :     sub segment_mlen { ref( $_[0] ) eq "ARRAY" ? $_[0]->[6] : 0 }
617 :     sub segment_tlen { ref( $_[0] ) eq "ARRAY" ? $_[0]->[7] : 0 }
618 :    
619 :    
620 :     #-----------------------------------------------------------------------------
621 :     # Set id, length, lnode, rnode, height, llen, mlen or tlen
622 :     # Return the value assigned.
623 :     #-----------------------------------------------------------------------------
624 :    
625 :     sub set_id { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[0] = $_[1] ) : undef }
626 :     sub set_len { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[1] = $_[1] ) : undef }
627 :     sub set_l { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[2] = $_[1] ) : undef }
628 :     sub set_r { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[3] = $_[1] ) : undef }
629 :     sub set_h { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[4] = $_[1] ) : undef }
630 :     sub set_llen { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[5] = $_[1] ) : undef }
631 :     sub set_mlen { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[6] = $_[1] ) : undef }
632 :     sub set_tlen { ref( $_[0] ) eq "ARRAY" ? ( $_[0]->[7] = $_[1] ) : undef }
633 :    
634 :    
635 :     #-----------------------------------------------------------------------------
636 :     # Make a new segment tree from list of [ id, length ] pairs
637 :     #-----------------------------------------------------------------------------
638 :    
639 :     sub segment_new_tree { ( quick_tree( sort { $a->[0] cmp $b->[0] } @_ ) )[0] }
640 :    
641 :    
642 :     #-----------------------------------------------------------------------------
643 :     # Make a new segment tree from sorted list of [ id, length ] pairs
644 :     #
645 :     # ( $tree, $height, $length ) = quick_tree( @pairs );
646 :     #-----------------------------------------------------------------------------
647 :    
648 :     sub quick_tree
649 :     {
650 :     @_ or return ( undef, 0, 0 );
651 :     @_ == 1 and return ( segment_new_tip( @{ $_[0] } ), 1, $_[0]->[1] );
652 :    
653 :     my ( $l, $hl, $ll ) = quick_tree( splice @_, 0, int( @_ / 2 ) );
654 :     my $n = segment_new_tip( @{ shift @_ } );
655 :     my ( $r, $hr, $lr ) = quick_tree( @_ );
656 :     my $h = max( $hl, $hr ) + 1;
657 :     my $mlen = $ll + segment_len( $n );
658 :     my $tlen = $mlen + $lr;
659 :    
660 :     splice @$n, 2, 6, ( $l, $r, $h, $ll, $mlen, $tlen );
661 :     ( $n, $h, $tlen )
662 :     }
663 :    
664 :     sub max { $_[0] >= $_[1] ? $_[0] : $_[1] }
665 :    
666 :    
667 :     #-----------------------------------------------------------------------------
668 :     # Make a new tip node
669 :     #-----------------------------------------------------------------------------
670 :    
671 :     sub segment_new_tip
672 :     {
673 :     my ( $id, $length ) = @_;
674 :     defined( $id ) && $length >= 0 or return undef;
675 :     [ $id, $length, undef, undef, 1, 0, $length, $length ]
676 :     }
677 :    
678 :    
679 :     1;
680 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3