File Coverage

lib/Heap/Fibonacci.pm

Criterion	Covered	Total	%
statement	118	186	63.4
branch	32	76	42.1
condition	1	24	4.1
subroutine	14	23	60.8
pod	0	20	0.0
total	165	329	50.1

package Heap::Fibonacci;

use strict;
use vars qw($VERSION);

$VERSION = '0.80';

# 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 = \⊤

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;
    $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 {
	# 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__