package Heap::Fibonacci;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
require Exporter;
require AutoLoader;
@ISA = qw(Exporter AutoLoader);
@EXPORT = ( );
$VERSION = '0.71';
my $debug = 0;
my $validate = 0;
sub debug {
@_ ? ($debug = shift) : $debug;
}
sub validate {
@_ ? ($validate = shift) : $validate;
}
my $width = 3;
my $bar = ' | ';
my $corner = ' +-';
my $vfmt = "%3d";
sub set_width {
$width = shift;
$width = 2 if $width < 2;
$vfmt = "%${width}d";
$bar = $corner = ' ' x $width;
substr($bar,-2,1) = '|';
substr($corner,-2,2) = '+-';
}
sub hdump;
sub hdump {
my $el = shift;
my $l1 = shift;
my $b = shift;
my $ch;
my $ch1;
unless( $el ) {
print $l1, "\n";
return;
}
hdump $ch1 = $el->{child},
$l1 . sprintf( $vfmt, $el->{val}->val),
$b . $bar;
if( $ch1 ) {
for( $ch = $ch1->{right}; $ch != $ch1; $ch = $ch->{right} ) {
hdump $ch, $b . $corner, $b . $bar;
}
}
}
sub heapdump {
my $h;
while( $h = shift ) {
my $top = $$h or last;
my $el = $top;
do {
hdump $el, sprintf( "%02d: ", $el->{degree}), ' ';
$el = $el->{right};
} until $el == $top;
print "\n";
}
}
sub bhcheck;
sub bhcheck {
my $el = shift;
my $p = shift;
my $cur = $el;
my $prev;
my $ch;
do {
$prev = $cur;
$cur = $cur->{right};
die "bad back link" unless $cur->{left} == $prev;
die "bad parent link"
unless (defined $p && defined $cur->{p} && $cur->{p} == $p)
|| (!defined $p && !defined $cur->{p});
die "bad degree( $cur->{degree} > $p->{degree} )"
if $p && $p->{degree} <= $cur->{degree};
die "not heap ordered"
if $p && $p->{val}->cmp($cur->{val}) > 0;
$ch = $cur->{child} and bhcheck $ch, $cur;
} until $cur == $el;
}
sub heapcheck {
my $h;
my $el;
while( $h = shift ) {
heapdump $h if $validate >= 2;
$el = $$h and bhcheck $el, undef;
}
}
sub ascending_cut;
sub elem;
sub elem_DESTROY;
sub link_to_left_of;
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $h = undef;
bless \$h, $class;
}
sub DESTROY {
my $h = shift;
elem_DESTROY $$h;
}
sub add {
my $h = shift;
my $v = shift;
$validate && do {
die "Method 'heap' required for element on heap"
unless $v->can('heap');
die "Method 'cmp' required for element on heap"
unless $v->can('cmp');
};
my $el = elem $v;
my $top;
if( !($top = $$h) ) {
$$h = $el;
} else {
link_to_left_of $top->{left}, $el ;
link_to_left_of $el,$top;
$$h = $el if $v->cmp($top->{val}) < 0;
}
}
sub top {
my $h = shift;
$$h && $$h->{val};
}
*minimum = \⊤
sub extract_top {
my $h = shift;
my $el = $$h or return undef;
my $ltop = $el->{left};
my $cur;
my $next;
if( $cur = $el->{child} ) {
my $first = $cur;
do {
$cur->{p} = undef;
} until ($cur = $cur->{right}) == $first;
$cur = $cur->{left};
link_to_left_of $ltop, $first;
link_to_left_of $cur, $el;
}
if( $el->{right} == $el ) {
$$h = undef;
} else {
link_to_left_of $el->{left}, $$h = $el->{right};
$h->consolidate;
}
my $top = $el->{val};
$top->heap(undef);
$el->{left} = $el->{right} = $el->{p} = $el->{child} = $el->{val} =
undef;
$top;
}
*extract_minimum = \&extract_top;
sub absorb {
my $h = shift;
my $h2 = shift;
my $el = $$h;
unless( $el ) {
$$h = $$h2;
$$h2 = undef;
return $h;
}
my $el2 = $$h2 or return $h;
my $el2l = $el2->{left};
link_to_left_of $el->{left}, $el2;
link_to_left_of $el2l, $el;
$$h = $el2 if $el->{val}->cmp( $el2->{val} ) > 0;
$$h2 = undef;
$h;
}
sub decrease_key {
my $h = shift;
my $top = $$h;
my $v = shift;
my $el = $v->heap or return undef;
my $p;
$$h = $el if $top->{val}->cmp( $v ) > 0;
if( $p = $el->{p} and $v->cmp($p->{val}) < 0 ) {
ascending_cut $top, $p, $el;
}
$v;
}
sub delete {
my $h = shift;
my $v = shift;
my $el = $v->heap or return undef;
my $p;
$p = $el->{p} and ascending_cut $$h, $p, $el;
$$h = $el;
$h->extract_top;
}
sub elem {
my $v = shift;
my $el = undef;
$el = {
p => undef,
degree => 0,
mark => 0,
child => undef,
val => $v,
left => undef,
right => undef,
};
$el->{left} = $el->{right} = $el;
$v->heap($el);
$el;
}
sub elem_DESTROY {
my $el = shift;
my $ch;
my $next;
$el->{left}->{right} = undef;
while( $el ) {
$ch = $el->{child} and elem_DESTROY $ch;
$next = $el->{right};
defined $el->{val} and $el->{val}->heap(undef);
$el->{child} = $el->{right} = $el->{left} = $el->{p} = $el->{val}
= undef;
$el = $next;
}
}
sub link_to_left_of {
my $l = shift;
my $r = shift;
$l->{right} = $r;
$r->{left} = $l;
}
sub link_as_parent_of {
my $p = shift;
my $c = shift;
my $pc;
if( $pc = $p->{child} ) {
link_to_left_of $pc->{left}, $c;
link_to_left_of $c, $pc;
} else {
link_to_left_of $c, $c;
}
$p->{child} = $c;
$c->{p} = $p;
$p->{degree}++;
$c->{mark} = 0;
$p;
}
sub consolidate {
my $h = shift;
my $cur;
my $this;
my $next = $$h;
my $last = $next->{left};
my @a;
do {
$this = $cur = $next;
$next = $cur->{right};
my $d = $cur->{degree};
my $alt;
while( $alt = $a[$d] ) {
($cur,$alt) = ($alt,$cur)
if $cur->{val}->cmp( $alt->{val} ) > 0;
link_to_left_of $alt->{left}, $alt->{right};
link_as_parent_of $cur, $alt;
$$h = $cur;
$a[$d] = undef;
++$d;
}
$a[$d] = $cur;
} until $this == $last;
$cur = $$h;
for $cur (grep defined, @a) {
$$h = $cur if $$h->{val}->cmp( $cur->{val} ) > 0;
}
}
sub ascending_cut {
my $top = shift;
my $p = shift;
my $el = shift;
while( 1 ) {
if( --$p->{degree} ) {
my $l = $el->{left};
$p->{child} = $l;
link_to_left_of $l, $el->{right};
} else {
$p->{child} = undef;
}
link_to_left_of $top->{left}, $el;
link_to_left_of $el, $top;
$el->{p} = undef;
$el->{mark} = 0;
$el = $p;
last unless $p = $el->{p};
$el->{mark} = 1, last unless $el->{mark};
}
}
1;
__END__
=head1 NAME
Heap::Fibonacci - a Perl extension for keeping data partially sorted
=head1 SYNOPSIS
use Heap::Fibonacci;
$heap = Heap::Fibonacci->new;
# see Heap(3) for usage
=head1 DESCRIPTION
Keeps elements in heap order using a linked list of Fibonacci trees.
The I<heap> method of an element is used to store a reference to
the node in the list that refers to the element.
See L<Heap> for details on using this module.
=head1 AUTHOR
John Macdonald, jmm@perlwolf.com
=head1 COPYRIGHT
Copyright 1998-2003, O'Reilly & Associates.
This code is distributed under the same copyright terms as perl itself.
=head1 SEE ALSO
Heap(3), Heap::Elem(3).
=cut