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