File Coverage

blib/lib/SkewHeap/PP.pm

Criterion	Covered	Total	%
statement	38	79	48.1
branch	8	22	36.3
condition	5	7	71.4
subroutine	14	25	56.0
pod	18	22	81.8
total	83	155	53.5

package SkewHeap::PP;
# ABSTRACT: a fast and flexible heap structure
$SkewHeap::PP::VERSION = '0.02';

#-------------------------------------------------------------------------------
# Boilerplate
#-------------------------------------------------------------------------------
use strict;
use warnings;

#-------------------------------------------------------------------------------
# Node array index constants
#-------------------------------------------------------------------------------
my $KEY   = 0;
my $LEFT  = 1;
my $RIGHT = 2;

#-------------------------------------------------------------------------------
# Skew heap array index constants
#-------------------------------------------------------------------------------
my $CMP  = 0;
my $SIZE = 1;
my $ROOT = 2;

#-------------------------------------------------------------------------------
# Exports
#-------------------------------------------------------------------------------
use parent 'Exporter';
our @EXPORT = qw(
  skew
  skew_count
  skew_is_empty
  skew_peek
  skew_put
  skew_take
  skew_merge
  skew_merge_safe
  skew_explain
);

#-------------------------------------------------------------------------------
# Common interface
#-------------------------------------------------------------------------------
sub skew (&)          { [ $_[0], 0, undef ] }
sub skew_count ($)    { $_[0][$SIZE] }
sub skew_is_empty ($) { $_[0][$SIZE] == 0 }

sub clone_node {
  my $node = shift;
  return unless defined $node;

  return [
    $node->[$KEY],
    clone_node($node->[$LEFT]),
    clone_node($node->[$RIGHT]),
  ];
}

sub merge_nodes_safe {
  my ($cmp, $a, $b) = @_;

  return clone_node($a) unless defined $b;
  return clone_node($b) unless defined $a;

  ($a, $b) = ($b, $a)
    if $cmp->($a->[$KEY], $b->[$KEY]) > 0;

  return [
    $a->[$KEY],
    merge_nodes_safe($cmp, $b, $a->[$RIGHT]),
    clone_node($a->[$LEFT]),
  ];
}

sub merge_nodes {
  my ($cmp, $a, $b) = @_;

  return $a unless defined $b;
  return $b unless defined $a;

  ($a, $b) = ($b, $a)
    if $cmp->($a->[$KEY], $b->[$KEY]) > 0;

  my $tmp      = $a->[$RIGHT];
  $a->[$RIGHT] = $a->[$LEFT];
  $a->[$LEFT]  = merge_nodes($cmp, $b, $tmp);

  return $a;
}

sub skew_peek {
  my $skew = shift;
  return if skew_is_empty($skew);
  return $skew->[$ROOT][$KEY];
}

sub skew_take {
  my ($skew, $want) = @_;
  my @taken;

  while (($want || 1) > @taken && $skew->[$SIZE] > 0) {
    push @taken, $skew->[$ROOT][$KEY];

    $skew->[$ROOT] = merge_nodes(
      $skew->[$CMP],
      $skew->[$ROOT][$LEFT],
      $skew->[$ROOT][$RIGHT],
    );

    --$skew->[$SIZE];
  }

  return defined($want) ? @taken : $taken[0];
}

sub skew_put {
  my $skew = shift;

  for (@_) {
    $skew->[$ROOT] = merge_nodes(
      $skew->[$CMP],
      $skew->[$ROOT],
      [$_, undef, undef],
    );

    ++$skew->[$SIZE];
  }

  return $skew->[$SIZE];
}

sub skew_merge {
  my $skew = shift;

  for (@_) {
    $skew->[$ROOT] = merge_nodes(
      $skew->[$CMP],
      $skew->[$ROOT],
      $_->[$ROOT],
    );

    $skew->[$SIZE] += $_->[$SIZE];
    $_->[$ROOT] = undef;
    $_->[$SIZE] = 0;
  }

  return $skew;
}

sub skew_merge_safe {
  my $skew = [ $_[0][$CMP], 0, undef ];

  for (@_) {
    $skew->[$ROOT] = merge_nodes_non_destructive(
      $skew->[$CMP],
      $skew->[$ROOT],
      $_->[$ROOT],
    );

    $skew->[$SIZE] += $_->[$SIZE];
  }

  return $skew;
}

sub node_explain {
  my $node = shift;
  my $indent_size = shift || 0;

  my $indent = '   ' x $indent_size;
  print $indent.'- Node: '.$node->[$KEY]."\n";

  if ($node->[$LEFT]) {
    node_explain($node->[$LEFT], $indent_size + 1);
  }

  if ($node->[$RIGHT]) {
    node_explain($node->[$RIGHT], $indent_size + 1);
  }
}

sub skew_explain {
  my $skew = shift;
  my $n = skew_count($skew);
  print "SkewHeap\n";
  node_explain($skew->[$ROOT], 1);
}

#-------------------------------------------------------------------------------
# Object inteface
#-------------------------------------------------------------------------------
sub count    { goto \&skew_count    }
sub is_empty { goto \&skew_is_empty }
sub peek     { goto \&skew_peek     }
sub put      { goto \&skew_put      }
sub take     { goto \&skew_take     }
sub merge    { goto \&skew_merge    }
sub explain  { goto \&skew_explain  }

sub new {
  my ($class, $cmp) = @_;
  bless(skew(\&$cmp), $class);
}

sub merge_safe {
  my $self = shift;
  my $new = skew_merge_safe($self->[$CMP], @_);
  bless($new, ref($self));
}

1;

__END__