perllib/Heap071/Fibonacci.pm

   1 package Heap071::Fibonacci;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
   5
   6 require Exporter;
   7 require 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
  27 my $debug = 0;
  28 my $validate = 0;
  29
  30 # enable/disable debugging output
  31 sub debug {
  32     @_ ? ($debug = shift) : $debug;
  33 }
  34
  35 # enable/disable validation checks on values
  36 sub validate {
  37     @_ ? ($validate = shift) : $validate;
  38 }
  39
  40 my $width = 3;
  41 my $bar = ' | ';
  42 my $corner = ' +-';
  43 my $vfmt = "%3d";
  44
  45 sub 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
  55 sub hdump;
  56
  57 sub 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
  81 sub 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
  96 sub bhcheck;
  97
  98 sub 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
 121 sub 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
 133 sub ascending_cut;
 134 sub elem;
 135 sub elem_DESTROY;
 136 sub 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.
 145 sub new {
 146     my $self = shift;
 147     my $class = ref($self) || $self;
 148     my $h = undef;
 149     bless \$h, $class;
 150 }
 151
 152 sub DESTROY {
 153     my $h = shift;
 154
 155     elem_DESTROY $$h;
 156 }
 157
 158 sub 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
 178 sub top {
 179     my $h = shift;
 180     $$h && $$h->{val};
 181 }
 182
 183 *minimum = \&top;
 184
 185 sub 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
 233 sub 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
 267 sub 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)
 291 sub 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
 310 sub 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
 327 sub 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
 344 sub link_to_left_of {
 345     my $l = shift;
 346     my $r = shift;
 347
 348     $l->{right} = $r;
 349     $r->{left} = $l;
 350 }
 351
 352 sub 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
 371 sub 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
 413 sub 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
 445 1;
 446
 447 __END__
 448
 449 =head1 NAME
 450
 451 Heap::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
 462 Keeps elements in heap order using a linked list of Fibonacci trees.
 463 The I<heap> method of an element is used to store a reference to
 464 the node in the list that refers to the element.
 465
 466 See L<Heap> for details on using this module.
 467
 468 =head1 AUTHOR
 469
 470 John Macdonald, jmm@perlwolf.com
 471
 472 =head1 COPYRIGHT
 473
 474 Copyright 1998-2003, O'Reilly & Associates.
 475
 476 This code is distributed under the same copyright terms as perl itself.
 477
 478 =head1 SEE ALSO
 479
 480 Heap(3), Heap::Elem(3).
 481
 482 =cut