File Coverage

blib/lib/Text/NumericData/Calc.pm

Criterion	Covered	Total	%
statement	60	87	68.9
branch	17	36	47.2
condition	2	3	66.6
subroutine	5	7	71.4
pod	3	6	50.0
total	87	139	62.5

package Text::NumericData::Calc;

use Math::Trig;
require Exporter;

# This is just a placeholder because of a past build system bug.
# The one and only version for Text::NumericData is kept in
# the Text::NumericData module itself.
our $VERSION = '1';
$VERSION = eval $VERSION;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(linear_value parsed_formula formula_function expression_function);

our $epsilon = 1e-15;

#a hack for gauss() function to use in formulae
#not fully verified yet  - and not normalized!
our $cache = undef;
sub gauss
{
	#Polar-Methode
	my $x;
	if(defined $cache)
	{
		$x = $cache;
		undef $cache;
	}
	else
	{
		my ($u1,$u2,$v);
		do
		{
			$u1 = rand();
			$u2 = rand();
			$v = (2*$u1-1)**2+(2*$u2-1)**2;
		}
		while($v >= 1);
		$cache = (2*$u2-1)*sqrt(-2*log($v)/$v);
		$x = (2*$u1-1)*sqrt(-2*log($v)/$v);
	}
	return $x;
}

# helper for floating point comparisons
sub near
{
	my ($a, $b, $eps) = @_;
	$eps = $epsilon unless defined $eps;

	return (abs($a-$b) < $eps);
}


#linear_value(x,[x1,x2],[y1,y2])
sub linear_value
{
	my ($x,$ox,$oy) = @_;
	return $ox->[0] != $ox->[1] ? ( $oy->[0] + ($oy->[1]-$oy->[0])*($x-$ox->[0])/($ox->[1]-$ox->[0]) ) : ( $x == $ox->[0] ? ($oy->[0]+$oy->[1])/2 : undef );
}

#parsed_formula(text, dataarrayname, pararrayname1, pararrayname2)
#A -> pararray1
#C -> pararray2
#[a,b] -> data[a][b]
#parsed_formula(text, dataarrayname, arraynamedef)
#arraynamedef: { A=>'A->', B=>'B->', X=>'xarr->', Z=>'zulu->' }

sub parsed_formula
{
	my ($form, $data, $par1, $par2) = @_;
	my $ardef;
	if(ref $par1 eq 'HASH')
	{
		$ardef = $par1;
	}
	else
	{
		$ardef = {A=>$par1, C=>$par2};
	}
	my @formlines = split("\n", $form);
	my $nnf = '';

	foreach my $formula (@formlines)
	{
		my $nf = '';
		#$ord$ord is not translated correctly but is not correct syntax anyway
		{ # Parse shortcut vars.
			my %defs =
			(
				 'x',   '[0,1]'
				,'y',   '[0,2]'
				,'z',   '[0,3]'
			);
			#print STDERR "shortcut parsing: $formula\n";
			while($formula =~ /^(.*)([^a-zA-Z\$]|^)(\$?([xab]|ord))([^(a-zA-Z]|$)(.*)$/m)
			{
				#print STDERR "found $4 (def=$defs{$4})\n";
				$formula = $1.$2.$defs{$4}.$5.$6;
			}
			#print STDERR "done shortcut parsing: $formula\n";
		}
		# Match any relevant [...] and stuff before it; parse and cut from formula.
		#print STDERR "formula: $formula\n";
		while($formula =~ s/\A([^[]*[^[a-zA-Z]|)\[\s*(([^[\],]+)(\s*,\s*([^[\],]+)|)\s*)\s*\]//)
		{
			#print STDERR "results: $1 : $2 : $3 : $4 : $5\n";
			#print STDERR "formula: $formula\n";
			$nf .= $1;
			my $num1 = $3;
			my $num2 = $5;
			unless(defined $num2)
			{
				$num2 = $num1;
				$num1 = 0;
			}
			if(($num1 =~ /^\d+$/) and ($num1 < 0))
			{
				print STDERR "File index $num1 < 0 !\n";
				return undef;
			}
			if($num2 =~ /^\d+$/)
			{
				--$num2;
				if($num2 < 0)
				{
					print STDERR "Dataset index $num2 < 0 !\n";
					return undef;
				}
			}
			else{ $num2 = "($num2)-1"; }
			$nf .= '$'.$data."[$num1][$num2]";
			#print STDERR "nf:      $nf\n";
		}

		$nf .= $formula;
		for(keys %{$ardef})
		{
			$nf =~ s/(^|[^\$a-zA-Z])$_(\d+)/$1\$$ardef->{$_}\[$2\]/g;
		}
		if($nnf ne ''){ $nnf .= "\n"; }
		$nnf .= $nf;
	}
	return $nnf;
}

#(formula [, config])
sub formula_function
{
	my ($formula,$cfg) = (shift, shift);
	my @ar = qw(A C);
	push(@ar, @_); # additional names arrays to insert
	my %ardef = map { $_ => $_.'->' } @ar;
	my $config = defined $cfg
		? $cfg
		: {verbose=>0, plainperl=>0};
	my $pf = $config->{plainperl}
		? $formula
		: parsed_formula($formula, 'fd->', \%ardef);
	unless(defined $pf)
	{
		$@ = "Text::NumericData::Calc: Error parsing the formula!";
		return undef;
	}
	my $ffc = 'sub { my ($fd, '.join(', ', map {'$'.$_} @ar).') = @_; '.$pf.' ; return 0; }';
	if(defined $config->{verbose})
	{
		print STDERR "Formula code: ".$pf."\n"
			if $config->{verbose};
		print STDERR "Formula function code: ".$ffc."\n"
			if $config->{verbose} > 1;
	}
	return eval $ffc;
}

# same as above, code differs in that it returns the expression indicated by formula
sub expression_function
{
	my $formula = shift;
	my $verb = shift;
	my @ar = qw(A C);
	push(@ar, @_); # additional names arrays to insert
	my %ardef = map { $_ => $_.'->' } @ar;
	my $pf = parsed_formula($formula,  'fd->', \%ardef);
	unless(defined $pf)
	{
		$@ = "Text::NumericData::Calc: Error parsing the formula!";
		return undef;
	}
	print STDERR "Formula code: ",$pf,"\n" if $verb;
	return eval 'sub { my ($fd, '.join(', ', map {'$'.$_} @ar).') = @_; return ('.$pf.'); }';
}

1;
__END__