File Coverage

blib/lib/Algorithm/SkipList.pm

Criterion	Covered	Total	%
statement	367	405	90.6
branch	101	140	72.1
condition	48	55	87.2
subroutine	61	61	100.0
pod	25	25	100.0
total	602	686	87.7

package Algorithm::SkipList;

use 5.006;
use strict;
use warnings::register __PACKAGE__;

our $VERSION = '1.02';
# $VERSION = eval $VERSION;

use AutoLoader qw( AUTOLOAD );
use Carp qw( carp croak );

require Algorithm::SkipList::Node;
require Algorithm::SkipList::Header;

# Future versions should check Config module to determine if it is
# being run on a 64-bit processor, and set MAX_LEVEL to 64.

use constant MIN_LEVEL       =>  2;
use constant MAX_LEVEL       => 32;
use constant DEF_P           => 0.25;
use constant DEF_K           => 0;

use constant BASE_NODE_CLASS => 'Algorithm::SkipList::Node';

# We use Exporter instead of something like Exporter::Lite because
# Carp uses it.

require Exporter;

our @EXPORT    = ( );
our @EXPORT_OK = ( );

sub new {
  no integer;

  my $class = shift;

  my $self = {
    NODECLASS => BASE_NODE_CLASS,       # node class used by list
    LIST      => undef,                 # pointer to the header node
    SIZE      => undef,                 # size of list
    SIZE_THRESHOLD => undef,            # size at which SIZE_LEVEL increased
    LAST_SIZE_TH   => undef,            # previous SIZE_THRESHOLD
    SIZE_LEVEL     => undef,            # maximum level random_level
    MAXLEVEL  => MAX_LEVEL,             # absolute maximum level
    P         => 0,                     # probability for each level
    K         => 0,                     # minimum power of P
    P_LEVELS  => [ ],                   # array used by random_level
    LIST_END  => undef,                 # node with greatest key
    LASTKEY   => undef,                 # last key used by next_key
    LASTINSRT => undef,                 # cached insertion fingers
    DUPLICATES => 0,                    # allow duplicates?
  };

  bless $self, $class;

  $self->_set_p( DEF_P ); # initializes P_LEVELS
  $self->_set_k( DEF_K );

  if (@_) {
    my %args = @_;
    foreach my $arg_name (CORE::keys %args) {
      my $method = "_set_" . $arg_name;
      if ($self->can($method)) {
	$self->$method( $args{ $arg_name } );
      } else {
	croak "Invalid parameter name: ``$arg_name\'\'";
      }
    }
  }

  $self->clear;

  return $self;
}

sub _set_duplicates {
  my ($self, $dup) = @_;
  $self->{DUPLICATES} = $dup || 0;
}

sub _set_node_class {
  my ($self, $node_class) = @_;
  $self->{NODECLASS} = $node_class;
}

sub _node_class {
    my ($self) = @_;
    $self->{NODECLASS};
  }

sub reset {
  my ($self) = @_;
  $self->{LASTKEY}  = undef;
}

sub clear {
  my ($self) = @_;

  $self->{SIZE}     = 0;
  $self->{SIZE_THRESHOLD} = 2;
  $self->{LAST_SIZE_TH}   = 0;
  $self->{SIZE_LEVEL}     = MIN_LEVEL;

  my $hdr = [ (undef) x $self->{SIZE_LEVEL} ];

  CORE::delete $self->{LIST};
  $self->{LIST} = new Algorithm::SkipList::Header( undef, undef, $hdr );

  $self->{LIST_END}  = undef;
  $self->{LASTINSRT} = undef;

  $self->reset;
}

sub _set_max_level {
  my ($self, $level) = @_;
  if ($level > MAX_LEVEL) {
    croak "Cannot set max_level greater than ", MAX_LEVEL;
  } elsif ($level < MIN_LEVEL) {
    croak "Cannot set max_level less than ", MIN_LEVEL;
  } elsif ((defined $self->list) && ($level < $self->list->level)) {
    croak "Current level exceeds specified level";
  }
  $self->{MAXLEVEL} = $level;
}

sub max_level {
  my ($self, $level) = @_;

  if (defined $level) {
    $self->_set_max_level($level);
  } else {
    $self->{MAXLEVEL};
  }
}

# We use the formula from Pugh's "Skip List Cookbook" paper.  We
# generate a reverse-sorted array of values based on p and k.  In
# _new_node_level() we look for the highest value in the array that is
# less than a random number n (0

sub _build_distribution {
  no integer;

  my ($self) = @_;

  my $p = $self->p;
  my $k = $self->k;

  $self->{P_LEVELS} = [ (0) x MAX_LEVEL ];
  for my $i (0..MAX_LEVEL) {
    $self->{P_LEVELS}->[$i] = $p**($i+$k);
  }
}

sub _set_p {
  no integer;

  my ($self, $p) = @_;

  unless ( ($p>0) && ($p<1) ) {
    croak "Unvalid value for P (must be between 0 and 1)";
  }

  $self->{P} = $p;
  $self->_build_distribution;

}

sub p {
  no integer;

  my ($self, $p) = @_;

  if (defined $p) {
    $self->_set_p($p);
  } else {
    $self->{P};
  }
}

sub _set_k {
  my ($self, $k) = @_;

  unless ( $k>=0 ) {
    croak "Unvalid value for K (must be at least 0)";
  }

  $self->{K} = $k;
  $self->_build_distribution;
}

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

  if (defined $k) {
    $self->_set_k($k);
  } else {
    $self->{K};
  }
}

sub size {
  my ($self) = @_;
  $self->{SIZE};
}

sub list {
  my ($self) = @_;
  $self->{LIST};
}


sub _adjust_level_threshold {
  use integer;

  my ($self) = @_;

  if ($self->{SIZE} >= $self->{SIZE_THRESHOLD}) {
    $self->{LAST_SIZE_TH}    = $self->{SIZE_THRESHOLD};
    $self->{SIZE_THRESHOLD} += $self->{SIZE_THRESHOLD};
    $self->{SIZE_LEVEL}++, if ($self->{SIZE_LEVEL} < $self->{MAXLEVEL});
  } elsif ($self->{SIZE} < $self->{LAST_SIZE_TH}) {
    $self->{SIZE_THRESHOLD}  = $self->{LAST_SIZE_TH};
    $self->{LAST_SIZE_TH}    = $self->{LAST_SIZE_TH} / 2;
    $self->{SIZE_LEVEL}--, if ($self->{SIZE_LEVEL} > MIN_LEVEL);
  }
}

sub _new_node_level { # previously _random_level
  no integer;

  my ($self) = @_;

  my $n     = CORE::rand();
  my $level = 1;

  while (($n < $self->{P_LEVELS}->[$level]) &&
	 ($level < $self->{SIZE_LEVEL})) {
    $level++;
  }

  $level;
}

sub _search_with_finger {
  my ($self, $key, $finger) = @_;

  use integer;

  my $list   = $self->list;
  my $level  = $list->level-1;

  my $node   = $finger->[ $level ] || $list;

  # Iteresting Perl syntax quirk:
  #   do { my $x = ... } while ($x)
  # doesn't work because it considers $x out of scope.
  #
  # However, benchmarking shows that it's faster to use
  #   my $x; do { $x = ... } while ($x)
  #

  my $fwd;
  my $cmp = -1;

  # This version of the search algorithm is based on Schneier, 1994.

  do {
    while ( ($fwd = $node->header()->[$level]) &&
	    ($cmp = $fwd->key_cmp($key)) < 0) {
      $node = $fwd;
    }
    $finger->[$level] = $node;
  } while ((--$level>=0)); # && ($cmp));

  $node = $fwd, unless ($cmp);

  # Ideally we could stop when $cmp == 0, but the update vector would
  # not be complete for levels below $level.  insert still works, but
  # delete and truncate have problems and need kluges to make up for
  # that.

  ($node, $finger, $cmp);
}

sub _search {
  my ($self, $key, $finger) = @_;

  use integer;

  my $list   = $self->list;
  my $level  = $list->level-1;

#  $finger ||= [ ];

  my $node   = $finger->[ $level ]  || $list;

  # This version of the search algorithm is based on Schneier, 1994.

  my $fwd;
  my $cmp = -1;

  do {
    while ( ($fwd = $node->header()->[$level]) &&
	    ($cmp = $fwd->key_cmp($key)) < 0) {
      $node = $fwd;
    }
  } while ((--$level>=0) && ($cmp));

  $node = $fwd; # , unless ($cmp); # Devel::Cover says it's never false

  ($node, $finger, $cmp);
}

sub insert {
  my ($self, $key, $value, $finger) = @_;

  use integer;

  my $list   = $self->list;

  # We save the node and finger of the last insertion. If the next key
  # is larger, then we can use the "finger" to speed up insertions.

  my ($node, $cmp);

  unless ($finger) {
    $node   = $self->{LASTINSRT}->[0] and do {
      $finger = $self->{LASTINSRT}->[1],
	if ($node->key_cmp($key) <= 0);
      };
  }

  ($node, $finger, $cmp) = $self->_search_with_finger($key, $finger);

  if ($cmp || $self->{DUPLICATES}) {

    my $new_level = $self->_new_node_level;

    my $node_hdr = [ ];
    my $fing_hdr;

    $node = $self->_node_class->new( $key, $value, $node_hdr );

    for (my $i=0;$i<$new_level;$i++) {
      $fing_hdr = ($finger->[$i]||$list)->header();
      $node_hdr->[$i] = $fing_hdr->[$i];
      $fing_hdr->[$i] = $node;
    }


    # We no longer set the LIST_END value, since it is the job of the
    # _greatest_node method to find it, as needed.

    $self->{SIZE}++;
    $self->_adjust_level_threshold;
  } else {
    $node->value($value);
  }
  $self->{LASTINSRT}->[0] = $node;
  $self->{LASTINSRT}->[1] = $finger;
}

sub delete {

  my ($self, $key, $finger) = @_;

  use integer;

  my $list = $self->list;

  my ($node, $update_ref, $cmp) = $self->_search_with_finger($key, $finger);

  if ($cmp == 0) {
    my $value = $node->value;

    # Note: it might make better sense to set $self->{LIST_END} = undef, and
    # let the _greatest_node method search for it if it's needed again.

    if (($self->{LIST_END}) && ($node == $self->{LIST_END})) {
      $self->{LIST_END}  = $update_ref->[0];
    }

    my $level = $node->level;

    for (my $i=0; $i<$level; $i++) {
      $update_ref->[$i]->header()->[$i] = $node->header()->[$i];
    }

    # There's probably a smarter way to handle the last insert and
    # last key values, but this is the fastest, easiest, safest and
    # most consistent way.

    $self->{LASTINSRT} = undef;
    $self->reset;

    $self->{SIZE} --;
    $self->_adjust_level_threshold;

    # We shouldn't need to "undef $node" here. The Garbage Collector
    # should hanldle that (especially if there's a finger that points
    # to it somewhere).

    # Note: It doesn't seem to be a wise idea to return a search
    # finger for deletions without further analysis

    $value;

  } else {
    carp "key not found", if (warnings::enabled);
    return;
  }
}

sub exists {

  my ($self, $key, $finger) = @_;

  (($self->_search($key, $finger))[2] == 0);
}

sub find_with_finger {
  my ($self, $key, $finger) = @_;

  my ($x, $update_ref, $cmp) = $self->_search_with_finger($key, $finger);

  ($cmp == 0) ? (
    (wantarray) ? ($x->value, $update_ref) : $x->value
  ) : undef;

}

sub find {
  my ($self, $key, $finger) = @_;

  my ($node, $update_ref, $cmp) = $self->_search($key, $finger);

  ($cmp == 0) ? $node->value : undef;
}


sub _first_node { # actually this is the second node
  my $self = shift;

  my $list = $self->list;
  my $node = $list->header()->[0];
}


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

  if (@_ > 1) {
    $self->{LASTKEY} = [ $node, $index ];
    my $check = $index || 0;
    if (($check < 0) || ($check >= $self->size)) {
      carp "index out of bounds", if (warnings::enabled);
    }
  }
  else {
    unless ($self->{LASTKEY}) {
      $self->{LASTKEY} = [ $self->_first_node, 0 ];
    }
    ($node, $index) = @{ $self->{LASTKEY} };
  }

  if ($node) {
    return (wantarray) ?
      ( $node->key, [ $node ], $node->value, $index ) : $node->key;
  } else {
    return;
  }
}

sub first_key {
  my $self = shift;

  my $node = $self->_first_node;

  if ($node) {
    return $self->last_key( $node, 0);
  }
  else {
    carp "no _first_node", if (warnings::enabled);
    return;
  }
}

sub next_key {
  my ($self, $last_key, $finger) = @_;

  my ($node, $cmp, $value, $index);

  if (defined $last_key) {
    ($node, $finger, $cmp) = $self->_search_with_finger($last_key, $finger);

    if ($cmp) {
      carp "cannot find last_key", if (warnings::enabled);
      return;
    }
  }
  else {
    ($node, $index) = @{ $self->{LASTKEY} || [ ] };
    unless ($node) {
      return $self->first_key;
    }
  }

  if ($node) {
    $node = $node->header()->[0];
    return $self->last_key(
      $node,
      (($node && (defined $index)) ? ($index+1) : undef )
    );
  }
  else {
    return $self->reset;
  }
}


BEGIN
  {
    # make aliases to methods...
    no strict;
    *TIEHASH = \&new;
    *STORE   = \&insert;
    *FETCH   = \&find;
    *EXISTS  = \&exists;
    *CLEAR   = \&clear;
    *DELETE  = \&delete;
    *FIRSTKEY = \&first_key;
    *NEXTKEY = \&next_key;

    *search  = \&find;
  }

1;

__END__