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