1#!/usr/bin/perl -w
2
3# Tests for Number::WithError
4
5use strict;
6use lib ();
7use File::Spec::Functions ':ALL';
8BEGIN {
9	$| = 1;
10	unless ( $ENV{HARNESS_ACTIVE} ) {
11		require FindBin;
12		$FindBin::Bin = $FindBin::Bin; # Avoid a warning
13		chdir catdir( $FindBin::Bin, updir() );
14		lib->import(
15			catdir('blib', 'lib'),
16			'lib',
17			);
18	}
19}
20
21
22#####################################################################
23
24use Number::WithError ':all';
25use Params::Util qw/_INSTANCE/;
26BEGIN {
27	require Test::LectroTest;
28   	if (defined $ENV{PERL_TEST_ATTEMPTS}) {
29		Test::LectroTest->import(
30			trials => $ENV{PERL_TEST_ATTEMPTS}+0,
31			regressions => catdir('t', 'regression.txt')
32		);
33	}
34	else {
35		Test::LectroTest->import(
36			trials => 100,
37			regressions => catdir('t', 'regression.txt')
38		);
39	}
40}
41
42sub Error () {
43	Frequency(
44		[40, Float],
45		[40, List(Float, 'length' => 2)],
46		[10, List(Float, 'length' => 1)],
47		[10, Unit(undef) ],
48	)
49}
50
51sub WithError () {
52	Concat(
53		Float,
54		List(
55			Error,
56			'length' => [0, 20]
57		)
58	)
59}
60
61sub WithErrorSmall () {
62	Concat(
63		Float(range=>[0..20]),
64		List(
65			Error,
66			'length' => [0, 10]
67		)
68	)
69}
70
71sub max {
72	my $max = $_[0];
73	for (@_) {
74		$max = $_ if $_ > $max;
75	}
76	return $max;
77}
78
79sub min {
80	my $min = $_[0];
81	for (@_) {
82		$min = $_ if $_ < $min;
83	}
84	return $min;
85}
86
87use constant EPS => 1e-8;
88use constant EPS_UNSTABLE => 1e-6;
89my $IsUnstable = 0;
90
91sub numeq ($$) {
92	return undef if not defined $_[0] or not defined $_[1];
93	if ($IsUnstable) {
94		return abs($_[0]-$_[1]) < abs(EPS_UNSTABLE * min($_[0], $_[1])) + EPS;
95	}
96	return abs($_[0]-$_[1]) < EPS;
97}
98
99sub undef_or_eq ($$) {
100	if (not defined $_[0]) {
101		if (not defined $_[1]) {
102			return 1;
103		}
104		else {
105			return undef;
106		}
107	}
108	elsif (not defined $_[1]) {
109		return undef;
110	}
111
112	if ($IsUnstable) {
113		return abs($_[0]-$_[1]) < abs(EPS_UNSTABLE * min($_[0], $_[1])) + EPS;
114	}
115	return abs($_[0]-$_[1]) < EPS;
116}
117
118sub diag {
119	print "# " . join('', @_) . "\n";
120}
121
122sub test_err_calc {
123	my $sub = shift;
124	my $res = shift;
125	my $o1 = shift;
126	my $o2 = shift;
127
128	if (not @{$res->{errors}} == max(scalar(@{$o1->{errors}}), scalar(@{$o2->{errors}}))) {
129		diag(
130			"Number of errors in result is ",
131			scalar(@{$res->{errors}}),
132			" but the expected number of errors is ",
133		   	max( scalar(@{$o1->{errors}}), scalar(@{$o2->{errors}}) )
134		);
135		return undef;
136	}
137
138	foreach my $no (0..$#{$res->{errors}}) {
139		my $e1 = $o1->{errors}[$no];
140		my $e2 = $o2->{errors}[$no];
141		my $eres = $res->{errors}[$no];
142
143		if (ref($e1) eq 'ARRAY') {
144			return undef if not ref($eres) eq 'ARRAY' and @{$e1}!=1;
145			if (ref($e2) eq 'ARRAY') {
146				for (0..1) {
147					my $cmperr = $sub->($e1->[$_]||0, $e2->[$_]||0, $o1->{num}, $o2->{num});
148					if (not numeq( $cmperr||0, $eres->[$_]||0 )) {
149						diag(
150							"Error number $no (both are arys) is in the result: ",
151							$eres->[$_]||0, " The expected result is: ", $cmperr||0
152						);
153						return undef;
154					}
155				}
156			}
157			else {
158				for (0..1) {
159					my $cmperr = $sub->($e1->[$_]||0, $e2||0, $o1->{num}, $o2->{num});
160					if (not numeq( $cmperr||0, $eres->[$_]||0 )) {
161						diag(
162							"Error number $no (err1 is ary) is in the result: ",
163							$eres->[$_]||0, " The expected result is: ", $cmperr||0
164						);
165						return undef;
166					}
167				}
168			}
169		}
170		elsif (ref($e2) eq 'ARRAY') {
171			return undef if not ref($eres) eq 'ARRAY' and @{$e2} != 1;
172			for (0..1) {
173				my $cmperr = $sub->($e1||0, $e2->[$_]||0, $o1->{num}, $o2->{num});
174				if (not numeq( $cmperr||0, $eres->[$_]||0 )) {
175					diag(
176						"Error number $no (err2 is ary) is in the result: ",
177						$eres->[$_]||0, " The expected result is: ", $cmperr||0
178					);
179					return undef;
180				}
181			}
182		}
183		else {
184			my $cmperr =  $sub->($e1||0, $e2||0, $o1->{num}, $o2->{num});
185			if ( not numeq( $cmperr||0, $eres||0 ) ) {
186				diag("Error number $no is in the result: ", $eres||0, " The expected result is: ", $cmperr||0);
187				return undef;
188			}
189		}
190	}
191	return 1;
192}
193
194my $Operator;
195
196# add
197$Operator = 'addition';
198Property {
199	##[ x <- WithError, y <- WithError ]##
200	$IsUnstable = 0;
201	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
202	return undef if grep {not defined} ($o1, $o2);
203
204	my $res = $o1->add($o2);
205	my $num = $o1->{num} + $o2->{num};
206	# parms: err1||0, err2||0, n1, n2
207	my $err_calc = sub { sqrt($_[0]**2 + $_[1]**2) };
208
209	return undef if not defined $res;
210	return undef if not _INSTANCE($res, 'Number::WithError');
211
212	if ( not numeq($res->{num}, $num) ) {
213		diag("Result of $Operator is $res->{num}. Should be $num.");
214	   	return undef;
215	}
216
217	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
218	1
219}, name => "add() method" ;
220
221Property {
222	##[ x <- WithError, y <- WithError ]##
223	$IsUnstable = 0;
224	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
225	return undef if grep {not defined} ($o1, $o2);
226
227	my $res = $o1 + $o2;
228	my $num = $o1->{num} + $o2->{num};
229	# parms: err1||0, err2||0, n1, n2
230	my $err_calc = sub { sqrt($_[0]**2 + $_[1]**2) };
231
232	return undef if not defined $res;
233	return undef if not _INSTANCE($res, 'Number::WithError');
234
235	if ( not numeq($res->{num}, $num) ) {
236		diag("Result of $Operator is $res->{num}. Should be $num.");
237	   	return undef;
238	}
239
240	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
241	1
242}, name => "overload: +" ;
243
244Property {
245	##[ x <- WithError, y <- Float ]##
246	$IsUnstable = 0;
247	my ($o1, $o2) = map {witherror(ref($_)eq'ARRAY' ? @$_ : $_)} ($x, $y);
248	return undef if grep {not defined} ($o1, $o2);
249
250	my $res = $y + $o1;
251	my $num = $y + $o1->{num};
252	# parms: err1||0, err2||0, n1, n2
253	my $err_calc = sub { sqrt($_[0]**2 + $_[1]**2) };
254
255	return undef if not defined $res;
256	return undef if not _INSTANCE($res, 'Number::WithError');
257
258	if ( not numeq($res->{num}, $num) ) {
259		diag("Result of $Operator is $res->{num}. Should be $num.");
260	   	return undef;
261	}
262
263	test_err_calc($err_calc, $res, $o2, $o1) or return undef;
264	1
265}, name => "overload: +, number" ;
266
267
268
269# subtract
270$Operator = 'subtraction';
271Property {
272	##[ x <- WithError, y <- WithError ]##
273	$IsUnstable = 0;
274	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
275	return undef if grep {not defined} ($o1, $o2);
276
277	my $res = $o1->subtract($o2);
278	my $num = $o1->{num} - $o2->{num};
279	# parms: err1||0, err2||0, n1, n2
280	my $err_calc = sub { sqrt($_[0]**2 + $_[1]**2) };
281
282	return undef if not defined $res;
283	return undef if not _INSTANCE($res, 'Number::WithError');
284
285	if ( not numeq($res->{num}, $num) ) {
286		diag("Result of $Operator is $res->{num}. Should be $num.");
287	   	return undef;
288	}
289
290	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
291	1
292}, name => "subtract() method" ;
293
294Property {
295	##[ x <- WithError, y <- WithError ]##
296	$IsUnstable = 0;
297	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
298	return undef if grep {not defined} ($o1, $o2);
299
300	my $res = $o1 - $o2;
301	my $num = $o1->{num} - $o2->{num};
302	# parms: err1||0, err2||0, n1, n2
303	my $err_calc = sub { sqrt($_[0]**2 + $_[1]**2) };
304
305	return undef if not defined $res;
306	return undef if not _INSTANCE($res, 'Number::WithError');
307
308	if ( not numeq($res->{num}, $num) ) {
309		diag("Result of $Operator is $res->{num}. Should be $num.");
310	   	return undef;
311	}
312
313	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
314	1
315}, name => "overload: -" ;
316
317Property {
318	##[ x <- WithError, y <- Float ]##
319	$IsUnstable = 0;
320	my ($o1, $o2) = map {witherror(ref($_)eq'ARRAY' ? @$_ : $_)} ($x, $y);
321	return undef if grep {not defined} ($o1, $o2);
322
323	my $res = $y - $o1;
324	my $num = $y - $o1->{num};
325	# parms: err1||0, err2||0, n1, n2
326	my $err_calc = sub { sqrt($_[0]**2 + $_[1]**2) };
327
328	return undef if not defined $res;
329	return undef if not _INSTANCE($res, 'Number::WithError');
330
331	if ( not numeq($res->{num}, $num) ) {
332		diag("Result of $Operator is $res->{num}. Should be $num.");
333	   	return undef;
334	}
335
336	test_err_calc($err_calc, $res, $o2, $o1) or return undef;
337	1
338}, name => "overload: -, number" ;
339
340
341
342
343# multiply
344$Operator = 'multiplication';
345Property {
346	##[ x <- WithError, y <- WithError ]##
347	$IsUnstable = 0;
348	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
349	return undef if grep {not defined} ($o1, $o2);
350
351	my $res = $o1->multiply($o2);
352	my $num = $o1->{num} * $o2->{num};
353	# parms: err1||0, err2||0, n1, n2
354	my $err_calc = sub { sqrt(($_[0]*$_[3])**2 + ($_[2]*$_[1])**2) };
355
356	return undef if not defined $res;
357	return undef if not _INSTANCE($res, 'Number::WithError');
358
359	if ( not numeq($res->{num}, $num) ) {
360		diag("Result of $Operator is $res->{num}. Should be $num.");
361	   	return undef;
362	}
363
364	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
365	1
366}, name => "multiply() method" ;
367
368Property {
369	##[ x <- WithError, y <- WithError ]##
370	$IsUnstable = 0;
371	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
372	return undef if grep {not defined} ($o1, $o2);
373
374	my $res = $o1 * $o2;
375	my $num = $o1->{num} * $o2->{num};
376	# parms: err1||0, err2||0, n1, n2
377	my $err_calc = sub { sqrt(($_[0]*$_[3])**2 + ($_[2]*$_[1])**2) };
378
379	return undef if not defined $res;
380	return undef if not _INSTANCE($res, 'Number::WithError');
381
382	if ( not numeq($res->{num}, $num) ) {
383		diag("Result of $Operator is $res->{num}. Should be $num.");
384	   	return undef;
385	}
386
387	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
388	1
389}, name => "overload: *" ;
390
391Property {
392	##[ x <- WithError, y <- Float ]##
393	$IsUnstable = 0;
394	my ($o1, $o2) = map {witherror(ref($_)eq'ARRAY' ? @$_ : $_)} ($x, $y);
395	return undef if grep {not defined} ($o1, $o2);
396
397	my $res = $y * $o1;
398	my $num = $y * $o1->{num};
399	# parms: err1||0, err2||0, n1, n2
400	my $err_calc = sub { sqrt(($_[0]*$_[3])**2 + ($_[2]*$_[1])**2) };
401
402	return undef if not defined $res;
403	return undef if not _INSTANCE($res, 'Number::WithError');
404
405	if ( not numeq($res->{num}, $num) ) {
406		diag("Result of $Operator is $res->{num}. Should be $num.");
407	   	return undef;
408	}
409
410	test_err_calc($err_calc, $res, $o2, $o1) or return undef;
411	1
412}, name => "overload: *, number" ;
413
414
415
416
417# divide
418$Operator = 'division';
419Property {
420	##[ x <- WithError, y <- WithError ]##
421	$IsUnstable = 0;
422	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
423	return undef if grep {not defined} ($o1, $o2);
424
425	my $res = $o1->divide($o2);
426	my $num = $o1->{num} / $o2->{num};
427	# parms: err1||0, err2||0, n1, n2
428	my $err_calc = sub { sqrt(($_[0]/$_[3])**2 + ($_[2]*$_[1]/$_[3]**2)**2) };
429
430	return undef if not defined $res;
431	return undef if not _INSTANCE($res, 'Number::WithError');
432
433	if ( not numeq($res->{num}, $num) ) {
434		diag("Result of $Operator is $res->{num}. Should be $num.");
435	   	return undef;
436	}
437
438	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
439	1
440}, name => "divide() method" ;
441
442Property {
443	##[ x <- WithError, y <- WithError ]##
444	$IsUnstable = 0;
445	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
446	return undef if grep {not defined} ($o1, $o2);
447
448	my $res = $o1 / $o2;
449	my $num = $o1->{num} / $o2->{num};
450	# parms: err1||0, err2||0, n1, n2
451	my $err_calc = sub { sqrt(($_[0]/$_[3])**2 + ($_[2]*$_[1]/$_[3]**2)**2) };
452
453	return undef if not defined $res;
454	return undef if not _INSTANCE($res, 'Number::WithError');
455
456	if ( not numeq($res->{num}, $num) ) {
457		diag("Result of $Operator is $res->{num}. Should be $num.");
458	   	return undef;
459	}
460
461	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
462	1
463}, name => "overload: /" ;
464
465Property {
466	##[ x <- WithError, y <- Float ]##
467	$IsUnstable = 0;
468	my ($o1, $o2) = map {witherror(ref($_)eq'ARRAY' ? @$_ : $_)} ($x, $y);
469	return undef if grep {not defined} ($o1, $o2);
470
471	my $res = $y / $o1;
472	my $num = $y / $o1->{num};
473	# parms: err1||0, err2||0, n1, n2
474	my $err_calc = sub { sqrt( $_[0]**2/$_[3]**2 + $_[2]**2*$_[1]**2/$_[3]**4 ) };
475
476	return undef if not defined $res;
477	return undef if not _INSTANCE($res, 'Number::WithError');
478
479	if ( not numeq($res->{num}, $num) ) {
480		diag("Result of $Operator is $res->{num}. Should be $num.");
481	   	return undef;
482	}
483
484	test_err_calc($err_calc, $res, $o2, $o1) or return undef;
485	1
486}, name => "overload: /, number" ;
487
488
489
490
491# exponentiate
492$Operator = 'exponentiation';
493Property {
494	##[ x <- WithErrorSmall, y <- WithErrorSmall ]##
495	$IsUnstable = 1;
496	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
497	return undef if grep {not defined} ($o1, $o2);
498
499	$tcon->retry if $y->[0] > 10 or $x->[0] > 50 or $y->[0] < 0;
500
501	my $res = $o1->exponentiate($o2);
502	my $num = $o1->{num} ** $o2->{num};
503	# parms: err1||0, err2||0, n1, n2
504	my $err_calc = sub { sqrt( ($_[3]*$_[2]**($_[3]-1)*$_[0])**2 + (log($_[2])*$_[2]**$_[3]*$_[1])**2 ) };
505
506	if ($o1->{num} < 0) {
507		return 1 if not defined $res;
508		return undef;
509	}
510	return undef if not defined $res;
511	return undef if not _INSTANCE($res, 'Number::WithError');
512
513	if ( not numeq($res->{num}, $num) ) {
514		diag("Result of $Operator is $res->{num}. Should be $num.");
515	   	return undef;
516	}
517
518	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
519	1
520}, name => "exponentiate() method" ;
521
522Property {
523	##[ x <- WithErrorSmall, y <- WithErrorSmall ]##
524	$IsUnstable = 1;
525	my ($o1, $o2) = map {witherror(@$_)} ($x, $y);
526	return undef if grep {not defined} ($o1, $o2);
527
528	$tcon->retry if $y->[0] > 10 or $x->[0] > 50 or $y->[0] < 0;
529
530	my $res = $o1 ** $o2;
531	my $num = $o1->{num} ** $o2->{num};
532	# parms: err1||0, err2||0, n1, n2
533	my $err_calc = sub { sqrt( ($_[3]*$_[2]**($_[3]-1)*$_[0])**2 + (log($_[2])*$_[2]**$_[3]*$_[1])**2 ) };
534
535	if ($o1->{num} < 0) {
536		return 1 if not defined $res;
537		return undef;
538	}
539	return undef if not defined $res;
540	return undef if not _INSTANCE($res, 'Number::WithError');
541
542	if ( not numeq($res->{num}, $num) ) {
543		diag("Result of $Operator is $res->{num}. Should be $num.");
544	   	return undef;
545	}
546
547	test_err_calc($err_calc, $res, $o1, $o2) or return undef;
548	1
549}, name => "overload: **" ;
550
551Property {
552	##[ x <- WithErrorSmall, y <- Float(range => [0,10]) ]##
553	$IsUnstable = 1;
554	my ($o1, $o2) = map {witherror(ref($_)eq'ARRAY' ? @$_ : $_)} ($x, $y);
555	return undef if grep {not defined} ($o1, $o2);
556
557	$tcon->retry if $y > 10 or $x->[0] > 50 or $y < 0;
558
559	my $res = $y ** $o1;
560	my $num = $y ** $o1->{num};
561	# parms: err1||0, err2||0, n1, n2
562	my $err_calc = sub { sqrt( ($_[3]*$_[2]**($_[3]-1)*$_[0])**2 + (log($_[2])*$_[2]**$_[3]*$_[1])**2 ) };
563
564	if ($y < 0) {
565		return 1 if not defined $res;
566		return undef;
567	}
568	return undef if not defined $res;
569	return undef if not _INSTANCE($res, 'Number::WithError');
570
571	if ( not numeq($res->{num}, $num) ) {
572		diag("Result of $Operator is $res->{num}. Should be $num.");
573	   	return undef;
574	}
575
576	test_err_calc($err_calc, $res, $o2, $o1) or return undef;
577	1
578}, name => "overload: **, number" ;
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
5971;
598
599