File Coverage

blib/lib/Tie/LazyList.pm

Criterion	Covered	Total	%
statement	73	140	52.1
branch	26	42	61.9
condition	3	6	50.0
subroutine	11	24	45.8
pod	0	1	0.0
total	113	213	53.0

# Package implementing a "lazy lists" via a tied arrays
package Tie::LazyList;

use 5.006;
use strict;
use warnings;
use Carp;

require Exporter;

our @ISA         = qw( Exporter );
our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK   = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT      = qw();
our $VERSION     = '0.05';


# debug variable that may be set to see the debug messages
our $debug       = 0;
sub debug ($) { print $_[0], "\n" if $debug }


# "Locality" factor - how many additional elements will be filled when
# extending an array
our $locality    = 10;


# Returns TRUE is passed parameter is a number, FALSE otherwise
# ( thank's to Joseph Hall for the trick :)
sub _is_number {
	my $number = @_ ? shift : $_;
	( ~$number & $number ) eq '0';
}

# Returns the result of applying the passed operation on two first numbers of array
# after checking that they're *really* numbers
sub _factor ($$){
	local $_;
	my ( $array_ref, $op ) = @_;
	for ( @{ $array_ref }[ 0, 1 ] ){
		( defined and _is_number()) or croak "Illegal array init by not a number !";
	}
	# checking the "division by zero" case
	if (( $op eq '/' ) and ( $array_ref->[0] == 0 )){
		croak "Illegal attempt to divide by zero !";
	}

	eval "$array_ref->[1] $op $array_ref->[0]";
}



# Predefined code abbreviations
my %CODES_ABBREV =
	(	# Arithmetic progression
		APROG     => sub {
							my ( $array_ref ) = @_;
							my $factor = _factor( $array_ref, '-' ); # factor = arr[1] - arr[0]
							sub {
								my ( $array_ref, $n ) = @_;
								$array_ref->[ $n - 1 ] + $factor;
							}
						 },
		# Geometric progression
		GPROG     => sub {
							my ( $array_ref ) = @_;
							my $factor = _factor( $array_ref, '/' ); # factor = arr[1] / arr[0]
							sub {
								my ( $array_ref, $n ) = @_;
								$array_ref->[ $n - 1 ] * $factor;
							}
						 },
		# Summary of arithmetic progression
		APROG_SUM => sub {
							my ( $array_ref ) = @_;
							my $factor = _factor( $array_ref, '-' ); # factor = arr[1] - arr[0]
							return (
								sub {
									my ( $array_ref, $n ) = @_;       # n - zero based
									my $a_0 = $array_ref->[ 0 ];      # a0
									my $a_n = $a_0 + ($factor * $n);  # an = a0 + d*n
									$array_ref->[ $n - 1 ] + $a_n;    # S(n) = S(n-1) + an
								},
								# truncating the rest of the array - we have the first elem and the factor
								[ $array_ref->[ 0 ]]
							)
						 },
		# Summary of geometric progression
		GPROG_SUM => sub {
							my ( $array_ref ) = @_;
							my $factor = _factor( $array_ref, '/' ); # factor = arr[1] / arr[0]
							return (
								sub {
									my ( $array_ref, $n ) = @_;       # n - zero based
									my $a_0 = $array_ref->[ 0 ];      # a0
									my $a_n = $a_0 * ($factor ** $n); # an = a0 * q^n
									$array_ref->[ $n - 1 ] + $a_n;    # S(n) = S(n-1) + an
								},
								# truncating the rest of the array - we have the first elem and the factor
								[ $array_ref->[ 0 ]]
							)
						 },
		 FIBON    => sub {
						 	my ( $array_ref ) = @_;
						 	@{ $array_ref } >= 2 or croak "Illegal array init - should be two elements at least !";
		 					sub {
		 						my ( $array_ref, $n ) = @_;
		 						$array_ref->[ $n - 1 ] + $array_ref->[ $n - 2 ];
		 					}
		 				 },
		 FACT     => sub {
						 	my ( $array_ref ) = @_;
						 	@{ $array_ref } >= 1 or croak "Illegal array init - should be one element at least !";
		 					sub {
		 						my ( $array_ref, $n ) = @_;
		 						$array_ref->[ $n - 1 ] * $n;
		 					}
						 },
		 POW      => sub {
							my ( $array_ref ) = @_;
							_is_number( my $x = $array_ref->[0] ) or croak "Illegal array init by not a number !";
							$x == 0 and croak "Illegal array init with zero !";
							return (
								sub {
									my ( $array_ref, $n ) = @_;
									$array_ref->[ $n - 1 ] * $x;
								},
								[ 1 ] # starting with x^0 = 1
							);
						 }
	);



sub TIEARRAY {
	local $_;
	my $class          = shift   or croak "Undefined class !";
	defined ( my $init = shift ) or croak "Undefined array init !"; # may be a scalar or ARRAY ref

	# List's initialization variables to be set now :
	my ( @arr,         # list's main array, should be initialized
	     $code_ref );  # list's generation function

	# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# setting @arr and, possibly, $code_ref ( $code_ref will be set if the init
	# passed is a reference to another array tied to LazyList )

	my $ref = ref $init;

	unless ( $ref ){
		# init is a simple scalar variable
		@arr = ( $init );
	} elsif ( $ref eq 'ARRAY' ){
		# init is a reference to ARRAY and it may be :
		# 1) ref to another array tied to LazyList
		# 2) ref to a usual Perl array
		my $tied_object = tied @{ $init };
		if ( defined $tied_object ){
			# 1)
			$tied_object->isa( $class )
				or croak "Reference to a tied object passed which isn't a [$class] instance !";
			# taking the initialization data from this tied object : init_array and code
			my ( $init_array, $code ) = $tied_object->_init_data();
			@arr      = @{ $init_array };
			$code_ref = $code;
		}
		else {
			# 2)
			@arr = @{ $init };
		}
	} else {
		# init is an unexpected reference
		croak "Unknown [$ref] referenece passed for initializing the list !";
	}


	# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# setting $code_ref ( if it wasn't set by above block ) and, possibly, @arr again
	# ( @arr will be set again if the code abbreviation that was used will return a
	# new array when fetched from the code's table )

	unless ( defined $code_ref ){

      # code is sitting in @_ and should be a scalar or CODE ref
      my $code = shift or croak "Undefined code !";
		my $ref  = ref $code;

		unless ( $ref ){
			# code is a scalar variable, should be one of the predefined code abbreviations
			exists $CODES_ABBREV{ $code } or croak "Unknown scalar [$code] passed as code abbreviation !";
			# getting the code and, possibly, array_ref for the new array
			my ( $returned_code, $array_ref ) = $CODES_ABBREV{ $code }->( \@arr );
			$code_ref = $returned_code;
			@arr      = @{ $array_ref } if defined $array_ref;
		} elsif ( $ref eq 'CODE' ){
			# code is a CODE reference
			$code_ref = $code;
		} else {
			# code is an unexpected reference
			croak "Unknown [$code_ref] reference passed as a code !";
		}
	}

	# sanity-check of result initializations
	ref [ @arr ]  eq 'ARRAY' or die "Failed to successfully initialize the array ! \a";
	ref $code_ref eq 'CODE'  or die "Failed to successfully initialize code reference ! \a";


	bless { array      => \@arr,         # the main list that will be used and expanded
			  init_array => \@arr,         # keeping the initialization array
	        code       => $code_ref,     # the generation function
	        'length'   => scalar @arr }, # the current length, will be updated every time it changes
			$class;
}


# returns the init_array ref and the code ref ( used for creating
# another tied array, initialized exactly as this one )
sub _init_data {
	local $_;
	my $self = shift;
	@{ $self }{ qw ( init_array code ) };
}


sub FETCH {
	debug "FETCH(@_)";
	local $_;
	my $self = shift;
	my ( $index ) = @_;
	my ( $array_ref, $length, $code_ref ) = @{ $self }{ qw ( array length code )};

	unless ( $index < $length ){           # we should extend the array
		my $top_fill = $index + $locality;  # top index to be filled
		$#{ $array_ref } = $top_fill;       # pre-extending array for the efficiency
		for ( $length .. $top_fill ){
			$array_ref->[ $_ ] = $code_ref->( $array_ref, $_ );
		}
		$self->{ 'length' } = $top_fill + 1;
	}

	$array_ref->[ $index ];
}

sub STORE {
	debug "STORE(@_)";
	local $_;
	my $self = shift;
	my ( $index, $value ) = @_;
	if ( defined $value ){
		$self->{ array }[ $index ] == $value or # <-- used by Perl during 'for ( @array )' loop
			croak "No STORE operation supported for class [@{[ ref $self ]}] !";
	}
}


sub FETCHSIZE {
	debug "FETCHSIZE(@_)";
	local $_;
	my $self = shift;
	$self->{ 'length' } + 1; # to make 'for ( @array )' loop iterate infinitely
}

sub STORESIZE {
	debug "STORESIZE(@_)";
	local $_;
	my $self = shift;
	croak "No STORESIZE operation supported for class [@{[ ref $self ]}] !";
}

sub EXTEND {
	debug "EXTEND(@_)";
	local $_;
	my $self = shift;
	croak "No EXTEND operation supported for class [@{[ ref $self ]}] !";
}

sub EXISTS {
	debug "EXISTS(@_)";
	local $_;
	my $self = shift;
	croak "No EXISTS operation supported for class [@{[ ref $self ]}] !";
}

sub DELETE {
	debug "DELETE(@_)";
	local $_;
	my $self = shift;
	croak "No DELETE operation supported for class [@{[ ref $self ]}] !";
}

sub CLEAR {
	debug "CLEAR(@_)";
	local $_;
	my $self = shift;
	croak "No CLEAR operation supported for class [@{[ ref $self ]}] !";
}

sub PUSH {
	debug "PUSH(@_)";
	local $_;
	my $self = shift;
	croak "No PUSH operation supported for class [@{[ ref $self ]}] !";
}

sub POP {
	debug "POP(@_)";
	local $_;
	my $self = shift;
	croak "No POP operation supported for class [@{[ ref $self ]}] !";
}

sub SHIFT {
	debug "SHIFT(@_)";
	local $_;
	my $self = shift;
	croak "No SHIFT operation supported for class [@{[ ref $self ]}] !";
}

sub UNSHIFT {
	debug "UNSHIFT(@_)";
	local $_;
	my $self = shift;
	croak "No UNSHIFT operation supported for class [@{[ ref $self ]}] !";
}

sub SPLICE {
	debug "SPLICE(@_)";
	local $_;
	my $self = shift;
	croak "No SPLICE operation supported for class [@{[ ref $self ]}] !";
}

sub UNTIE {
	debug "UNTIE(@_)";
	local $_;
	my $self = shift;
}

sub DESTROY {
	debug "DESTROY(@_)";
	local $_;
	my $self = shift;
}


1;

__END__