Heap

#!/usr/bin/perl

sub heapup {
    my ($array, $index) = @_;
    my $value = $array->[$index];

    while ( $index ) {
        my $parent = int( ($index-1)/2 );
        my $pv = $array->[$parent];
        last if $pv lt $value;
        $array->[$index] = $pv;
        $index = $parent;
    }
    $array->[$index] = $value;
}

sub heapdown {
    my ($array, $index, $last) = @_;
    defined($last) or $last = $#$array;

    # Short-circuit if heap is now empty, or only one element
    # (if there is only one element in position 0, it
    # can't be out of order).
    return if $last <= 0;

    my $iv = $array->[$index];

    while ( $index < $last ) {
        my $child = 2*$index + 1;
        last if $child > $last;
        my $cv = $array->[$child];
        if ( $child < $last ) {
            my $cv2 = $array->[$child+1];
            if ( $cv2 lt $cv ) {
                $cv = $cv2;
                ++$child;
            }
        }
        last if $iv le $cv;
        $array->[$index] = $cv;
        $index = $child;
    }
    $array->[$index] = $iv;
}

sub heapify_array_up {
    my $array = shift;
    my $i;

    for ( $i = 1; $i < $#$array; ++$i ) {
        heapup( $array, $i );
    }
}

sub heapify_array_down {
    my $array = shift;
    my $last = $#$array;
    my $i;

    for ( $i = int( ($last-1)/2 ); $i >= 0; --$i ) {
        heapdown( $array, $i, $last );
    }
}

sub heapify {
    my ($array, $last) = @_;

    defined( $last ) or $last = $#$array;

    for ( my $i = int( ($last-1)/2 ); $i >= 0; --$i ) {
        heapdown( $array, $i, $last );
    }
}

sub extract {
    my $array = shift;
    my $last = shift || $#$array;

    # It had better not be empty to start.
    return undef if $last < 0;

    # No heap cleanup required if there is only one element.
    return pop(@$array) unless $last;

    # More than one, get the smallest.
    my $val = $array->[0];

    # Replace it with the tail element and bubble it down.
    $array->[0] = pop(@$array);
    heapdown( $array, 0 );

    return $val;
}

sub revsortheap {
    my $array = shift;
    my $i = $#$array;

    for ( $i = @$array; $i; ) {
        # Swap the smallest remaining element to the end.
        @$array[0,$i] = @$array[$i,0];
        # Maintain the heap, without touching the extracted element.
        heapdown( $array, 0, --$i );
    }
}

@heap = qw( toves slithy the and brillig Twas );
heapify( \@heap );