package Heap::Binary;
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 {
my $h = shift;
my $i = shift;
my $p = shift;
my $ch = $i*2+1;
return if $i >= @$h;
my $space = ' ' x $width;
printf( "%${width}d", $h->[$i]->val );
if( $ch+1 < @$h ) {
hdump( $h, $ch, $p . $bar);
print( $p, $corner );
++$ch;
}
if( $ch < @$h ) {
hdump( $h, $ch, $p . $space );
} else {
print "\n";
}
}
sub heapdump {
my $h;
while( $h = shift ) {
hdump $h, 0, '';
print "\n";
}
}
sub heapcheck {
my $h;
while( $h = shift ) {
my $i;
my $p;
next unless @$h;
for( $p = 0, $i = 1; $i < @$h; ++$p, ++$i ) {
$h->[$p]->cmp($h->[$i]) <= 0 or die "not in heap order";
last unless ++$i < @$h;
$h->[$p]->cmp($h->[$i]) <= 0 or die "not in heap order";
}
heapdump $h if $validate >= 2;
}
}
sub moveto;
sub heapup;
sub heapdown;
sub new {
my $self = shift;
my $class = ref($self) || $self;
return bless [], $class;
}
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');
};
heapup $h, scalar(@$h), $v;
}
sub top {
my $h = shift;
$h->[0];
}
*minimum = \⊤
sub extract_top {
my $h = shift;
my $top = $h->[0];
if( @$h ) {
$top->heap(undef);
my $last = pop(@$h);
if( @$h ) {
heapdown $h, 0, $last;
}
}
$top;
}
*extract_minimum = \&extract_top;
sub absorb {
my $h = shift;
my $h2 = shift;
my $v;
foreach $v (splice @$h2, 0) {
$h->add($v);
}
$h;
}
sub decrease_key {
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 $i = $v->heap;
heapup $h, $i, $v;
}
sub delete {
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 $i = $v->heap;
return $v unless defined $i;
if( $i == $ pop @$h;
} else {
my $v2 = pop @$h;
if( $v2->cmp($v) < 0 ) {
heapup $h, $i, $v2;
} else {
heapdown $h, $i, $v2;
}
}
$v->heap(undef);
return $v;
}
sub moveto {
my $h = shift;
my $i = shift;
my $v = shift;
$h->[$i] = $v;
$v->heap($i);
}
sub heapup {
my $h = shift;
my $i = shift;
my $v = shift;
my $pi;
while( $i && $v->cmp($h->[$pi = int( ($i-1)/2 )]) < 0 ) {
moveto $h, $i, $h->[$pi];
$i = $pi;
}
moveto $h, $i, $v;
$v;
}
sub heapdown {
my $h = shift;
my $i = shift;
my $v = shift;
my $leaf = int(@$h/2);
while( $i < $leaf ) {
my $j = $i*2+1;
my $k = $j+1;
$j = $k if $k < @$h && $h->[$k]->cmp($h->[$j]) < 0;
if( $v->cmp($h->[$j]) > 0 ) {
moveto $h, $i, $h->[$j];
$i = $j;
next;
}
last;
}
moveto $h, $i, $v;
}
1;
__END__
=head1 NAME
Heap::Binary - a Perl extension for keeping data partially sorted
=head1 SYNOPSIS
use Heap::Binary;
$heap = Heap::Binary->new;
# see Heap(3) for usage
=head1 DESCRIPTION
Keeps an array of elements in heap order. The I<heap> method
of an element is used to store the index into the array 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