File Coverage

blib/lib/Math/Prime/Util/PrimeArray.pm

Criterion	Covered	Total	%
statement	79	85	92.9
branch	20	30	66.6
condition	15	15	100.0
subroutine	15	20	75.0
pod			n/a
total	129	150	86.0

package Math::Prime::Util::PrimeArray;
use strict;
use warnings;

BEGIN {
  $Math::Prime::Util::PrimeArray::AUTHORITY = 'cpan:DANAJ';
  $Math::Prime::Util::PrimeArray::VERSION = '0.73';
}

# parent is cleaner, and in the Perl 5.10.1 / 5.12.0 core, but not earlier.
# use parent qw( Exporter );
use base qw( Exporter );
our @EXPORT_OK = qw(@primes @prime @pr @p $probj);
our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);

# It would be nice to do this dynamically.
our(@primes, @prime, @pr, @p, $probj);
sub import {
  tie @primes, __PACKAGE__ if grep { $_ eq '@primes' } @_;
  tie @prime , __PACKAGE__ if grep { $_ eq '@prime'  } @_;
  tie @pr    , __PACKAGE__ if grep { $_ eq '@pr'     } @_;
  tie @p     , __PACKAGE__ if grep { $_ eq '@p'      } @_;
  $probj = __PACKAGE__->TIEARRAY if grep { $_ eq '$probj' } @_;
  goto &Exporter::import;
}

use Math::Prime::Util qw/nth_prime nth_prime_upper nth_prime_lower primes prime_precalc next_prime prev_prime/;
use Tie::Array;
use Carp qw/carp croak confess/;

use constant SEGMENT_SIZE  =>  50_000;
use constant ALLOW_SKIP    =>  3_000;     # Sieve if skipping up to this

sub TIEARRAY {
  my $class = shift;
  if (@_) {
    croak "usage: tie ARRAY, '" . __PACKAGE__ . "";
  }
  return bless {
    # used to keep track of shift
    SHIFTINDEX => 0,
    # Remove all extra prime memory when we go out of scope
    MEMFREE    => Math::Prime::Util::MemFree->new,
    # A chunk of primes
    PRIMES     => [2, 3, 5, 7, 11, 13, 17],
    # What's the index of the first one?
    BEG_INDEX  => 0,
    # What's the index of the last one?
    END_INDEX  => 6,
    # positive = forward, negative = backward, 0 = random
    ACCESS_TYPE => 0,
  }, $class;
}
sub STORE     { carp "You cannot write to the prime array"; }
sub DELETE    { carp "You cannot write to the prime array"; }
sub STORESIZE { carp "You cannot write to the prime array"; }
sub EXISTS    { 1 }
#sub EXTEND    { my $self = shift; my $count = shift; prime_precalc($count); }
sub EXTEND    { 1 }
sub FETCHSIZE { 0x7FFF_FFFF }   # Even on 64-bit
# Simple FETCH:
# sub FETCH { return nth_prime($_[1]+1); }

sub FETCH {
  my ($self, $index) = @_;
  $index = 0xFFFFFFFF + $index + 1 if $index < 0;
  $index += $self->{SHIFTINDEX};  # take into account any shifts
  my $begidx = $self->{BEG_INDEX};
  my $endidx = $self->{END_INDEX};

  if ( $index < $begidx || $index > $endidx ) {

    if ($index > $endidx && $index < $endidx + ALLOW_SKIP) { # Forward iteration

      $self->{ACCESS_TYPE}++;
      if ($self->{ACCESS_TYPE} > 2 || $index > $endidx+1) {
        my $end_prime = nth_prime_upper($index + SEGMENT_SIZE);
        $self->{PRIMES} = primes( $self->{PRIMES}->[-1]+1, $end_prime );
        $begidx = $endidx+1;
      } else {
        push @{$self->{PRIMES}}, next_prime($self->{PRIMES}->[-1]);
      }

    } elsif ($index < $begidx && $index > $begidx - ALLOW_SKIP) { # Bk iteration

      $self->{ACCESS_TYPE}--;
      if ($self->{ACCESS_TYPE} < -2 || $index < $begidx-1) {
        my $beg_prime = $index <= SEGMENT_SIZE
                               ?  2  :  nth_prime_lower($index - SEGMENT_SIZE);
        $self->{PRIMES} = primes($beg_prime, $self->{PRIMES}->[0]-1);
        $begidx -= scalar @{ $self->{PRIMES} };
      } else {
        $begidx--;
        unshift @{$self->{PRIMES}}, prev_prime($self->{PRIMES}->[0]);
      }

    } else {                         # Random access

      $self->{ACCESS_TYPE} = int($self->{ACCESS_TYPE} / 2);
      # Alternately we could get a small window, but that will be quite
      # a bit slower if true random access.
      $begidx = $index;
      $self->{PRIMES} = [nth_prime($begidx+1)];

    }
    $self->{BEG_INDEX} = $begidx;
    $self->{END_INDEX} = $begidx + scalar @{$self->{PRIMES}} - 1;
  }
  return $self->{PRIMES}->[ $index - $begidx ];
}

# Fake out shift and unshift
sub SHIFT {
  my $self = shift;
  my $head = $self->FETCH(0);
  $self->{SHIFTINDEX}++;
  $head;
}
sub UNSHIFT {
  my ($self, $shiftamount) = @_;
  $shiftamount = 1 unless defined $shiftamount;
  $self->{SHIFTINDEX} = ($shiftamount >= $self->{SHIFTINDEX})
                        ? 0
                        : $self->{SHIFTINDEX} - $shiftamount;
  $self->FETCHSIZE;
}
# CLEAR this
# PUSH this, LIST
# POP this
# SPLICE this, offset, len, LIST
# DESTROY this
# UNTIE this

1;

__END__