File Coverage

blib/lib/Math/InterpolationCompiler.pm

Criterion	Covered	Total	%
statement	76	79	96.2
branch	24	34	70.5
condition	5	9	55.5
subroutine	10	10	100.0
pod	0	2	0.0
total	115	134	85.8

package Math::InterpolationCompiler;
use 5.006001;
use Moo 2;
use Types::Standard 1;
use Carp;

our $VERSION= '0.001000';

# ABSTRACT: Compile interpolations into perl coderefs


has domain        => ( is => 'ro', isa => Types::Standard::ArrayRef, required => 1 );
has range         => ( is => 'ro', isa => Types::Standard::ArrayRef, required => 1 );
has algorithm     => ( is => 'ro', default => sub { 'linear' } );
has beyond_domain => ( is => 'ro', default => sub { 'clamp' } );
has perl_code     => ( is => 'lazy' );
has fn            => ( is => 'lazy' );
has sanitize      => ( is => 'ro', default => sub { 1 } );

sub BUILDARGS {
	my $self= shift;
	my $args= $self->next::method(@_);
	if ($args->{points} && !$args->{domain} && !$args->{range}) {
		my (@domain, @range);
		for (@{ delete $args->{points} }) {
			push @domain, $_->[0];
			push @range,  $_->[1];
		}
		$args->{domain}= \@domain;
		$args->{range}=  \@range;
	}
	return $args;
}

sub _sanitize_number_array {
	return [
		map {
			defined $_ or croak " is not a number";
			my $n= "$_";
			$n =~ /^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$/ or croak "$n is not a number";
			$n
		} @{ $_[0] }
	];
}

sub BUILD {
	my $self= shift;
	@{ $self->domain } == @{ $self->range }
		or croak "Domain and range differ in length (".@{ $self->domain }." != ".@{ $self->range }.")";
	@{ $self->domain } > 1
		or croak "Domain does not contain any intervals";
	my $prev;
	if ($self->sanitize) {
		$self->{domain}= _sanitize_number_array($self->domain);
		$self->{range}=  _sanitize_number_array($self->range);
	}
	for (@{ $self->domain }) {
		croak "Domain is not sorted in non-decreasing order"
			if defined $prev && $_ < $prev;
		$prev= $_;
	}
	$self->can("_gen_".$self->algorithm)
		or croak "Unknown algorithm ".$self->algorithm;
}

sub _build_perl_code {
	my $self= shift;
	my $method= $self->can("_gen_".$self->algorithm);
	return $self->$method;
}

sub _build_fn {
	my $self= shift;
	my $sub= eval $self->perl_code
		or croak "Failed to build function: $@";
	return $sub;
}

# Create a linear interpolation
sub _gen_linear {
	my $self= shift;
	my $domain= $self->domain;
	my $range= $self->range;
	my @expressions;
	for (my $i= 1; $i < @$domain; $i++) {
		# skip discontinuities
		next if $domain->[$i] == $domain->[$i-1];
		# calculate slope and offset at x0
		my $m= ($range->[$i] - $range->[$i-1]) / ($domain->[$i] - $domain->[$i-1]);
		my $b= $range->[$i-1] - $domain->[$i-1] * $m;
		# generate code
		push @expressions, [ $domain->[$i-1], '$x * '.$m.' + '.$b ];
	}
	if ($self->beyond_domain eq 'clamp') {
		unshift @expressions, [ undef, $range->[0] ];
		push    @expressions, [ $domain->[-1], $range->[-1] ];
	}
	elsif ($self->beyond_domain eq 'extrapolate') {
		# just let the edge expressions do their thing
		# ... unless there were discontinuities at the edges
		unshift @expressions, [ undef, $range->[0] ]
			if $domain->[0] == $domain->[1];
		push    @expressions, [ $domain->[-1], $range->[-1] ]
			if $domain->[-1] == $domain->[-2];
	}
	elsif ($self->beyond_domain eq 'undef') {
		unshift @expressions, [ undef, 'undef' ];
		push    @expressions, [ $domain->[-1], '$x == '.$domain->[-1].'? ('.$range->[-1].') : undef' ];
	}
	elsif ($self->beyond_domain eq 'die') {
		unshift @expressions, [ undef, 'die "argument out of bounds (<'.$domain->[0].')"' ];
		push    @expressions, [ $domain->[-1], '$x == '.$domain->[-1].'? ('.$range->[-1].') : die "argument out of bounds (>'.$domain->[-1].')"' ];
	}
	else {
		croak "Algorithm 'linear' does not support domain-edge '".$self->beyond_domain."'";
	}
	# Now tree-up the expressions
	while (@expressions > 1) {
		my ($i, $dest);
		for ($i= 1, $dest= 0; $i < @expressions; $i+= 2) {
			$expressions[$dest++]= [
				$expressions[$i-1][0],
				'$x < '.$expressions[$i][0]."?"
				.' ('.$expressions[$i-1][1].")"
				.':('.$expressions[$i][1].")"
			];
		}
		# odd number?
		if ($i == @expressions) {
			$expressions[$dest++]= $expressions[-1];
		}
		# truncate list
		$#expressions= $dest-1;
	}
	# finally, wrap with function
	return "sub {\n my \$x= shift;\n return ".$expressions[0][1].";\n}\n";
}

1;

__END__