File Coverage

blib/lib/Heap/MinMax.pm

Criterion	Covered	Total	%
statement	264	397	66.5
branch	92	164	56.1
condition	4	15	26.6
subroutine	32	42	76.1
pod	13	39	33.3
total	405	657	61.6

#
# MinMax.pm
#
# An implementation of a Min-Max Binary Heap, based on 1986 article
# "Min-Max Heaps and Generalized Priority Queues" by Atkinson, Sack,
# Santoro, and Strothotte, published in Communications of the ACM.
#
# In a Min-Max heap, objects are stored in partial order such that both the
# minimum element and maximum element are available in constant time.  This
# is accomplished through a modification of the standard heap algorithm that
# introduces the notion of 'min' (even) levels and 'max' (odd) levels in the
# binary tree structure of the heap.
#
# With a Min-Max heap you get all this, plus insertion into a Min-Max heap is
# actually *faster* than with a normal heap (by a constant factor of 0.5).
#
#
package Heap::MinMax;

use Carp;
use strict;
use warnings;


our $VERSION = '1.04';



##################################################
#  the MinMax Heap constructor
##################################################
sub new {
    my $invocant = shift;
    my $class   = ref($invocant) || $invocant;
    my $self = {
        _arr      => [],   # Array containing heap
	fcompare  => \&default_cmp_func,
	feval     => \&default_eval,
        @_,    # Override previous attributes
    };
    $self = bless $self, $class;
    return $self;
}

##############################################
# accessor methods
##############################################

sub array
{
    my $self = shift;
    if (@_) { $self->{_arr} = shift }
    return $self->{_arr};
}




#=========================================================================
#
# main heap functions
#
#=========================================================================


##########################################################################
#
# build_heap
#
# $mm_heap->build_heap();
#
# builds a heap from MinMax object's array
#
##########################################################################
sub build_heap
{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $arr_length = @$array;
    my $val;

    for(my $i = $arr_length/2; $i >= 0; $i--){
	$val = $self->trickledown($i);
    }
    return $val;
}

##########################################################################
#
# insert
#
# $mm_heap->insert($value);
# $mm_heap->insert(@values);
#
# Insertion works by placing the new node in the first available
# leaf position and then calling bubble_up to re-establish min-max
# ordering of the heap.
#
##########################################################################
sub insert
{
    my ($self,
	@values) = @_;

    while(defined(my $val = shift(@values))){
	my $array = $self->{_arr};
	push(@$array, $val); # put the new element in the next available leaf slot
	my $arr_length = @$array;
	my $index = $arr_length - 1;

	# call bubble_up
	$self->bubble_up($index);
    }
}

#########################################################################
#
# remove
#
# $mm_heap->remove($object);
#
# Not the same as pop_.  really expensive arbitrary remove
# operation that iterates over the array and finds the object it needs,
# removes it, then calls trickledown from the index where the object
# was found to re-establish min-max ordering of the heap.
#
#########################################################################
sub remove
{
    my ($self,
	$obj) = @_;


    my ($pkg, $filename, $line) = caller();

    my $array = $self->{_arr};
    my $arr_length = @$array;
    my $evalfunc = $self->{feval};
    my $value = $evalfunc->($obj);

    my $index;

    my $i = 0;
    foreach my $elt (@$array){

	if($self->{fcompare}->($obj, $elt) == 0){
	    $index = $i;
	    last;
	}
	$i++;
    }

    if(defined $index){
	my $obj = $array->[$index];

	$array->[$index] = $array->[$arr_length-1];
	pop(@$array);

	$self->trickledown($index);

	return $obj;
    }
    return;
}

############################################################
#
# min
#
# my $min_obj = $mm_heap->min();
#
# return the minimum object in heap
#
############################################################
sub min
{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $arr_length = @$array;

    #array is empty
    if(!$arr_length){
	return;
    }

    my $top = $array->[0];
    return $top;
}

############################################################
#
# pop_min
#
# my $min_obj = $mm_heap->pop_min();
#
# pop the minimum object from the heap and return it
#
############################################################
sub pop_min
{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $arr_length = @$array;

    #array is empty
    if(!$arr_length){
	return;
    }

    my $top = $array->[0];

    $array->[0] = $array->[$arr_length-1];
    pop(@$array);

    $self->trickledown(0);
    return $top;
}


############################################################
#
# min_non_zero
#
# my $min_obj = $mm_heap->min_no_zero();
#
# get minimum, non-zero valued object from the heap
# and return it.   This only makes sense if you have an
# evaluation function that can return 0.
#
############################################################
sub min_non_zero # the smallest non-zero element
{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $arr_length = @$array;
    my $evalfunc = $self->{feval};
    my $index = 0;

    #array is empty
    if(!$arr_length){
	return;
    }

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

    if($evalfunc->($top) == 0){ # find min of grandchildren
	my $n = 0;
	my $smallest;
	for my $i (3,4,5,6) {
	    if($n == 0){
		$smallest = $i;
		$n++;
	    }
	    else{
		if($array->[$i] && $self->{fcompare}->($array->[$i], $array->[$smallest]) == -1){
		    $smallest = $i;
		}
	    }
	}
	$index = $smallest;
    }

    $top = $array->[$index];

    return $top;
}


############################################################
#
# pop_min_non_zero
#
# my $min_obj = $mm_heap->pop_min_no_zero();
#
# pop the minimum, non-zero valued object from the heap
# and return it.   This only makes sense if you have an
# evaluation function that can return 0.
#
############################################################
sub pop_min_non_zero # pop the smallest non-zero element
{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $arr_length = @$array;
    my $evalfunc = $self->{feval};
    my $index = 0;

    #array is empty
    if(!$arr_length){
	return;
    }

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

    if($evalfunc->($top) == 0){ # find min of grandchildren
	my $n = 0;
	my $smallest;
	for my $i (3,4,5,6) {
	    if($n == 0){
		$smallest = $i;
		$n++;
	    }
	    else{
		if($array->[$i] && $self->{fcompare}->($array->[$i], $array->[$smallest]) == -1){
		    $smallest = $i;
		}
	    }
	}
	$index = $smallest;
    }

    $top = $array->[$index];
    $array->[$index] = $array->[$arr_length-1];
    pop(@$array);
    $self->trickledown($index);

    return $top;
}

############################################################
#
# max
#
# my $max_obj = $mm_heap->max();
#
# get maximum object in the heap and return it
#
############################################################
sub max
{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $arr_length = @$array;
    my $evalfunc = $self->{feval};

    #array is empty
    if(!$arr_length){
	return;
    }

    # array has only one element
    if($arr_length == 1){
	return $array->[0];
    }

    # array has only two elements
    if($arr_length == 2){
	return $array->[1];
    }

    my $result = $self->{fcompare}->($array->[1], $array->[2]);
    my $max_index = ($result >= 0) ? 1 : 2;
    my $top = $array->[$max_index];

    return $top;
}



############################################################
#
# pop_max
#
# my $max_obj = $mm_heap->pop_max();
#
# pop the maximum object from the heap and return it
#
############################################################
sub pop_max
{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $arr_length = @$array;
    my $evalfunc = $self->{feval};

    my $top;
    my $max_index;

    #array is empty
    if(!$arr_length){
	return;
    }

     # array has only one element
    if($arr_length == 1){
	$max_index =  0;
    }
    # array has only two elements
    elsif($arr_length == 2){
	$max_index = 1;
    }
    else{
	my $result = $self->{fcompare}->($array->[1], $array->[2]);
        $max_index = ($result >= 0) ? 1 : 2;
    }

    $top = $array->[$max_index];

    $array->[$max_index] = $array->[$arr_length-1];
    pop(@$array);

    $self->trickledown($max_index);

    return $top;
}





############################################################
#
# trickledown() is called during heap construction.   it
# determines whether current level is a min-level or max-level,
# and calls the appropriate trickledown{min,max}() function.
#
############################################################
sub trickledown
{
    my ($self, $i) = @_;
    my $array = $self->{_arr};

    if($i >= @$array){
	return;
    }
    my $level = $self->get_level($i);

    if($level == 0){
	$self->trickledown_min($i);
    }
    elsif(($level % 2) == 0){
	$self->trickledown_min($i);
    }
    else{
	$self->trickledown_max($i);
    }
    return;
}

############################################################
#
# trickledown_min is called during heap construction when examining
# a subtree rooted at an even level.  Compares the values of the root
# node with the smallest of its children and grand-children.
# if the root node is larger, the values are swapped and the
# function recurses.
#
#
# Note: this function is very similar to trickle_down_max, but
# they are kept separate for purposes of readability.
#
############################################################
sub trickledown_min
{
       my ($self, $index) = @_;
       my $array = $self->{_arr};
       my $m = $self->get_smallest_descendant_index($index);

       my $level = $self->get_level($index);

       if(!$m){
	   return;
       }

       if($self->is_grandchild($index, $m)){
	   if($self->{fcompare}->($array->[$m], $array->[$index]) == -1){
	       $self->swap($index, $m);

	       if($self->{fcompare}->($array->[$m], $self->parent($m)) == 1){
		   my $parent_index = $self->parent_node_index($m);
		   $self->swap($m, $parent_index);
	       }

	       $self->trickledown_min($m);
	   }
       }
       elsif($self->{fcompare}->($array->[$m], $array->[$index]) == -1){
      	   $self->swap($index, $m);
       }
}

############################################################
#
# trickledown_max is called during heap construction when examining
# a subtree rooted at an odd level.  Compares the values of the root
# node with the largest of its children and grand-children.
# if the root node is smaller, the values are swapped and the
# function recurses.
#
#
# Note: this function is very similar to trickle_down_min, but
# they are kept separate for purposes of readability.
#
############################################################
sub trickledown_max
{
       my ($self, $index) = @_;
       my $array = $self->{_arr};
       my $m = $self->get_largest_descendant_index($index);

       my $level = $self->get_level($index);

       if(!$m){ return; }

       if($self->is_grandchild($index, $m)){
	   if($self->{fcompare}->($array->[$m], $array->[$index]) == 1){
	       $self->swap($m, $index);

	       if($self->{fcompare}->($array->[$m], $self->parent($m)) == -1){
		   my $parent_index = $self->parent_node_index($m);
		   $self->swap($m, $parent_index);
	       }

	       $self->trickledown_max($m);
	   }
       }
       elsif($self->{fcompare}->($array->[$m], $array->[$index]) == 1){
	   $self->swap($index, $m);
       }
}

############################################################
#
# bubble_up() is  called during insertion.  determines whether the
# current level is an even (min) or odd (max) level, and
# then either calls bubble_up_min or bubble_up_max.
#
#
############################################################
sub bubble_up
{
    my ($self, $i) = @_;
    my $array = $self->{_arr};

    my $level = $self->get_level($i);

    if(($level % 2) == 0){
	if($self->has_parent($i) != -1){
	    my $parent_index = $self->parent_node_index($i);

	    if($self->{fcompare}->($array->[$i], $array->[$parent_index]) == 1){
		$self->swap($i, $parent_index);
		$self->bubble_up_max($parent_index);
	    }
	    else{
		$self->bubble_up_min($i);
	    }
	}
    }
    else{
	if($self->has_parent($i) != -1){
	    my $parent_index = $self->parent_node_index($i);

	    if($self->{fcompare}->($array->[$i], $array->[$parent_index]) == -1){
		$self->swap($i, $parent_index);
		$self->bubble_up_min($parent_index);
	    }
	    else{
		$self->bubble_up_max($i);
	    }
	}
    }
}

############################################################
#
# bubble_up_min is called during insertion. after inserting
# a new leaf on the heap, the object is then "bubbled-up" to
# maintain heap-ness.
#
# Note: this function is *very* similar to bubble_up_max, but
# they are kept separate for purposes of readability.
#
############################################################
sub bubble_up_min
{
    my ($self, $i) = @_;
    my $array = $self->{_arr};

    if($self->has_grandparent($i)){
	my $gp_index = $self->grandparent_node_index($i);

	if($self->{fcompare}->($array->[$i], $array->[$gp_index]) == -1){
	    $self->swap($i, $gp_index);
	    $self->bubble_up_min($gp_index);
	}
    }
}

############################################################
#
# bubble_up_max is called during insertion.   after inserting
# a new leaf on the heap, the object is then "bubbled-up" to
# maintain heap-ness.
#
# Note: this function is *very* similar to bubble_up_min, but
# they are kept separate for purposes of readability.
#
############################################################
sub bubble_up_max
{
    my ($self, $i) = @_;
    my $array = $self->{_arr};

    if($self->has_grandparent($i)){
	my $gp_index = $self->grandparent_node_index($i);

	if($self->{fcompare}->($array->[$i], $array->[$gp_index]) == 1){
	    $self->swap($i, $gp_index);
	    $self->bubble_up_max($gp_index);
	}
    }
}



############################################################
#
# swap two elements in the array
#
############################################################
sub swap
{
    my ($self, $m, $index) = @_;
    my $array = $self->{_arr};

    if($m <  @$array && $index <  @$array){
	 my $tmp = $array->[$index];
	 $array->[$index] =  $array->[$m];
	 $array->[$m] =  $tmp;
    }

    $self->{_arr} = $array;
}



############################################################
#
# get_smallest_descendant_index() returns the index of the
# smallest descendant of this node.
#
############################################################
sub get_smallest_descendant_index
{
    my ($self, $index) = @_;
    my $array = $self->{_arr};

    if($self->has_children($index)){ # if has children
	my %descendants;

	# right node and right node descendants
	my $rightnode = $self->right_node($index);
	my $r_index = $self->right_node_index($index);

	if($rightnode){
	    $descendants{$r_index} = $rightnode;
	}

	my $right_leftnode = $self->left_node($r_index);
	my $right_leftnode_index = $self->left_node_index($r_index);

	if($right_leftnode){
	    $descendants{$right_leftnode_index} = $right_leftnode;
	}

	my $right_rightnode = $self->right_node($r_index);
	my $right_rightnode_index = $self->right_node_index($r_index);

	if($right_rightnode){
	    $descendants{$right_rightnode_index} = $right_rightnode;
	}

	# left node and left node descendants
	my $leftnode = $self->left_node($index);
	my $l_index = $self->left_node_index($index);

	if($leftnode){
	    $descendants{$l_index} = $leftnode;
	}

	my $left_leftnode = $self->left_node($l_index);
	my $left_leftnode_index = $self->left_node_index($l_index);

	if($left_leftnode){
	    $descendants{$left_leftnode_index} = $left_leftnode;
	}

	my $left_rightnode = $self->right_node($l_index);
	my $left_rightnode_index = $self->right_node_index($l_index);
	if($left_rightnode){
	    $descendants{$left_rightnode_index} = $left_rightnode;
	}

	my $index;

	# extract minimum
	my $min_descendant;
	my $i = 0;
	foreach my $key (keys %descendants){
	    if($i == 0){
		$min_descendant = $descendants{$key};

		$index = $key;
		$i++;
	    }
	    elsif($self->{fcompare}->($descendants{$key}, $min_descendant) == -1){
		$min_descendant = $descendants{$key};
		$index = $key;
	    }
	}
	return $index;
    }

    return;
}


############################################################
#
# get_largest_descendant_index() returns the index of the
# largest descendant of this node.
#
############################################################
sub get_largest_descendant_index
{
    my ($self, $index) = @_;
    my $array = $self->{_arr};

    if($self->has_children($index)){ # if has children
	my %descendants;

	# right node and right node descendants
	my $rightnode = $self->right_node($index);
	my $r_index = $self->right_node_index($index);

	if($rightnode){
	    $descendants{$r_index} = $rightnode;
	}

	my $right_leftnode = $self->left_node($r_index);
	my $right_leftnode_index = $self->left_node_index($r_index);

	if($right_leftnode){
	    $descendants{$right_leftnode_index} = $right_leftnode;
	}

	my $right_rightnode = $self->right_node($r_index);
	my $right_rightnode_index = $self->right_node_index($r_index);

	if($right_rightnode){
	    $descendants{$right_rightnode_index} = $right_rightnode;
	}

	# left node and left node descendants
	my $leftnode = $self->left_node($index);
	my $l_index = $self->left_node_index($index);

	if($leftnode){
	    $descendants{$l_index} = $leftnode;
	}

	my $left_leftnode = $self->left_node($l_index);
	my $left_leftnode_index = $self->left_node_index($l_index);

	if($left_leftnode){
	    $descendants{$left_leftnode_index} = $left_leftnode;
	}

	my $left_rightnode = $self->right_node($l_index);
	my $left_rightnode_index = $self->right_node_index($l_index);
	if($left_rightnode){
	    $descendants{$left_rightnode_index} = $left_rightnode;
	}

	my $index;

	# extract maximum
	my $max_descendant;
	my $i = 0;

	foreach my $key (keys %descendants){
	    if($i == 0){
		$max_descendant = $descendants{$key};

		$index = $key;
		$i++;
	    }
	    elsif($self->{fcompare}->($descendants{$key}, $max_descendant) == 1){
		$max_descendant = $descendants{$key};
		$index = $key;
	    }
	}

	return $index;
    }

    return;
}





################################################
#
# utilities for the heap algorithms
#
################################################
sub default_cmp_func
{
    my ($obj1, $obj2) = @_;

    if(fp_equal($obj1, $obj2, 10)){
	return 0;
    }
    if($obj1 < $obj2){
	return -1;
    }
    return 1;
}

sub default_eval
{
    my ($elt) = @_;
    return $elt;
}


sub parent_node_index
{
    my ($self,
	$index) = @_;

    if($index == 0){
	return -1;
    }

    return int(($index-1)/2);
}


sub grandparent_node_index
{
    my ($self,
	$index) = @_;

    if($index == 0){
	return;
    }
    my $parent_index = $self->parent_node_index($index);
    if($parent_index){
	return $self->parent_node_index($parent_index);
    }
    return;
}

sub right_node
{
    my ($self, $index) = @_;

    my $r_index = $self->right_node_index($index);
    my $array = $self->{_arr};

    if($r_index < @$array){
	return $array->[$r_index];
    }
    return;
}

sub right_node_index
{
    my ($self,
	$index) = @_;
    return $index*2 + 2;
}


sub left_node
{
    my ($self, $index) = @_;
    my $l_index = $self->left_node_index($index);
    my $array = $self->{_arr};

    if($l_index < @$array){
	return $array->[$l_index];
    }
    return;
}


sub left_node_index
{
    my ($self,
	$index) = @_;
    return $index*2 + 1;
}


sub parent
{
    my ($self,
	$index) = @_;
    my $array = $self->{_arr};

    if($index == 0){
	return;
    }
    my $parent_index = $self->parent_node_index($index);

    if($parent_index){
	return $self->{_arr}->[$parent_index];
    }
    return;
}


sub get_size
{
    my $self = shift;
    my $array = $self->{_arr};
    return @$array;
}

sub is_empty
{
    my ($self) = @_;
    my $array = $self->{_arr};
    if(@$array == 0){
	return 1;
    }
    return 0;
}


sub has_grandparent
{
    my ($self, $i) = @_;

    my $parent_node_index = $self->parent_node_index($i);

    if($parent_node_index){
	if($self->parent_node_index($parent_node_index) != -1){
	    return 1;

	}
    }
    return 0;
}

sub has_parent
{
    my ($self, $i) = @_;

    if($self->parent_node_index($i) != -1){
	return 1;
    }
    return -1;
}

sub has_children
{
    my ($self, $i) = @_;

    if($self->left_node($i) || $self->right_node($i)){ # if has children
	return 1;
    }
    return 0;
}

sub is_grandchild
{
    my ($self, $index, $gindex) = @_;

    my $l_index = $self->left_node_index($index);
    my $r_index = $self->right_node_index($index);

    my $l_l_index = $self->left_node_index($l_index);
    if($gindex == $l_l_index){
	return 1;
    }
    my $l_r_index = $self->right_node_index($l_index);
    if($gindex == $l_r_index){
	return 1;
    }
    my $r_l_index = $self->left_node_index($r_index);
    if($gindex == $r_l_index){
	return 1;
    }
    my $r_r_index = $self->right_node_index($r_index);
    if($gindex == $r_r_index){
	return 1;
    }

    return 0;
}



sub get_level
{
    my ($self, $i) = @_;
    my $log;
    my ($pkg, $filename, $line) = caller();

    if($i == 0){
	return 0;
    }
    $log = log($i + 1) / log(2);
    return int($log);
}



############################################################
#
# print
#
# $mm_heap->print();
#
# Dump the contents of the heap to STDOUT
#
############################################################
sub print{
    $_[0]->print_heap();
}

sub print_heap{
    my ($self) = @_;
    my $array = $self->{_arr};
    my $eval_func = $self->{feval};

    my $i = 0;
    foreach my $elt (@$array){
	my $val = $eval_func->($elt);
	if(!defined($val)){
	    croak "Error:  evaluation function provided to Heap::MinMax object returned null\n";
	}
	print $eval_func->($elt) . "\n";
	$i++;
    }
}



sub fp_equal {
    my ($A, $B, $dp) = @_;

    return sprintf("%.${dp}g", $A) eq sprintf("%.${dp}g", $B);
}





1;
__END__