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

package Heap::Fibonacci;

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
#       el      - linkable element, contains user-provided value
#       v       - user-provided value

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

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;
    }
}


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

sub ascending_cut;
sub elem;
sub elem_DESTROY;
sub link_to_left_of;

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

# Cormen et al. use two values for the heap, a pointer to an element in the
# list at the top, and a count of the number of elements.  The count is only
# used to determine the size of array required to hold log(count) pointers,
# but perl can set array sizes as needed and doesn't need to know their size
# when they are created, so we're not maintaining that field.
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 = \&top;

sub extract_top {
    my $h = shift;
    my $el = $$h or return undef;
    my $ltop = $el->{left};
    my $cur;
    my $next;

    # $el is the heap with the lowest value on it
    # move all of $el's children (if any) to the top list (between
    # $ltop and $el)
    if( $cur = $el->{child} ) {
        # remember the beginning of the list of children
        my $first = $cur;
        do {
            # the children are moving to the top, clear the p
            # pointer for all of them
            $cur->{p} = undef;
        } until ($cur = $cur->{right}) == $first;

        # remember the end of the list
        $cur = $cur->{left};
        link_to_left_of $ltop, $first;
        link_to_left_of $cur, $el;
    }

    if( $el->{right} == $el ) {
        # $el had no siblings or children, the top only contains $el
        # and $el is being removed
        $$h = undef;
    } else {
        link_to_left_of $el->{left}, $$h = $el->{right};
        # now all those loose ends have to be merged together as we
        # search for the
        # new smallest element
        $h->consolidate;
    }

    # extract the actual value and return that, $el is no longer used
    # but break all of its links so that it won't be pointed to...
    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;

    # add $el2 and its siblings to the head list for $h
    # at start, $ell -> $el -> ... -> $ell is on $h (where $ell is
    #                           $el->{left})
    #           $el2l -> $el2 -> ... -> $el2l are on $h2
    # at end, $ell -> $el2l -> ... -> $el2 -> $el -> ... -> $ell are
    #                           all on $h
    my $el2l = $el2->{left};
    link_to_left_of $el->{left}, $el2;
    link_to_left_of $el2l, $el;

    # change the top link if needed
    $$h = $el2 if $el->{val}->cmp( $el2->{val} ) > 0;

    # clean out $h2
    $$h2 = undef;

    # return the heap
    $h;
}

# a key has been decreased, it may have to percolate up in its heap
sub decrease_key {
    my $h = shift;
    my $top = $$h;
    my $v = shift;
    my $el = $v->heap or return undef;
    my $p;

    # first, link $h to $el if it is now the smallest (we will
    # soon link $el to $top to properly put it up to the top list,
    # if it isn't already there)
    $$h = $el if $top->{val}->cmp( $v ) > 0;

    if( $p = $el->{p} and $v->cmp($p->{val}) < 0 ) {
        # remove $el from its parent's list - it is now smaller

        ascending_cut $top, $p, $el;
    }

    $v;
}


# to delete an item, we bubble it to the top of its heap (as if its key
# had been decreased to -infinity), and then remove it (as in extract_top)
sub delete {
    my $h = shift;
    my $v = shift;
    my $el = $v->heap or return undef;

    # if there is a parent, cut $el to the top (as if it had just had its
    # key decreased to a smaller value than $p's value
    my $p;
    $p = $el->{p} and ascending_cut $$h, $p, $el;

    # $el is in the top list now, make it look like the smallest and
    # remove it
    $$h = $el;
    $h->extract_top;
}


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

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;

    while( $el ) {
        $ch = $el->{child} and elem_DESTROY $ch;
        $next = $el->{right};

        $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 {
        # examine next item on top list
        $this = $cur = $next;
        $next = $cur->{right};
        my $d = $cur->{degree};
        my $alt;
        while( $alt = $a[$d] ) {
            # we already saw another item of the same degree,
            # put the larger valued one under the smaller valued
            # one - switch $cur and $alt if necessary so that $cur
            # is the smaller
            ($cur,$alt) = ($alt,$cur)
                if $cur->{val}->cmp( $alt->{val} ) > 0;
            # remove $alt from the top list
            link_to_left_of $alt->{left}, $alt->{right};
            # and put it under $cur
            link_as_parent_of $cur, $alt;
            # make sure that $h still points to a node at the top
            $$h = $cur;
            # we've removed the old $d degree entry
            $a[$d] = undef;
            # and we now have a $d+1 degree entry to try to insert
            # into @a
            ++$d;
        }
        # found a previously unused degree
        $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} ) {
            # there are still other children below $p
            my $l = $el->{left};
            $p->{child} = $l;
            link_to_left_of $l, $el->{right};
        } else {
            # $el was the only child of $p
            $p->{child} = undef;
        }
        link_to_left_of $top->{left}, $el;
        link_to_left_of $el, $top;
        $el->{p} = undef;
        $el->{mark} = 0;

        # propagate up the list
        $el = $p;

        # quit at the top
        last unless $p = $el->{p};

        # quit if we can mark $el
        $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