File Coverage

blib/lib/Algorithm/SkipList.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

=head1 NAME

Algorithm::SkipList - Perl implementation of skip lists

=begin readme

=head1 REQUIREMENTS

The following non-core modules are used:

  Tree::Node

=head1 INSTALLATION

Installation can be done using the traditional F or the
newer F method .

Using Makefile.PL:

  perl Makefile.PL
  make test
  make install

(On Windows platforms you should use F instead.)

Using Build.PL (if you have L installed):

  perl Build.PL
  perl Build test
  perl Build install

=end readme

=head1 SYNOPSIS

  my $list = new Algorithm::SkipList();

  $list->insert( 'key1', 'value' );
  $list->insert( 'key2', 'another value' );

  $value = $list->find('key2');

  $list->delete('key1');

=head1 DESCRIPTION

This is an implementation of skip lists in Perl.

Skip lists are an alternative to balanced trees. They are ordered
linked lists with random links at various I that allow
searches to skip over sections of the list, like so:

  4 +---------------------------> +----------------------> +
    |                             |                        |
  3 +------------> +------------> +-------> +-------> +--> +
    |              |              |         |         |    |
  2 +-------> +--> +-------> +--> +--> +--> +-------> +--> +
    |         |    |         |    |    |    |         |    |
  1 +--> +--> +--> +--> +--> +--> +--> +--> +--> +--> +--> +
         A    B    C    D    E    F    G    H    I    J   NIL

A search would start at the top level: if the link to the right
exceeds the target key, then it descends a level.

Skip lists generally perform as well as balanced trees for searching
but do not have the overhead with respect to reblanacing the structure.
And on average, they use less memory than trees.

They also use less memory than hashes, and so are appropriate for
large collections.

=for readme stop

For more information on skip lists, see the L section below.

=head2 METHODS

=cut

package Algorithm::SkipList;

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

our $VERSION = '2.00_02';
$VERSION = eval $VERSION;

use self;

use Carp qw( carp croak );
use Tree::Node;
use Algorithm::SkipList::Header;

use constant MAX_LEVEL       => 31;
use constant MIN_LEVEL       =>  1;

use constant DEFAULT_P       => 0.25;
use constant DEFAULT_K       => 0;

# We could use Algorithm::SkipList::Node, which exists as a stub. But
# there's just no point to it.

use constant DEFAULT_NODE_CLASS => 'Tree::Node';

# This is an internal routine which defines valid configuration options and
# their default values.  It is meant to be called by the BEGIN block (see
# source code below) that creates access methods for these options.

my %CONFIG_OPTIONS;

sub _set_config_options {
  %CONFIG_OPTIONS = (
    p                => DEFAULT_P,
    k                => DEFAULT_K,
    min_level        => MIN_LEVEL,
    max_level        => MAX_LEVEL,
    node_class       => DEFAULT_NODE_CLASS,
    allow_duplicates => 0,
  );
}

=over

=item new

  $list = new Algorithm::SkipList();

Creates a new skip list.

If you need to use a different L for using
customized L routines, you will need to specify a
different class:

  $list = new Algorithm::SkipList( node_class => 'MyNodeClass' );

See the L section below.

Specialized internal parameters may be configured:

  $list = new Algorithm::SkipList( max_level => 31 );

Defines a different maximum list level (the default is 31).

The initial list (see the L method) will start out at one
level, and will increase as the size of the list doubles, up intil
it reaches the maximum level.

The default minimum level can be changed:

  $list = new Algorithm::SkipList( min_level => 4 );

You can also control the probability used to determine level sizes for
each node by setting the L and k values:

  $list = new Algorithm::SkipList( p => 0.25, k => 1 );

See  L for more information on this parameter.

You can enable duplicate keys by using the following:

  $list = new Algorithm::SkipList( allow_duplicates => 1 );

This is an experimental feature. See the L section
below.

=cut

sub new {
  my $class = shift || __PACKAGE__;
  my $self  = {
    p                => DEFAULT_P,
    k                => DEFAULT_K,
    p_levels         => [ ],            # array used by random_level
  };

  bless $self, $class;

  # Set default values

  foreach my $field (CORE::keys %CONFIG_OPTIONS) {
    my $method = "_set_" . $field;
    $self->$method( $CONFIG_OPTIONS{$field} );
  }

  # Update user-settings

  if (@_) {
    while (my $arg = shift) {
      if (exists $CONFIG_OPTIONS{$arg}) {
	my $value = shift;
	my $method = "_set_" . $arg;
	$self->$method($value);
      }
      else {

	croak "Unknown option: \'$arg\'";
      }
    }
  }

  # Additional user-settings checks, since the practical way to check is
  # after all of the settings have been changed.

  if ($self->min_level > $self->max_level) {
    croak "min_level > max_level";
  }

  $self->clear;

  return $self;
}

=item list

  $node = $list->list;

Returns the initial node in the list.  Accessing accessors other than
C and C will trigger an error.

This method is meant for internal use.

=cut

sub list {
  return $self->{list};
}

=item level

  $level = $list->level;

Returns the current maximum level (number of forward pointers) that
any node can have.  It will not be larger than L, nor
does it correspond to the number of nodes in L.

This method is meant for internal use.

=cut

sub level {
  return $self->{level};
}

=item clear

  $list->clear;

Erases existing nodes and resets the list.

=cut

sub clear {
  $self->{list}      = Algorithm::SkipList::Header->new(MAX_LEVEL);
  $self->{level}     = MIN_LEVEL;

  if ($self->{max_level} > $self->{list}->child_count) {
    $self->{max_level} = $self->{list}->child_count;
    carp sprintf('max_level downgraded to %d due to limits of list header',
		 $self->{list}->child_count) if (warnings::enabled);
  }

  $self->{size}      = 0;

  $self->{size_threshold}      = 2**($self->{level});
  $self->{last_size_threshold} = $self->{size};

  $self->{last_node} = undef;

  $self->_reset_iterator;
}

=begin internal

=item _search

  ($node, $cmp) = $list->_search( $key );

  ($node, $cmp) = $list->_search( $key, $finger );

Same as L, only that no search finger is returned.

This is useful for searches where a finger is not needed.  The speed
of searching is improved.

Note that as of version 2.00, the order of return values has been
changed.

=end internal

=cut

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

  use integer;

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

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

  my $fwd;
  my $cmp = -1;

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

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

  return ($node, $cmp);
}

=begin internal

=item _search_with_finger

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

Searches for the node with a key.  If the key is found, that node is
returned along with a L.  If the key is not found, the previous
node from where the node would be if it existed is returned.

Note that the value of C<$cmp>

  $cmp = $node->key_cmp( $key )

is returned because it is already determined by L.

Search fingers may also be specified:

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

See the section L below.

Note that as of version 2.00, the order of return values has been
changed.

=end internal

=cut

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

  use integer;

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

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

  my $fwd;
  my $cmp = -1;

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

  # Ideally we could stop when $cmp == 0, but the update vector would
  # not be complete for levels below $level.

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

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

=item exists

  if ($list->exists( $key )) { ... }

Returns true if there exists a node associated with the key, false
otherwise.

This may also be used with  L:

  if ($list->exists( $key, $finger )) { ... }

=cut

sub exists {
  # my ($key, $finger) = @args;
  (($self->_search(@args))[1] == 0);
}

=item find_with_finger

  $value = $list->find_with_finger( $key );

Searches for the node associated with the key, and returns the value. If
the key cannot be found, returns C.

L may also be used:

  $value = $list->find_with_finger( $key, $finger );

To obtain the search finger for a key, call L in a
list context:

  ($value, $finger) = $list->find_with_finger( $key );

=cut

sub find_with_finger {
  ##my ($key, $finger) = @args;
  my ($node, $cmp);
     ($node, $cmp, $args[1]) = $self->_search_with_finger(@args);

  if ($cmp) {
    return;
  } else {
    return (wantarray) ? ($node->value, $args[1]) : $node->value;
  }
}

=item find

  $value = $list->find( $key );

  $value = $list->find( $key, $finger );

Searches for the node associated with the key, and returns the value. If
the key cannot be found, returns C.

This method is slightly faster than L since it does
not return a search finger when called in list context.

If you are searching for duplicate keys, you must use
L or L.

=cut

sub find {
  ## my ($key, $finger) = @args;
  my ($node, $cmp) = $self->_search(@args);

  if ($cmp) {
    return;
  } else {
    return $node->value;
  }
}

=item insert

  $list->insert( $key, $value );

Inserts a new node into the list.

Only alphanumeric keys are supported "out of the box".  To use numeric
or other types of keys, see L below.

You may also use a L with insert,
provided that the finger is for a key that occurs earlier in the list:

  $list->insert( $key, $value, $finger );

Using fingers for inserts is I recommended since there is a risk
of producing corrupted lists.

=cut

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

  use integer;

  # TODO: Track last node inserted and use it's update vector if the
  # key to be inserted is greater.

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

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

    my $level = $self->_new_node_level;
    $node = $self->node_class->new($level);
    $node->set_key($key);
    $node->set_value($value);

    my $list = $self->list;
    for(my $i=0; $i<$level; $i++) {
      $node->set_child($i, ($finger->[$i]||$list)->get_child($i));
      ($finger->[$i]||$list)->set_child($i, $node);
    }

    $self->{size}++;
    $self->_adjust_level_threshold;

    # Tracking the last node in the list. We cannot save the finger
    # since something could be inserted between $finger->[0] and the
    # last_node.

    $self->{last_node} = $node
      unless ($node->get_child(0));

  }
  else {
    $node->set_value($value);
  }
}

=item delete

  $value = $list->delete( $key );

Deletes the node associated with the key, and returns the value.  If
the key cannot be found, returns C.

L may also be used:

  $value = $list->delete( $key, $finger );

Calling L in a list context I return a search
finger.

=cut

sub delete {
  my ($key, $finger) = @args;

  use integer;

  my ($node, $cmp);
 ($node, $cmp, $finger) = $self->_search_with_finger(@args);

  if ($cmp) {
    return;
  }
  else {
    my $list = $self->list;
    for(my $i=0; $i<$node->child_count; $i++) {
      ($finger->[$i]||$list)->set_child($i, $node->get_child($i));
    }
    $self->{size}--;

    # It is only practical to adjust the level during inserts. If we
    # do this during deletes, we run into some problems.

    # $self->_adjust_level_threshold;

    $self->{last_node} = $finger->[0]
      unless ($node->get_child(0));

    return $node->value;
  }
}

=begin internal

  $list->_build_distribution;

This is an internal routine to update the probabilities for each node
level.  It is meant to be called each time L or L are updated.

=end internal

=cut

sub _build_distribution {
  no integer;

  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 ($p) = @args;

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

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

sub _set_k {

  my ($k) = @args;

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

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

sub _set_min_level {
  my ($min_level) = @args;

  if ($self->size) {
    croak "min_level can only be set on an empty skip list";
  }

  if ( ($min_level < MIN_LEVEL) || ($min_level > MAX_LEVEL) ) {
    croak sprintf("Invalid value for min_level (must be between %d and %d)",
		  MIN_LEVEL, MAX_LEVEL);
  }

  $self->{min_level} = $min_level;
}

sub _set_max_level {
  my ($max_level) = @args;

  # We want to make sure that the user-supplied does not exceed the
  # maximum level of the list node (even though we specify that the
  # list node has MAX_LEVEL by default).

  my $max = MAX_LEVEL;
  if ((defined $self->list) && ($self->list->child_count < $max)) {
    $max = $self->list->child_count;
  }
  my $min = $self->min_level || MIN_LEVEL;

  if ( ($max_level < $min) || ($max_level > $max) ) {
    croak sprintf("Invalid value for max_level (must be between %d and %d)",
		  $min, $max);
  }
  $self->{max_level} = $max_level;
}

sub _adjust_level_threshold {
  use integer;

  if ($self->{size} == $self->{size_threshold}) {
    # $self->{last_size_threshold} = $self->{size_threshold};
    $self->{size_threshold}      += $self->{size_threshold};
    $self->{level}++,
      if ($self->{level} < $self->{max_level});
  }

#   elsif ($self->{size} < $self->{last_size_threshold}) {
#     $self->{size_threshold}  = $self->{last_size_threshold};
#     $self->{last_size_threshold} = $self->{last_size_threshold} / 2;
#
#     # We cannot practically decrease the level without readjusting the
#     # levels of all the nodes globally, which isn't worthwhile.
#
#     # $self->{level}--,
#     #   if ($self->{level} > MIN_LEVEL);
#   }
}

sub _new_node_level {
  no integer;

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

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

  return $level;
}

sub _set_node_class {
  my ($node_class) = @args;
  unless ($node_class->isa( DEFAULT_NODE_CLASS )) {
    croak "$node_class is not a " . DEFAULT_NODE_CLASS;
  }
  $self->{node_class} = $node_class;
}

=item size

  $size = $list->size;

Returns the number of nodes in the list.

=cut

sub size {
  return $self->{size};
}

=item reset

  $list->reset;

Resets the iterator used by L and L.

=begin internal

=item _reset_iterator

This is the internal alias for L.

=end internal

=cut

sub _reset_iterator {
  $self->{iterator} = undef;
}

sub _set_iterator_by_key {
  ## my ($key, $finger) = @args;
  my ($node, $cmp) = $self->_search(@args);
  if ($cmp) {
    carp "key \'$args[0]\' not found" if (warnings::enabled);
    return $self->_reset_iterator;
  } else {
    return $self->{iterator} = $node;
  }
}

sub _first_node {
  $self->_reset_iterator;
  $self->_next_node;
}

sub _next_node {
  $self->{iterator} = ($self->{iterator} || $self->list)->get_child(0);
}

sub _last_node {
  return $self->{last_node};
}

=item first_key

  $key = $list->first_key;

Returns the first key in the list. Implicitly calls the iterator L
method.

=cut

sub first_key {
  my $node = $self->_first_node;
  return $node->key;
}

=item next_key

  $key = $list->next_key;

Returns the next key in the series.

  $key = $list->next_key($last_key);

Returns the key that follows the C<$last_key>.

  $key = $list->next_key($last_key, $finger);

Same as above, using the C<$finger> to search for the key.

=cut

sub next_key {
  my ($last_key, $finger) = @args;
  if (defined $last_key) {
    $self->_set_iterator_by_key($last_key, $finger);
  }

  my $node = $self->_next_node;
  return $node->key if ($node);
  return;
}


sub _error {
  croak "Method unimplemented";
}

BEGIN {
  *TIEHASH   = \&new;
  *STORE     = \&insert;
  *FETCH     = \&find;
  *EXISTS    = \&exists;
  *CLEAR     = \&clear;
  *DELETE    = \&delete;
  *FIRSTKEY  = \&first_key;
  *NEXTKEY   = \&next_key;

  *reset     = \&_reset_iterator;
  *search    = \&find;

    *merge   = \&_error;
    *find_duplicates = \&_error;
    *_node_by_index = \&_error;
    *key_by_index = \&_error;
    *index_by_key = \&_error;
    *value_by_index = \&_error;

  *_prev     = \&_error;
  *_prev_key = \&_error;

  _set_config_options();
  foreach my $field (CORE::keys %CONFIG_OPTIONS) {
    my $set_method = "_set_" . $field;
    no strict 'refs';
    *$field = sub {
      my $self = shift;
      if (@_) {
	$self->$set_method($field);
      } else {
	return $self->{$field};
      }
    };
    unless (__PACKAGE__->can($set_method)) {
      *$set_method = sub {
	my $self = shift;
        $self->{$field} = shift;
      };
    }
  }
}

1;

# __END__

=item least

  ($key, $value) = $list->least;

Returns the least key and value in the list, or C if the list
is empty.

=cut

sub least {
  my $node = $self->_first_node || return;
  return ($node->key, $node->value);
}

=item greatest

  ($key, $value) = $list->greatest;

Returns the greatest key and value in the list, or C if the list
is empty.

=cut

sub greatest {
  my $node = $self->_last_node || return;
  return ($node->key, $node->value);

}

=item next

  ($key, $value) = $list->next( $last_key, $finger );

Returns the next key-value pair.

C<$last_key> and C<$finger> are optional.

=cut

sub next {
  my ($last_key, $finger) = @args;
  if (defined $last_key) {
    $self->_set_iterator_by_key($last_key, $finger);
  }
  my $node = $self->_next_node;
  return ($node->key, $node->value);
}

=item keys

  @keys = $list->keys;

Returns a list of keys, in the order that they occur.

  @keys = $list->keys( $low, $high);

Returns a list of keys between C<$low> and C<$high>, inclusive. (This
is only available in versions 1.02 and later.)

=cut

sub keys {
  my ($low, $high, $finger) = @args;
  my @result = ( );
  if (defined $low) {
    push @result, $self->_set_iterator_by_key($low, $finger)->key;
  }
  else {
    $self->_reset_iterator;
  }

  my $node;
  while ( ($node = $self->_next_node) &&
	  ((!defined $high) || ($node->key_cmp($high) < 1) )) {
    push @result, $node->key;
  }
  return @result;
}

=item values

  @values = $list->values;

Returns a list of values corresponding to the keys returned by the
L method.  You can also request the values between a pair of
keys:

  @values = $list->values( $low, $high );

=cut

sub values {
  my ($low, $high, $finger) = @args;
  my @result = ( );
  if (defined $low) {
    push @result, $self->_set_iterator_by_key($low, $finger)->value;
  }
  else {
    $self->_reset_iterator;
  }

  my $node;
  while ( ($node = $self->_next_node) &&
	  ((!defined $high) || ($node->key_cmp($high) < 1) )) {
    push @result, $node->value;
  }
  return @result;
}


=item copy

  $list2 = $list1->copy;

Makes a copy of a list.  The configuration options passed to L are
used, although the exact structure of node levels is not cloned.

  $list2 = $list1->copy( $key_from, $key_to, $finger );

Copy the list between C<$key_from> and C<$key_to> (inclusive).  If
C<$finger> is defined, it will be used as a search finger to find
C<$key_from>.  If C<$key_to> is not specified, then it will be assumed
to be the end of the list.

If C<$key_from> does not exist, C will be returned.

Note: the order of arguments has been changed since version 2.00!

=cut

sub copy {
  my ($low, $high, $finger) = @args;
  my %opts = map { $_ => $self->$_ } (CORE::keys %CONFIG_OPTIONS);
  my $copy = Algorithm::SkipList->new( %opts );

  if (defined $low) {
    my $node = $self->_set_iterator_by_key($low, $finger);
    $copy->insert($node->key, $node->value), if ($node);
  }
  else {
    $self->_reset_iterator;
  }

  my $node;
  while ( ($node = $self->_next_node) &&
	  ((!defined $high) || ($node->key_cmp($high) < 1) )) {
    $copy->insert($node->key, $node->value);
  }

  return $copy;
}

sub truncate {
  my ($key, $finger) = @args;

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

  if ($cmp) {
    return;
  }
  else {
    my %opts = map { $_ => $self->$_ } (CORE::keys %CONFIG_OPTIONS);
    my $tail = Algorithm::SkipList->new( %opts );
    my $list = $tail->list;

    for(my $i=0; $i<@$finger; $i++) {
      $list->set_child($i, $finger->[$i]->get_child($i));
      $finger->[$i]->set_child($i, undef);
    }
    $self->{last_node} = $finger->[0];
    return $tail;
  }
}

sub append {
  my ($head, $tail) = @_;

  my $left  = $head->_last_node;
  my $right = $tail->_first_node;

  # Note: the behavior is not different when one of the skip lists is
  # empty. In particular, the tail is not cleared, although the user
  # should assume that it is.

  unless ($head->size) { return $tail; }
  unless ($tail->size) { return $head; }

  if ( (($left->key_cmp($right->key)<0) && ($right->key_cmp($left->key)>0)) ||
       ($head->allow_duplicates && ($left->key_cmp($right->key)==0)) ) {

    # We need to build an update vector for the last node on each
    # level. There's really no other way to do this but to use a
    # specialized search.

    my $finger = [ ($head->list) x $head->level ];
    {
      my $i = $head->level-1;
      my $node = $head->list->get_child($i);
      if ($node) {
	do {
	  while (my $fwd = $node->get_child($i)) {
	    $node = $fwd;
	  }
	  $finger->[$i] = $node;
	} while (--$i >= 0);
      }
    }

    for(my $i=0; $i<$head->level; $i++) {
      $finger->[$i]->set_child($i, $tail->list->get_child($i));
    }

    # If the tail has a greater height than the head, we increase it

    if ($tail->level > $head->level) {
      for (my $i=$head->level; $i<$tail->level; $i++) {
	$head->list->set_child($i, $tail->list->get_child($i));
      }
      $head->{level} = $tail->level;
    }
    $head->{size} += $tail->size;
    $tail->clear;

    return $head;
  }
  else {
    croak "Cannot append: first key of tail is less than last key of head";
  }
}

=begin internal

=item _debug

  $list->_debug;

This is an internal routine for dumping the contents and structure of
a skiplist to STDERR.  It is intended for debugging.

=end internal

=cut

sub _debug {
  my ($fh) = @args;

  $fh = \*STDERR, unless ($fh);

  my $node   = $self->list;

  while ($node) {
    if ($node->isa("Algorithm::SkipList::Header")) {
      print $fh "undef=undef (header) ", $node, "\n";
    }
    else {
      print $fh
	$node->key||'undef', "=", $node->value||'undef'," ", $node,"\n";
    }

    for(my $i=0; $i<$node->child_count; $i++) {
      print $fh " ", $i," ", $node->get_child($i)
	|| 'undef', "\n";
    }
    print $fh "\n";

    $node = $node->get_child(0);
  }
}

1;

__END__