File Coverage

blib/lib/Array/IntSpan.pm

Criterion	Covered	Total	%
statement	202	217	93.0
branch	111	132	84.0
condition	42	48	87.5
subroutine	19	23	82.6
pod	10	18	55.5
total	384	438	87.6

#
# This file is part of Array-IntSpan
#
# This software is Copyright (c) 2014 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The Artistic License 1.0
#
##########################################################################
#
# Array::IntSpan - a Module for handling arrays using IntSpan techniques
#
# Author: Toby Everett, Dominique Dumont
#
##########################################################################
# Copyright 2003-2004,2010,2014 Dominique Dumont.  All rights reserved.
# Copyright 2000 Toby Everett.  All rights reserved.
#
# This file is distributed under the Artistic License. See
# http://www.ActiveState.com/corporate/artistic_license.htm or
# the license that comes with your perl distribution.
#
# For comments, questions, bugs or general interest, feel free to
# contact Dominique Dumont at [e-mail]
# or Toby Everett at [e-mail]
##########################################################################

use strict;
use warnings ;

package Array::IntSpan;
$Array::IntSpan::VERSION = '2.003';

sub min { my @a = sort {$a <=> $b} @_ ; return $a[0] ; }
sub max { my @a = sort {$b <=> $a} @_ ; return $a[0] ; }

sub new {
  my $class = shift;

  my $self = [@_];
  bless $self, $class;
  $self->_check_structure;
  return $self;
}

#internal function
sub search {
  my ($self,$start,$end,$index) = @_ ;

  # Binary search for the first element that is *entirely* before the
  # element to be inserted
  while ($start < $end) {
    my $mid = int(($start+$end)/2);
    if ($self->[$mid][1] < $index) {
      $start = $mid+1;
    } else {
      $end = $mid;
    }
  }
  return $start ;
}

# clear the range. Note the the $self ref is preserved
sub clear {
    my $self = shift;
    @$self = () ;
}

sub set_range_as_string {
    my $self = shift;
    my $str = shift;

    $str =~ s/\s//g;

    foreach my $substr (split /,/, $str) {
        my @range = $substr =~ /-/ ? split /-/,$substr : ($substr) x 2;
        $self->set_range(@range, @_);
    }
}

sub set {
    my $self = shift;
    my $idx = shift;

    $self->set_range($idx, $idx, @_);
}

sub set_range {
  my $self = shift;

  #Test that we were passed appropriate values
  @_ == 3 or @_ == 4 or
    croak("Array::IntSpan::set_range should be called with 3 values and an ".
          "optional code ref.");
  $_[0] <= $_[1] or
      croak("Array::IntSpan::set_range called with bad indices: ".
            "$_[0] and $_[1].");

  not defined $_[3] or ref($_[3]) eq 'CODE' or
    croak("Array::IntSpan::set_range called without 4th parameter ".
          "set as a sub ref");

  my ($offset,$length,@list) = $self -> get_splice_parms(@_) ;

  #print "splice $offset,$length,@list\n";
  splice @$self, $offset,$length,@list ;

  return $length ? 1 : 0 ;
}

# not well tested or documented. May be useless...
sub check_clobber {
  my $self = shift;

  my @clobbered = $self->clobbered_items(@_) ;

  map {warn "will clobber @$_ with @_\n" ;} @clobbered ;

  return @clobbered ;
}

sub get_element
  {
    my ($self,$idx) = @_;
    my $ref = $self->[$idx] ;
    return () unless defined $ref ;
    return @$ref ;
  }

# call-back:
# filler (start, end)
# copy (start, end, payload )
# set (start, end, payload)

sub get_range {
  my $self = shift;
  #my($new_elem) = [@_];
  my ($start_elem,$end_elem, $filler, $copy, $set) = @_ ;

  $copy = sub{$_[2];} unless defined $copy ;

  my $end_range = $#{$self};
  my $range_size = @$self ; # nb of elements

  # Before we binary search, first check if we fall before the range
  if ($end_range < 0 or $self->[$end_range][1] < $start_elem)
    {
      my @arg = ref($filler) ?
        ([$start_elem,$end_elem,&$filler($start_elem,$end_elem)]) :
          defined $filler ? ([@_]) : () ;
      push @$self, @arg if @arg;
      return ref($self)->new(@arg) ;
    }

  # Before we binary search, first check if we fall after the range
  if ($end_elem < $self->[0][0])
    {
      my @arg = ref($filler) ?
        ([$start_elem,$end_elem,&$filler($start_elem,$end_elem)]) :
          defined $filler ? ([@_]) : () ;
      unshift @$self, @arg  if @arg;
      return ref($self)->new(@arg) ;
    }

  my $start = $self->search(0,     $range_size,  $start_elem) ;
  my $end   = $self->search($start,$range_size,  $end_elem) ;

  my $start_offset = $start_elem - $self->[$start][0] ;
  my $end_offset   = defined $self->[$end] ?
    $end_elem - $self->[$end][0] : undef ;

  #print "get_range: start $start, end $end, start_offset $start_offset";
  #print ", end_offset $end_offset" if defined $end_offset ;
  #print "\n";

  my @extracted ;
  my @replaced ;
  my $length = 0;

  # handle the start
  if (defined $filler and $start_offset < 0)
    {
      my $e = min ($end_elem, $self->[$start][0]-1) ;
      my $new = ref($filler) ? &$filler($start_elem, $e) : $filler ;
      my @a = ($start_elem, $e, $new) ;
      # don't use \@a, as we don't want @extracted and @replaced to
      # point to the same memory area. But $new must point to the same
      # object
      push @extracted, [ @a ] ;
      push @replaced,  [ @a ] ;
    }

  if ($self->[$start][0] <= $end_elem)
    {
      my $s = max ($start_elem,$self->[$start][0]) ;
      my $e = min ($end_elem, $self->[$start][1]) ;
      my $payload = $self->[$start][2] ;
      if ($self->[$start][0] < $s)
        {
          my $s1 = $self->[$start][0];
          my $e1 = $s - 1 ;
          push @replaced, [$s1, $e1 , &$copy($s1,$e1,$payload) ];
        }
      # must duplicate the start, end variable
      push @extracted, [$s, $e, $payload];
      push @replaced, [$s, $e, $payload];
      if ($e < $self->[$start][1])
        {
          my $s3 = $e+1 ;
          my $e3 = $self->[$start][1] ;
          push @replaced, [$s3, $e3, &$copy($s3, $e3,$payload) ] ;
        }
      &$set($s,$e, $payload) if defined $set ;
      $length ++ ;
    }

  # handle the middle if any
  if ($start + 1 <= $end -1 )
    {
      #print "adding " ;
      foreach my $idx ( $start+1 .. $end - 1)
        {
          #print "idx $idx," ;
          if (defined $filler)
            {
              my $start_fill = $self->[$idx-1][1]+1 ;
              my $end_fill = $self->[$idx][0]-1 ;
              if ($start_fill <= $end_fill)
                {
                  my $new = ref($filler) ? &$filler($start_fill, $end_fill)
                    : $filler ;
                  push @extracted, [$start_fill, $end_fill, $new] ;
                  push @replaced,  [$start_fill, $end_fill, $new];
                }
            }
          push @extracted, [@{$self->[$idx]}];
          push @replaced , [@{$self->[$idx]}];
          $length++ ;
        }
      #print "\n";
    }

  # handle the end
  if ($end > $start)
    {
      if (defined $filler)
        {
          # must add end element filler
          my $start_fill = $self->[$end-1][1]+1 ;
          my $end_fill = (not defined $end_offset or $end_offset < 0) ?
            $end_elem :  $self->[$end][0]-1 ;
          if ($start_fill <= $end_fill)
            {
              my $new = ref($filler) ? &$filler($start_fill, $end_fill) :
                $filler ;
              push @extracted, [$start_fill, $end_fill, $new] ;
              push @replaced,  [$start_fill, $end_fill, $new];
            }
        }

      if (defined $end_offset and $end_offset >= 0)
        {
          my $payload = $self->[$end][2] ;
          my $s = $self->[$end][0] ;
          my @a = ($s,$end_elem, $payload) ;
          push @extracted, [@a];
          push @replaced , [@a];
          if ($end_elem < $self->[$end][1])
            {
              my $s2 = $end_elem + 1 ;
              my $e2 = $self->[$end][1] ;
              push @replaced , [$s2, $e2, &$copy($s2,$e2,$payload)];
            }
          &$set($s,$end_elem, $payload) if defined $set ;
          $length++ ;
        }
    }

  if (defined $filler)
    {
      splice (@$self, $start,$length , @replaced) ;
    }

  my $ret = ref($self)->new(@extracted) ;
  return $ret ;
}

sub clobbered_items {
  my $self = shift;
  my($range_start,$range_stop,$range_value) = @_;

  my $item = $self->get_range($range_start,$range_stop) ;

  return   grep {$_->[2] ne $range_value} @$item ;
}


# call-back:
# set (start, end, payload)
sub consolidate {
  my ($self,$bottom,$top,$set) = @_;

  $bottom = 0 if (not defined $bottom or $bottom < 0 );
  $top = $#$self if (not defined $top or $top > $#$self) ;

  #print "consolidate from $top to $bottom\n";

  for (my $i= $top; $i>0; $i--)
    {
      if ($self->[$i][2] eq $self->[$i-1][2] and
          $self->[$i][0] == $self->[$i-1][1]+1 )
        {
          #print "consolidate splice ",$i-1,",2\n";
          my ($s,$e,$p) = ($self->[$i-1][0], $self->[$i][1], $self->[$i][2]);
          splice @$self, $i-1, 2, [$s, $e, $p] ;
          $set->($s,$e,$p) if defined $set ;
        }
    }

}

sub set_consolidate_range {
  my $self = shift;

  #Test that we were passed appropriate values
  @_ == 3 or @_ == 5 or
    croak("Array::IntSpan::set_range should be called with 3 values ".
          "and 2 optional code ref.");
  $_[0] <= $_[1] or
      croak("Array::IntSpan::set_range called with bad indices: $_[0] and $_[1].");

  not defined $_[3] or ref($_[3]) eq 'CODE' or
    croak("Array::IntSpan::set_range called without 4th parameter set as a sub ref");

  my ($offset,$length,@list) = $self -> get_splice_parms(@_[0,1,2,3]) ;

  #print "splice $offset,$length\n";
  splice @$self, $offset,$length,@list ;
  my $nb = @list ;

  $self->consolidate($offset - 1 , $offset+ $nb , $_[4]) ;

  return $length ? 1 : 0 ;#($b , $t ) ;

}

# get_range_list
# scalar context -> return a string
# list context => returns list of list

sub get_range_list {
    my ($self, %options) = @_;
    if (wantarray) {
        return map { [ @$_[0,1] ] } @$self;
    }
    else {
        return join ', ' , map {
            my ($a,$b) =  @$_;
                  $a == $b ? $a
                : $a+1==$b ? join(', ',$a,$b)
                :            join('-',$a,$b);
        } @$self;
    }
}

# internal function
# call-back:
# copy (start, end, payload )
sub get_splice_parms {
  my $self = shift;
  my ($start_elem,$end_elem,$value,$copy) = @_ ;

  my $end_range = $#{$self};
  my $range_size = @$self ; # nb of elements

  #Before we binary search, we'll first check to see if this is an append operation
  if ( $end_range < 0 or
      $self->[$end_range][1] < $start_elem
     )
    {
      return defined $value ? ( $range_size, 0, [$start_elem,$end_elem,$value]) :
        ($range_size, 0) ;
    }

  # Check for prepend operation
  if ($end_elem < $self->[0][0] ) {
    return defined $value ? ( 0 , 0, [$start_elem,$end_elem,$value]) : (0,0);
  }

  #Binary search for the first element after the last element that is entirely
  #before the element to be inserted (say that ten times fast)
  my $start = $self->search(0,     $range_size,  $start_elem) ;
  my $end   = $self->search($start,$range_size,  $end_elem) ;

  my $start_offset = $start_elem - $self->[$start][0] ;
  my $end_offset   = defined $self->[$end] ?
    $end_elem - $self->[$end][0] : undef ;

  #print "get_splice_parms: start $start, end $end, start_offset $start_offset";
  #print ", end_offset $end_offset" if defined $end_offset ;
  #print "\n";

  my @modified = () ;

  #If we are here, we need to test for whether we need to frag the
  #conflicting element
  if ($start_offset > 0) {
    my $item = $self->[$start][2] ;
    my $s = $self->[$start][0] ;
    my $e = $start_elem-1 ;
    my $new = defined($copy) ? $copy->($s,$e,$item) : $item ;
    push @modified ,[$s, $e, $new ];
  }

  push @modified, [$start_elem,$end_elem,$value] if defined $value ;

  #Do a fragmentation check
  if (defined $end_offset
      and $end_offset >= 0
      and $end_elem < $self->[$end][1]
     ) {
    my $item = $self->[$end][2] ;
    my $s = $end_elem+1 ;
    my $e = $self->[$end][1] ;
    my $new = defined($copy) ? $copy->($s,$e,$item) : $item ;
    push @modified , [$s, $e, $new] ;
  }

  my $extra =  (defined $end_offset and $end_offset >= 0) ? 1 : 0 ;

  return ($start, $end - $start + $extra , @modified);
}

sub lookup {
  my $self = shift;
  my($key) = @_;

  my($start, $end) = (0, $#{$self});
  return undef unless $end >= 0 ; # completely empty span

  while ($start < $end) {
    my $mid = int(($start+$end)/2);
    if ($self->[$mid][1] < $key) {
      $start = $mid+1;
    } else {
      $end = $mid;
    }
  }
  if ($self->[$start]->[0] <= $key && $self->[$start]->[1] >= $key) {
    return $self->[$start]->[2];
  }
  return undef;
}

sub _check_structure {
  my $self = shift;

  return unless $#$self >= 0;

  foreach my $i (0..$#$self) {
    @{$self->[$i]} == 3 or
        croak("Array::IntSpan::_check_structure failed - element $i lacks 3 entries.");
    $self->[$i][0] <= $self->[$i][1] or
        croak("Array::IntSpan::_check_structure failed - element $i has bad indices.");
    if ($i > 0) {
      $self->[$i-1][1] < $self->[$i][0] or
          croak("Array::IntSpan::_check_structure failed - element $i (",
                ,$self->[$i][0],",",$self->[$i][1],
                ") doesn't come after previous element (",
                $self->[$i-1][0],",",$self->[$i-1][1],")");
    }
  }
}

#The following code is courtesy of Mark Jacob-Dominus,
sub croak {
  require Carp;
  no warnings 'redefine' ;
  *croak = \&Carp::croak;
  goto &croak;
}

1;

__END__