1package Heap::Binomial; 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 21# common names 22# h - heap head 23# el - linkable element, contains user-provided value 24# v - user-provided value 25 26################################################# debugging control 27 28my $debug = 0; 29my $validate = 0; 30 31# enable/disable debugging output 32sub debug { 33 @_ ? ($debug = shift) : $debug; 34} 35 36# enable/disable validation checks on values 37sub validate { 38 @_ ? ($validate = shift) : $validate; 39} 40 41my $width = 3; 42my $bar = ' | '; 43my $corner = ' +-'; 44my $vfmt = "%3d"; 45 46sub set_width { 47 $width = shift; 48 $width = 2 if $width < 2; 49 50 $vfmt = "%${width}d"; 51 $bar = $corner = ' ' x $width; 52 substr($bar,-2,1) = '|'; 53 substr($corner,-2,2) = '+-'; 54} 55 56sub hdump { 57 my $el = shift; 58 my $l1 = shift; 59 my $b = shift; 60 61 my $ch; 62 63 unless( $el ) { 64 print $l1, "\n"; 65 return; 66 } 67 68 hdump( $ch = $el->{child}, 69 $l1 . sprintf( $vfmt, $el->{val}->val), 70 $b . $bar ); 71 72 while( $ch = $ch->{sib} ) { 73 hdump( $ch, $b . $corner, $b . $bar ); 74 } 75} 76 77sub heapdump { 78 my $h; 79 80 while( $h = shift ) { 81 my $el; 82 83 for( $el = $$h; $el; $el = $el->{sib} ) { 84 hdump( $el, sprintf( "%02d: ", $el->{degree}), ' ' ); 85 } 86 print "\n"; 87 } 88} 89 90sub bhcheck { 91 92 my $pel = shift; 93 my $pdeg = $pel->{degree}; 94 my $pv = $pel->{val}; 95 my $cel; 96 for( $cel = $pel->{child}; $cel; $cel = $cel->{sib} ) { 97 die "degree not decreasing in heap" 98 unless --$pdeg == $cel->{degree}; 99 die "heap order not preserved" 100 unless $pv->cmp($cel->{val}) <= 0; 101 bhcheck($cel); 102 } 103 die "degree did not decrease to zero" 104 unless $pdeg == 0; 105} 106 107 108sub heapcheck { 109 my $h; 110 while( $h = shift ) { 111 heapdump $h if $validate >= 2; 112 my $el = $$h or next; 113 my $pdeg = -1; 114 for( ; $el; $el = $el->{sib} ) { 115 $el->{degree} > $pdeg 116 or die "degree not increasing in list"; 117 $pdeg = $el->{degree}; 118 bhcheck($el); 119 } 120 } 121} 122 123 124################################################# forward declarations 125 126sub elem; 127sub elem_DESTROY; 128sub link_to; 129sub moveto; 130 131################################################# heap methods 132 133 134sub new { 135 my $self = shift; 136 my $class = ref($self) || $self; 137 my $h = undef; 138 bless \$h, $class; 139} 140 141sub DESTROY { 142 my $h = shift; 143 144 elem_DESTROY $$h; 145} 146 147sub add { 148 my $h = shift; 149 my $v = shift; 150 $validate && do { 151 die "Method 'heap' required for element on heap" 152 unless $v->can('heap'); 153 die "Method 'cmp' required for element on heap" 154 unless $v->can('cmp'); 155 }; 156 $$h = elem $v, $$h; 157 $h->self_union_once; 158} 159 160sub top { 161 my $h = shift; 162 my $el = $$h or return undef; 163 my $top = $el->{val}; 164 while( $el = $el->{sib} ) { 165 $top = $el->{val} 166 if $top->cmp($el->{val}) > 0; 167 } 168 $top; 169} 170 171*minimum = \⊤ 172 173sub extract_top { 174 my $h = shift; 175 my $mel = $$h or return undef; 176 my $top = $mel->{val}; 177 my $mpred = $h; 178 my $el = $mel; 179 my $pred = $h; 180 181 # find the heap with the lowest value on it 182 while( $pred = \$el->{sib}, $el = $$pred ) { 183 if( $top->cmp($el->{val}) > 0 ) { 184 $top = $el->{val}; 185 $mel = $el; 186 $mpred = $pred; 187 } 188 } 189 190 # found it, $mpred points to it, $mel is its container, $val is it 191 # unlink it from the chain 192 $$mpred = $mel->{sib}; 193 194 # we're going to return the value from $mel, but all of its children 195 # must be retained in the heap. Make a second heap with the children 196 # and then merge the heaps. 197 $h->absorb_children($mel); 198 199 # finally break all of its pointers, so that we won't leave any 200 # memory loops when we forget about the pointer to $mel 201 $mel->{p} = $mel->{child} = $mel->{sib} = $mel->{val} = undef; 202 203 # break the back link 204 $top->heap(undef); 205 206 # and return the value 207 $top; 208} 209 210*extract_minimum = \&extract_top; 211 212sub absorb { 213 my $h = shift; 214 my $h2 = shift; 215 216 my $dest_link = $h; 217 my $el1 = $$h; 218 my $el2 = $$h2; 219 my $anymerge = $el1 && $el2; 220 while( $el1 && $el2 ) { 221 if( $el1->{degree} <= $el2->{degree} ) { 222 # advance on h's list, it's already linked 223 $dest_link = \$el1->{sib}; 224 $el1 = $$dest_link; 225 } else { 226 # move next h2 elem to head of h list 227 $$dest_link = $el2; 228 $dest_link = \$el2->{sib}; 229 $el2 = $$dest_link; 230 $$dest_link = $el1; 231 } 232 } 233 234 # if h ran out first, move rest of h2 onto end 235 if( $el2 ) { 236 $$dest_link = $el2; 237 } 238 239 # clean out h2, all of its elements have been move to h 240 $$h2 = undef; 241 242 # fix up h - it can have multiple items at the same degree if we 243 # actually merged two non-empty lists 244 $anymerge ? $h->self_union: $h; 245} 246 247# a key has been decreased, it may have to percolate up in its heap 248sub decrease_key { 249 my $h = shift; 250 my $v = shift; 251 my $el = $v->heap or return undef; 252 my $p; 253 254 while( $p = $el->{p} ) { 255 last if $v->cmp($p->{val}) >= 0; 256 moveto $el, $p->{val}; 257 $el = $p; 258 } 259 260 moveto $el, $v; 261 262 $v; 263} 264 265# to delete an item, we bubble it to the top of its heap (as if its key 266# had been decreased to -infinity), and then remove it (as in extract_top) 267sub delete { 268 my $h = shift; 269 my $v = shift; 270 my $el = $v->heap or return undef; 271 272 # bubble it to the top of its heap 273 my $p; 274 while( $p = $el->{p} ) { 275 moveto $el, $p->{val}; 276 $el = $p; 277 } 278 279 # find it on the main list, to remove it and split up the children 280 my $n; 281 for( $p = $h; ($n = $$p) && $n != $el; $p = \$n->{sib} ) { 282 ; 283 } 284 285 # remove it from the main list 286 $$p = $el->{sib}; 287 288 # put any children back onto the main list 289 $h->absorb_children($el); 290 291 # remove the link to $el 292 $v->heap(undef); 293 294 return $v; 295} 296 297 298################################################# internal utility functions 299 300sub elem { 301 my $v = shift; 302 my $sib = shift; 303 my $el = { 304 p => undef, 305 degree => 0, 306 child => undef, 307 val => $v, 308 sib => $sib, 309 }; 310 $v->heap($el); 311 $el; 312} 313 314sub elem_DESTROY { 315 my $el = shift; 316 my $ch; 317 my $next; 318 319 while( $el ) { 320 $ch = $el->{child} and elem_DESTROY $ch; 321 $next = $el->{sib}; 322 323 $el->{val}->heap(undef); 324 $el->{child} = $el->{sib} = $el->{p} = $el->{val} = undef; 325 $el = $next; 326 } 327} 328 329sub link_to { 330 my $el = shift; 331 my $p = shift; 332 333 $el->{p} = $p; 334 $el->{sib} = $p->{child}; 335 $p->{child} = $el; 336 $p->{degree}++; 337} 338 339sub moveto { 340 my $el = shift; 341 my $v = shift; 342 343 $el->{val} = $v; 344 $v->heap($el); 345} 346 347# we've merged two lists in degree order. Traverse the list and link 348# together any pairs (adding 1 + 1 to get 10 in binary) to the next 349# higher degree. After such a merge, there may be a triple at the 350# next degree - skip one and merge the others (adding 1 + 1 + carry 351# of 1 to get 11 in binary). 352sub self_union { 353 my $h = shift; 354 my $prev = $h; 355 my $cur = $$h; 356 my $next; 357 my $n2; 358 359 while( $next = $cur->{sib} ) { 360 if( $cur->{degree} != $next->{degree} ) { 361 $prev = \$cur->{sib}; 362 $cur = $next; 363 next; 364 } 365 366 # two or three of same degree, need to do a merge. First though, 367 # skip over the leading one of there are three (it is the result 368 # [carry] from the previous merge) 369 if( ($n2 = $next->{sib}) && $n2->{degree} == $cur->{degree} ) { 370 $prev = \$cur->{sib}; 371 $cur = $next; 372 $next = $n2; 373 } 374 375 # and now the merge 376 if( $cur->{val}->cmp($next->{val}) <= 0 ) { 377 $cur->{sib} = $next->{sib}; 378 link_to $next, $cur; 379 } else { 380 $$prev = $next; 381 link_to $cur, $next; 382 $cur = $next; 383 } 384 } 385 $h; 386} 387 388# we've added one element at the front, keep merging pairs until there isn't 389# one of the same degree (change all the low order one bits to zero and the 390# lowest order zero bit to one) 391sub self_union_once { 392 my $h = shift; 393 my $cur = $$h; 394 my $next; 395 396 while( $next = $cur->{sib} ) { 397 return if $cur->{degree} != $next->{degree}; 398 399 # merge 400 if( $cur->{val}->cmp($next->{val}) <= 0 ) { 401 $cur->{sib} = $next->{sib}; 402 link_to $next, $cur; 403 } else { 404 $$h = $next; 405 link_to $cur, $next; 406 $cur = $next; 407 } 408 } 409 $h; 410} 411 412# absorb all the children of an element into a heap 413sub absorb_children { 414 my $h = shift; 415 my $el = shift; 416 417 my $h2 = $h->new; 418 my $child = $el->{child}; 419 while( $child ) { 420 my $sib = $child->{sib}; 421 $child->{sib} = $$h2; 422 $child->{p} = undef; 423 $$h2 = $child; 424 $child = $sib; 425 } 426 427 # merge them all in 428 $h->absorb($h2); 429} 430 431 4321; 433 434__END__ 435 436=head1 NAME 437 438Heap::Binomial - a Perl extension for keeping data partially sorted 439 440=head1 SYNOPSIS 441 442 use Heap::Binomial; 443 444 $heap = Heap::Binomial->new; 445 # see Heap(3) for usage 446 447=head1 DESCRIPTION 448 449Keeps elements in heap order using a linked list of binomial trees. 450The I<heap> method of an element is used to store a reference to 451the node in the list that refers to the element. 452 453See L<Heap> for details on using this module. 454 455=head1 AUTHOR 456 457John Macdonald, jmm@perlwolf.com 458 459=head1 COPYRIGHT 460 461Copyright 1998-2003, O'Reilly & Associates. 462 463This code is distributed under the same copyright terms as perl itself. 464 465=head1 SEE ALSO 466 467Heap(3), Heap::Elem(3). 468 469=cut 470