1package Heap::Fibonacci; 2 3use strict; 4use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); 5 6require Exporter; 7require AutoLoader; 8 9@ISA = qw(Exporter AutoLoader); 10 11# No names exported. 12# No names available for export. 13@EXPORT = ( ); 14 15$VERSION = '0.71'; 16 17 18# Preloaded methods go here. 19 20# common names 21# h - heap head 22# el - linkable element, contains user-provided value 23# v - user-provided value 24 25################################################# debugging control 26 27my $debug = 0; 28my $validate = 0; 29 30# enable/disable debugging output 31sub debug { 32 @_ ? ($debug = shift) : $debug; 33} 34 35# enable/disable validation checks on values 36sub validate { 37 @_ ? ($validate = shift) : $validate; 38} 39 40my $width = 3; 41my $bar = ' | '; 42my $corner = ' +-'; 43my $vfmt = "%3d"; 44 45sub set_width { 46 $width = shift; 47 $width = 2 if $width < 2; 48 49 $vfmt = "%${width}d"; 50 $bar = $corner = ' ' x $width; 51 substr($bar,-2,1) = '|'; 52 substr($corner,-2,2) = '+-'; 53} 54 55sub hdump; 56 57sub hdump { 58 my $el = shift; 59 my $l1 = shift; 60 my $b = shift; 61 62 my $ch; 63 my $ch1; 64 65 unless( $el ) { 66 print $l1, "\n"; 67 return; 68 } 69 70 hdump $ch1 = $el->{child}, 71 $l1 . sprintf( $vfmt, $el->{val}->val), 72 $b . $bar; 73 74 if( $ch1 ) { 75 for( $ch = $ch1->{right}; $ch != $ch1; $ch = $ch->{right} ) { 76 hdump $ch, $b . $corner, $b . $bar; 77 } 78 } 79} 80 81sub heapdump { 82 my $h; 83 84 while( $h = shift ) { 85 my $top = $$h or last; 86 my $el = $top; 87 88 do { 89 hdump $el, sprintf( "%02d: ", $el->{degree}), ' '; 90 $el = $el->{right}; 91 } until $el == $top; 92 print "\n"; 93 } 94} 95 96sub bhcheck; 97 98sub bhcheck { 99 my $el = shift; 100 my $p = shift; 101 102 my $cur = $el; 103 my $prev; 104 my $ch; 105 do { 106 $prev = $cur; 107 $cur = $cur->{right}; 108 die "bad back link" unless $cur->{left} == $prev; 109 die "bad parent link" 110 unless (defined $p && defined $cur->{p} && $cur->{p} == $p) 111 || (!defined $p && !defined $cur->{p}); 112 die "bad degree( $cur->{degree} > $p->{degree} )" 113 if $p && $p->{degree} <= $cur->{degree}; 114 die "not heap ordered" 115 if $p && $p->{val}->cmp($cur->{val}) > 0; 116 $ch = $cur->{child} and bhcheck $ch, $cur; 117 } until $cur == $el; 118} 119 120 121sub heapcheck { 122 my $h; 123 my $el; 124 while( $h = shift ) { 125 heapdump $h if $validate >= 2; 126 $el = $$h and bhcheck $el, undef; 127 } 128} 129 130 131################################################# forward declarations 132 133sub ascending_cut; 134sub elem; 135sub elem_DESTROY; 136sub link_to_left_of; 137 138################################################# heap methods 139 140# Cormen et al. use two values for the heap, a pointer to an element in the 141# list at the top, and a count of the number of elements. The count is only 142# used to determine the size of array required to hold log(count) pointers, 143# but perl can set array sizes as needed and doesn't need to know their size 144# when they are created, so we're not maintaining that field. 145sub new { 146 my $self = shift; 147 my $class = ref($self) || $self; 148 my $h = undef; 149 bless \$h, $class; 150} 151 152sub DESTROY { 153 my $h = shift; 154 155 elem_DESTROY $$h; 156} 157 158sub add { 159 my $h = shift; 160 my $v = shift; 161 $validate && do { 162 die "Method 'heap' required for element on heap" 163 unless $v->can('heap'); 164 die "Method 'cmp' required for element on heap" 165 unless $v->can('cmp'); 166 }; 167 my $el = elem $v; 168 my $top; 169 if( !($top = $$h) ) { 170 $$h = $el; 171 } else { 172 link_to_left_of $top->{left}, $el ; 173 link_to_left_of $el,$top; 174 $$h = $el if $v->cmp($top->{val}) < 0; 175 } 176} 177 178sub top { 179 my $h = shift; 180 $$h && $$h->{val}; 181} 182 183*minimum = \⊤ 184 185sub extract_top { 186 my $h = shift; 187 my $el = $$h or return undef; 188 my $ltop = $el->{left}; 189 my $cur; 190 my $next; 191 192 # $el is the heap with the lowest value on it 193 # move all of $el's children (if any) to the top list (between 194 # $ltop and $el) 195 if( $cur = $el->{child} ) { 196 # remember the beginning of the list of children 197 my $first = $cur; 198 do { 199 # the children are moving to the top, clear the p 200 # pointer for all of them 201 $cur->{p} = undef; 202 } until ($cur = $cur->{right}) == $first; 203 204 # remember the end of the list 205 $cur = $cur->{left}; 206 link_to_left_of $ltop, $first; 207 link_to_left_of $cur, $el; 208 } 209 210 if( $el->{right} == $el ) { 211 # $el had no siblings or children, the top only contains $el 212 # and $el is being removed 213 $$h = undef; 214 } else { 215 link_to_left_of $el->{left}, $$h = $el->{right}; 216 # now all those loose ends have to be merged together as we 217 # search for the 218 # new smallest element 219 $h->consolidate; 220 } 221 222 # extract the actual value and return that, $el is no longer used 223 # but break all of its links so that it won't be pointed to... 224 my $top = $el->{val}; 225 $top->heap(undef); 226 $el->{left} = $el->{right} = $el->{p} = $el->{child} = $el->{val} = 227 undef; 228 $top; 229} 230 231*extract_minimum = \&extract_top; 232 233sub absorb { 234 my $h = shift; 235 my $h2 = shift; 236 237 my $el = $$h; 238 unless( $el ) { 239 $$h = $$h2; 240 $$h2 = undef; 241 return $h; 242 } 243 244 my $el2 = $$h2 or return $h; 245 246 # add $el2 and its siblings to the head list for $h 247 # at start, $ell -> $el -> ... -> $ell is on $h (where $ell is 248 # $el->{left}) 249 # $el2l -> $el2 -> ... -> $el2l are on $h2 250 # at end, $ell -> $el2l -> ... -> $el2 -> $el -> ... -> $ell are 251 # all on $h 252 my $el2l = $el2->{left}; 253 link_to_left_of $el->{left}, $el2; 254 link_to_left_of $el2l, $el; 255 256 # change the top link if needed 257 $$h = $el2 if $el->{val}->cmp( $el2->{val} ) > 0; 258 259 # clean out $h2 260 $$h2 = undef; 261 262 # return the heap 263 $h; 264} 265 266# a key has been decreased, it may have to percolate up in its heap 267sub decrease_key { 268 my $h = shift; 269 my $top = $$h; 270 my $v = shift; 271 my $el = $v->heap or return undef; 272 my $p; 273 274 # first, link $h to $el if it is now the smallest (we will 275 # soon link $el to $top to properly put it up to the top list, 276 # if it isn't already there) 277 $$h = $el if $top->{val}->cmp( $v ) > 0; 278 279 if( $p = $el->{p} and $v->cmp($p->{val}) < 0 ) { 280 # remove $el from its parent's list - it is now smaller 281 282 ascending_cut $top, $p, $el; 283 } 284 285 $v; 286} 287 288 289# to delete an item, we bubble it to the top of its heap (as if its key 290# had been decreased to -infinity), and then remove it (as in extract_top) 291sub delete { 292 my $h = shift; 293 my $v = shift; 294 my $el = $v->heap or return undef; 295 296 # if there is a parent, cut $el to the top (as if it had just had its 297 # key decreased to a smaller value than $p's value 298 my $p; 299 $p = $el->{p} and ascending_cut $$h, $p, $el; 300 301 # $el is in the top list now, make it look like the smallest and 302 # remove it 303 $$h = $el; 304 $h->extract_top; 305} 306 307 308################################################# internal utility functions 309 310sub elem { 311 my $v = shift; 312 my $el = undef; 313 $el = { 314 p => undef, 315 degree => 0, 316 mark => 0, 317 child => undef, 318 val => $v, 319 left => undef, 320 right => undef, 321 }; 322 $el->{left} = $el->{right} = $el; 323 $v->heap($el); 324 $el; 325} 326 327sub elem_DESTROY { 328 my $el = shift; 329 my $ch; 330 my $next; 331 $el->{left}->{right} = undef; 332 333 while( $el ) { 334 $ch = $el->{child} and elem_DESTROY $ch; 335 $next = $el->{right}; 336 337 defined $el->{val} and $el->{val}->heap(undef); 338 $el->{child} = $el->{right} = $el->{left} = $el->{p} = $el->{val} 339 = undef; 340 $el = $next; 341 } 342} 343 344sub link_to_left_of { 345 my $l = shift; 346 my $r = shift; 347 348 $l->{right} = $r; 349 $r->{left} = $l; 350} 351 352sub link_as_parent_of { 353 my $p = shift; 354 my $c = shift; 355 356 my $pc; 357 358 if( $pc = $p->{child} ) { 359 link_to_left_of $pc->{left}, $c; 360 link_to_left_of $c, $pc; 361 } else { 362 link_to_left_of $c, $c; 363 } 364 $p->{child} = $c; 365 $c->{p} = $p; 366 $p->{degree}++; 367 $c->{mark} = 0; 368 $p; 369} 370 371sub consolidate { 372 my $h = shift; 373 374 my $cur; 375 my $this; 376 my $next = $$h; 377 my $last = $next->{left}; 378 my @a; 379 do { 380 # examine next item on top list 381 $this = $cur = $next; 382 $next = $cur->{right}; 383 my $d = $cur->{degree}; 384 my $alt; 385 while( $alt = $a[$d] ) { 386 # we already saw another item of the same degree, 387 # put the larger valued one under the smaller valued 388 # one - switch $cur and $alt if necessary so that $cur 389 # is the smaller 390 ($cur,$alt) = ($alt,$cur) 391 if $cur->{val}->cmp( $alt->{val} ) > 0; 392 # remove $alt from the top list 393 link_to_left_of $alt->{left}, $alt->{right}; 394 # and put it under $cur 395 link_as_parent_of $cur, $alt; 396 # make sure that $h still points to a node at the top 397 $$h = $cur; 398 # we've removed the old $d degree entry 399 $a[$d] = undef; 400 # and we now have a $d+1 degree entry to try to insert 401 # into @a 402 ++$d; 403 } 404 # found a previously unused degree 405 $a[$d] = $cur; 406 } until $this == $last; 407 $cur = $$h; 408 for $cur (grep defined, @a) { 409 $$h = $cur if $$h->{val}->cmp( $cur->{val} ) > 0; 410 } 411} 412 413sub ascending_cut { 414 my $top = shift; 415 my $p = shift; 416 my $el = shift; 417 418 while( 1 ) { 419 if( --$p->{degree} ) { 420 # there are still other children below $p 421 my $l = $el->{left}; 422 $p->{child} = $l; 423 link_to_left_of $l, $el->{right}; 424 } else { 425 # $el was the only child of $p 426 $p->{child} = undef; 427 } 428 link_to_left_of $top->{left}, $el; 429 link_to_left_of $el, $top; 430 $el->{p} = undef; 431 $el->{mark} = 0; 432 433 # propagate up the list 434 $el = $p; 435 436 # quit at the top 437 last unless $p = $el->{p}; 438 439 # quit if we can mark $el 440 $el->{mark} = 1, last unless $el->{mark}; 441 } 442} 443 444 4451; 446 447__END__ 448 449=head1 NAME 450 451Heap::Fibonacci - a Perl extension for keeping data partially sorted 452 453=head1 SYNOPSIS 454 455 use Heap::Fibonacci; 456 457 $heap = Heap::Fibonacci->new; 458 # see Heap(3) for usage 459 460=head1 DESCRIPTION 461 462Keeps elements in heap order using a linked list of Fibonacci trees. 463The I<heap> method of an element is used to store a reference to 464the node in the list that refers to the element. 465 466See L<Heap> for details on using this module. 467 468=head1 AUTHOR 469 470John Macdonald, jmm@perlwolf.com 471 472=head1 COPYRIGHT 473 474Copyright 1998-2003, O'Reilly & Associates. 475 476This code is distributed under the same copyright terms as perl itself. 477 478=head1 SEE ALSO 479 480Heap(3), Heap::Elem(3). 481 482=cut 483