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


line stmt bran cond sub pod time code
1             package Text::NumericData::Calc;
2              
3 9     9   1322 use Math::Trig;
  9         51784  
  9         12137  
4             require Exporter;
5              
6             # This is just a placeholder because of a past build system bug.
7             # The one and only version for Text::NumericData is kept in
8             # the Text::NumericData module itself.
9             our $VERSION = '1';
10             $VERSION = eval $VERSION;
11              
12             our @ISA = qw(Exporter);
13             our @EXPORT_OK = qw(linear_value parsed_formula formula_function expression_function);
14              
15             our $epsilon = 1e-15;
16              
17             #a hack for gauss() function to use in formulae
18             #not fully verified yet - and not normalized!
19             our $cache = undef;
20             sub gauss
21             {
22             #Polar-Methode
23 0     0 0 0 my $x;
24 0 0       0 if(defined $cache)
25             {
26 0         0 $x = $cache;
27 0         0 undef $cache;
28             }
29             else
30             {
31 0         0 my ($u1,$u2,$v);
32             do
33 0         0 {
34 0         0 $u1 = rand();
35 0         0 $u2 = rand();
36 0         0 $v = (2*$u1-1)**2+(2*$u2-1)**2;
37             }
38             while($v >= 1);
39 0         0 $cache = (2*$u2-1)*sqrt(-2*log($v)/$v);
40 0         0 $x = (2*$u1-1)*sqrt(-2*log($v)/$v);
41             }
42 0         0 return $x;
43             }
44              
45             # helper for floating point comparisons
46             sub near
47             {
48 0     0 0 0 my ($a, $b, $eps) = @_;
49 0 0       0 $eps = $epsilon unless defined $eps;
50              
51 0         0 return (abs($a-$b) < $eps);
52             }
53              
54              
55             #linear_value(x,[x1,x2],[y1,y2])
56             sub linear_value
57             {
58 180     180 1 502 my ($x,$ox,$oy) = @_;
59 180 0       1574 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 );
    50          
60             }
61              
62             #parsed_formula(text, dataarrayname, pararrayname1, pararrayname2)
63             #A -> pararray1
64             #C -> pararray2
65             #[a,b] -> data[a][b]
66             #parsed_formula(text, dataarrayname, arraynamedef)
67             #arraynamedef: { A=>'A->', B=>'B->', X=>'xarr->', Z=>'zulu->' }
68              
69             sub parsed_formula
70             {
71 19     19 1 71 my ($form, $data, $par1, $par2) = @_;
72 19         40 my $ardef;
73 19 50       84 if(ref $par1 eq 'HASH')
74             {
75 19         45 $ardef = $par1;
76             }
77             else
78             {
79 0         0 $ardef = {A=>$par1, C=>$par2};
80             }
81 19         87 my @formlines = split("\n", $form);
82 19         56 my $nnf = '';
83              
84 19         54 foreach my $formula (@formlines)
85             {
86 19         44 my $nf = '';
87             #$ord$ord is not translated correctly but is not correct syntax anyway
88             { # Parse shortcut vars.
89 19         38 my %defs =
  19         112  
90             (
91             'x', '[0,1]'
92             ,'y', '[0,2]'
93             ,'z', '[0,3]'
94             );
95             #print STDERR "shortcut parsing: $formula\n";
96 19         364 while($formula =~ /^(.*)([^a-zA-Z\$]|^)(\$?([xab]|ord))([^(a-zA-Z]|$)(.*)$/m)
97             {
98             #print STDERR "found $4 (def=$defs{$4})\n";
99 0         0 $formula = $1.$2.$defs{$4}.$5.$6;
100             }
101             #print STDERR "done shortcut parsing: $formula\n";
102             }
103             # Match any relevant [...] and stuff before it; parse and cut from formula.
104             #print STDERR "formula: $formula\n";
105 19         208 while($formula =~ s/\A([^[]*[^[a-zA-Z]|)\[\s*(([^[\],]+)(\s*,\s*([^[\],]+)|)\s*)\s*\]//)
106             {
107             #print STDERR "results: $1 : $2 : $3 : $4 : $5\n";
108             #print STDERR "formula: $formula\n";
109 63         192 $nf .= $1;
110 63         156 my $num1 = $3;
111 63         143 my $num2 = $5;
112 63 100       162 unless(defined $num2)
113             {
114 53         98 $num2 = $num1;
115 53         91 $num1 = 0;
116             }
117 63 50 66     384 if(($num1 =~ /^\d+$/) and ($num1 < 0))
118             {
119 0         0 print STDERR "File index $num1 < 0 !\n";
120 0         0 return undef;
121             }
122 63 50       237 if($num2 =~ /^\d+$/)
123             {
124 63         167 --$num2;
125 63 50       171 if($num2 < 0)
126             {
127 0         0 print STDERR "Dataset index $num2 < 0 !\n";
128 0         0 return undef;
129             }
130             }
131 0         0 else{ $num2 = "($num2)-1"; }
132 63         401 $nf .= '$'.$data."[$num1][$num2]";
133             #print STDERR "nf: $nf\n";
134             }
135              
136 19         55 $nf .= $formula;
137 19         40 for(keys %{$ardef})
  19         87  
138             {
139 40         1137 $nf =~ s/(^|[^\$a-zA-Z])$_(\d+)/$1\$$ardef->{$_}\[$2\]/g;
140             }
141 19 50       107 if($nnf ne ''){ $nnf .= "\n"; }
  0         0  
142 19         76 $nnf .= $nf;
143             }
144 19         80 return $nnf;
145             }
146              
147             #(formula [, config])
148             sub formula_function
149             {
150 15     15 1 61 my ($formula,$cfg) = (shift, shift);
151 15         58 my @ar = qw(A C);
152 15         44 push(@ar, @_); # additional names arrays to insert
153 15         44 my %ardef = map { $_ => $_.'->' } @ar;
  32         425  
154 15 100       65 my $config = defined $cfg
155             ? $cfg
156             : {verbose=>0, plainperl=>0};
157             my $pf = $config->{plainperl}
158 15 50       87 ? $formula
159             : parsed_formula($formula, 'fd->', \%ardef);
160 15 50       60 unless(defined $pf)
161             {
162 0         0 $@ = "Text::NumericData::Calc: Error parsing the formula!";
163 0         0 return undef;
164             }
165 15         45 my $ffc = 'sub { my ($fd, '.join(', ', map {'$'.$_} @ar).') = @_; '.$pf.' ; return 0; }';
  32         147  
166 15 50       67 if(defined $config->{verbose})
167             {
168             print STDERR "Formula code: ".$pf."\n"
169 15 50       51 if $config->{verbose};
170             print STDERR "Formula function code: ".$ffc."\n"
171 15 50       53 if $config->{verbose} > 1;
172             }
173 15         2065 return eval $ffc;
174             }
175              
176             # same as above, code differs in that it returns the expression indicated by formula
177             sub expression_function
178             {
179 4     4 0 12 my $formula = shift;
180 4         12 my $verb = shift;
181 4         16 my @ar = qw(A C);
182 4         15 push(@ar, @_); # additional names arrays to insert
183 4         14 my %ardef = map { $_ => $_.'->' } @ar;
  8         44  
184 4         22 my $pf = parsed_formula($formula, 'fd->', \%ardef);
185 4 50       17 unless(defined $pf)
186             {
187 0         0 $@ = "Text::NumericData::Calc: Error parsing the formula!";
188 0         0 return undef;
189             }
190 4 50       16 print STDERR "Formula code: ",$pf,"\n" if $verb;
191 4         14 return eval 'sub { my ($fd, '.join(', ', map {'$'.$_} @ar).') = @_; return ('.$pf.'); }';
  8         607  
192             }
193              
194             1;
195             __END__