File Coverage

lib/Heap/Binary.pm

Criterion	Covered	Total	%
statement	64	116	55.1
branch	14	54	25.9
condition	7	9	77.7
subroutine	10	18	55.5
pod	0	16	0.0
total	95	213	44.6

package Heap::Binary;

use strict;
use vars qw($VERSION);

$VERSION = '0.80';

# common names:
#	h	- heap head
#	i	- index of a heap value element
#	v	- user-provided value (to be) stored on the heap

################################################# debugging control

my $debug = 0;
my $validate = 0;

# enable/disable debugging output
sub debug {
    @_ ? ($debug = shift) : $debug;
}

# enable/disable validation checks on values
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;
    }
}

################################################# forward declarations

sub moveto;
sub heapup;
sub heapdown;

################################################# heap methods

# new()                 usually Heap::Binary->new()
#	return a new empty heap
sub new {
    my $self = shift;
    my $class = ref($self) || $self;
    return bless [], $class;
}

# add($h,$v)            usually $h->add($v)
#	insert value $v into the heap
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;
}

# top($h)          usually $h->top
#	the smallest value is returned, but it is still left on the heap
sub top {
    my $h = shift;
    $h->[0];
}

*minimum = \⊤

# extract_top($h)          usually $h->extract_top
#	the smallest value is returned after removing it from the heap
sub extract_top {
    my $h = shift;
    my $top = $h->[0];
    if( @$h ) {
	# there was at least one item, must decrease the heap
	$top->heap(undef);
	my $last = pop(@$h);
	if( @$h ) {
	    # $top was not the only thing left, so re-heap the
	    # remainder by over-writing position zero (where
	    # $top was) using the value popped from the end
	    heapdown $h, 0, $last;
	}
    }
    $top;
}

*extract_minimum = \&extract_top;

# absorb($h,$h2)           usually $h->absorb($h2)
#	all of the values in $h2 are inserted into $h instead, $h2 is left
#	empty.
sub absorb {
    my $h = shift;
    my $h2 = shift;
    my $v;

    foreach $v (splice @$h2, 0) {
	$h->add($v);
    }
    $h;
}

# decrease_key($h,$v)       usually $h->decrease_key($v)
#	the key value of $v has just been decreased and so it may need to
#	be percolated to a higher position in the heap
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;
}

# delete($h,$v)       usually: $h->delete($v)
#	delete value $v from heap $h.  It must have previously been
#	add'ed to $h.
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 == $#$h ) {
	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;
}


################################################# internal utility functions

# moveto($h,$i,$v)
#	place value $v at index $i in the heap $h, and update it record
#	of where it is located
sub moveto {
    my $h = shift;
    my $i = shift;
    my $v = shift;

    $h->[$i] = $v;
    $v->heap($i);
}

# heapup($h,$i,$v)
#	value $v is to be placed at index $i in heap $h, but it might
#	be smaller than some of its parents.  Keep pushing parents down
#	until a smaller parent is found or the top of the heap is reached,
#	and then place $v there.
sub heapup {
    my $h = shift;
    my $i = shift;
    my $v = shift;
    my $pi;		# parent index

    while( $i && $v->cmp($h->[$pi = int( ($i-1)/2 )]) < 0 ) {
	moveto $h, $i, $h->[$pi];
	$i = $pi;
    }

    moveto $h, $i, $v;
    $v;
}

# heapdown($h,$i,$v)
#	value $v is to be placed at index $i in heap $h, but it might
#	have children that are smaller than it is.  Keep popping the smallest
#	child up until a pair of larger children is found or a leaf node is
#	reached, and then place $v there.
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__