tools/perl-5.8.0/lib/site_perl/5.8.0/Heap/Binary.pm

package Heap::Binary;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader);

# No names exported.
# No names available for export.
@EXPORT = ( );

$VERSION = '0.70';


# Preloaded methods go here.


# 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 = \&top;

# 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__

=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