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

Annotation of /FigKernelPackages/gjosegmentlib.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3