File Coverage

blib/lib/SkewHeap/PP.pm

Criterion	Covered	Total	%
statement	118	138	85.5
branch	16	22	72.7
condition	5	5	100.0
subroutine	28	33	84.8
pod	18	22	81.8
total	185	220	84.0

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

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

use feature 'signatures';
no warnings 'experimental::signatures';

#-------------------------------------------------------------------------------
# Node array index constants
#-------------------------------------------------------------------------------
use constant KEY   => 0;
use constant LEFT  => 1;
use constant RIGHT => 2;

#-------------------------------------------------------------------------------
# Skew heap array index constants
#-------------------------------------------------------------------------------
use constant CMP   => 0;
use constant SIZE  => 1;
use constant ROOT  => 2;

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

#-------------------------------------------------------------------------------
# Common interface
#-------------------------------------------------------------------------------
sub skew :prototype(&) {
  return [$_[0], 0, undef];
}

sub merge_nodes ($skew, $l, $r) {
  return $l unless defined $r;
  return $r unless defined $l;

  if ($skew->[CMP]->($l->[KEY], $r->[KEY]) > 0) {
    ($l, $r) = ($r, $l);
  }

  my $tmp     = $l->[RIGHT];
  $l->[RIGHT] = $l->[LEFT];
  $l->[LEFT]  = merge_nodes($skew, $r, $tmp);

  return $l;
}

sub clone_node ($node) {
  return unless defined $node;

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

sub merge_nodes_non_destructive ($skew, $l, $r) {
  return clone_node($l) unless defined $r;
  return clone_node($r) unless defined $l;

  if ($skew->[CMP]->($l->[KEY], $r->[KEY]) > 0) {
    ($l, $r) = ($r, $l);
  }

  return [
    $l->[KEY],
    merge_nodes_non_destructive($skew, $r, $l->[RIGHT]),
    clone_node($l->[LEFT]),
  ];
}

sub skew_count :prototype($) {
  return $_[0][SIZE];
}

sub skew_is_empty :prototype($) {
  return $_[0][SIZE] == 0;
}

sub skew_peek :prototype($) {
  return $_[0][ROOT][KEY] unless skew_is_empty($_[0]);
  return;
}

sub skew_take ($skew, $want = undef) {
  my @taken;
  while (($want || 1) > @taken && $skew->[SIZE] > 0) {
    push @taken, $skew->[ROOT][KEY];
    $skew->[ROOT] = merge_nodes($skew, $skew->[ROOT][LEFT], $skew->[ROOT][RIGHT]);
    --$skew->[SIZE];
  }

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

sub skew_put ($skew, @items) {
  for (sort{ $skew->[CMP]->($b, $a) } @items) {
    $skew->[ROOT] = merge_nodes($skew, $skew->[ROOT], [$_, undef, undef]);
    ++$skew->[SIZE];
  }

  return $skew->[SIZE];
}

sub skew_merge ($skew, @heaps) {
  for (@heaps) {
    $skew->[ROOT] = merge_nodes($skew, $skew->[ROOT], $_->[ROOT]);
    $skew->[SIZE] += $_->[SIZE];
    $_->[ROOT] = undef;
    $_->[SIZE] = 0;
  }

  return $skew;
}

sub skew_merge_safe (@heaps) {
  my $skew = [$heaps[0][CMP], 0, undef];

  for (@heaps) {
    $skew->[ROOT] = merge_nodes_non_destructive($skew, $skew->[ROOT], $_->[ROOT]);
    $skew->[SIZE] += $_->[SIZE];
  }

  return $skew;
}

sub node_explain ($node, $indent_size=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 ($skew) {
  my $n = skew_count($skew);
  print "SkewHeap\n";
  node_explain($skew->[ROOT], 1);
}

#-------------------------------------------------------------------------------
# Object inteface
#-------------------------------------------------------------------------------
sub new ($class, $cmp) {
  my $skew = skew \&$cmp;
  bless $skew, $class;
}

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 merge_safe ($self, @heaps) {
  my $new = skew_merge_safe($self, @heaps);
  bless $new, ref($self);
}

1;

__END__