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