lib/Math/BigInt/t/mbimbf.inc

   1 # test rounding, accuracy, precicion and fallback, round_mode and mixing
   2 # of classes
   3
   4 # Make sure you always quote any bare floating-point values, lest 123.46 will
   5 # be stringified to 123.4599999999 due to limited float prevision.
   6
   7 my ($x,$y,$z,$u,$rc);
   8
   9 ###############################################################################
  10 # test defaults and set/get
  11
  12 ok_undef (${"$mbi\::accuracy"});
  13 ok_undef (${"$mbi\::precision"});
  14 ok_undef ($mbi->accuracy());
  15 ok_undef ($mbi->precision());
  16 ok (${"$mbi\::div_scale"},40);
  17 ok (${"$mbi\::round_mode"},'even');
  18 ok ($mbi->round_mode(),'even');
  19
  20 ok_undef (${"$mbf\::accuracy"});
  21 ok_undef (${"$mbf\::precision"});
  22 ok_undef ($mbf->precision());
  23 ok_undef ($mbf->precision());
  24 ok (${"$mbf\::div_scale"},40);
  25 ok (${"$mbf\::round_mode"},'even');
  26 ok ($mbf->round_mode(),'even');
  27
  28 # accessors
  29 foreach my $class ($mbi,$mbf)
  30   {
  31   ok_undef ($class->accuracy());
  32   ok_undef ($class->precision());
  33   ok ($class->round_mode(),'even');
  34   ok ($class->div_scale(),40);
  35
  36   ok ($class->div_scale(20),20);
  37   $class->div_scale(40); ok ($class->div_scale(),40);
  38
  39   ok ($class->round_mode('odd'),'odd');
  40   $class->round_mode('even'); ok ($class->round_mode(),'even');
  41
  42   ok ($class->accuracy(2),2);
  43   $class->accuracy(3); ok ($class->accuracy(),3);
  44   ok_undef ($class->accuracy(undef));
  45
  46   ok ($class->precision(2),2);
  47   ok ($class->precision(-2),-2);
  48   $class->precision(3); ok ($class->precision(),3);
  49   ok_undef ($class->precision(undef));
  50   }
  51
  52 # accuracy
  53 foreach (qw/5 42 -1 0/)
  54   {
  55   ok (${"$mbf\::accuracy"} = $_,$_);
  56   ok (${"$mbi\::accuracy"} = $_,$_);
  57   }
  58 ok_undef (${"$mbf\::accuracy"} = undef);
  59 ok_undef (${"$mbi\::accuracy"} = undef);
  60
  61 # precision
  62 foreach (qw/5 42 -1 0/)
  63   {
  64   ok (${"$mbf\::precision"} = $_,$_);
  65   ok (${"$mbi\::precision"} = $_,$_);
  66   }
  67 ok_undef (${"$mbf\::precision"} = undef);
  68 ok_undef (${"$mbi\::precision"} = undef);
  69
  70 # fallback
  71 foreach (qw/5 42 1/)
  72   {
  73   ok (${"$mbf\::div_scale"} = $_,$_);
  74   ok (${"$mbi\::div_scale"} = $_,$_);
  75   }
  76 # illegal values are possible for fallback due to no accessor
  77
  78 # round_mode
  79 foreach (qw/odd even zero trunc +inf -inf/)
  80   {
  81   ok (${"$mbf\::round_mode"} = $_,$_);
  82   ok (${"$mbi\::round_mode"} = $_,$_);
  83   }
  84 ${"$mbf\::round_mode"} = 'zero';
  85 ok (${"$mbf\::round_mode"},'zero');
  86 ok (${"$mbi\::round_mode"},'-inf');     # from above
  87
  88 ${"$mbi\::accuracy"} = undef;
  89 ${"$mbi\::precision"} = undef;
  90 # local copies
  91 $x = $mbf->new('123.456');
  92 ok_undef ($x->accuracy());
  93 ok ($x->accuracy(5),5);
  94 ok_undef ($x->accuracy(undef),undef);
  95 ok_undef ($x->precision());
  96 ok ($x->precision(5),5);
  97 ok_undef ($x->precision(undef),undef);
  98
  99 # see if MBF changes MBIs values
 100 ok (${"$mbi\::accuracy"} = 42,42);
 101 ok (${"$mbf\::accuracy"} = 64,64);
 102 ok (${"$mbi\::accuracy"},42);           # should be still 42
 103 ok (${"$mbf\::accuracy"},64);           # should be now 64
 104
 105 ###############################################################################
 106 # see if creating a number under set A or P will round it
 107
 108 ${"$mbi\::accuracy"} = 4;
 109 ${"$mbi\::precision"} = undef;
 110
 111 ok ($mbi->new(123456),123500);          # with A
 112 ${"$mbi\::accuracy"} = undef;
 113 ${"$mbi\::precision"} = 3;
 114 ok ($mbi->new(123456),123000);          # with P
 115
 116 ${"$mbf\::accuracy"} = 4;
 117 ${"$mbf\::precision"} = undef;
 118 ${"$mbi\::precision"} = undef;
 119
 120 ok ($mbf->new('123.456'),'123.5');      # with A
 121 ${"$mbf\::accuracy"} = undef;
 122 ${"$mbf\::precision"} = -1;
 123 ok ($mbf->new('123.456'),'123.5');      # with P from MBF, not MBI!
 124
 125 ${"$mbf\::precision"} = undef;          # reset
 126
 127 ###############################################################################
 128 # see if MBI leaves MBF's private parts alone
 129
 130 ${"$mbi\::precision"} = undef; ${"$mbf\::precision"} = undef;
 131 ${"$mbi\::accuracy"} = 4; ${"$mbf\::accuracy"} = undef;
 132 ok ($mbf->new('123.456'),'123.456');
 133 ${"$mbi\::accuracy"} = undef;           # reset
 134
 135 ###############################################################################
 136 # see if setting accuracy/precision actually rounds the number
 137
 138 $x = $mbf->new('123.456'); $x->accuracy(4);   ok ($x,'123.5');
 139 $x = $mbf->new('123.456'); $x->precision(-2); ok ($x,'123.46');
 140
 141 $x = $mbi->new(123456);    $x->accuracy(4);   ok ($x,123500);
 142 $x = $mbi->new(123456);    $x->precision(2);  ok ($x,123500);
 143
 144 ###############################################################################
 145 # test actual rounding via round()
 146
 147 $x = $mbf->new('123.456');
 148 ok ($x->copy()->round(5),'123.46');
 149 ok ($x->copy()->round(4),'123.5');
 150 ok ($x->copy()->round(5,2),'NaN');
 151 ok ($x->copy()->round(undef,-2),'123.46');
 152 ok ($x->copy()->round(undef,2),120);
 153
 154 $x = $mbi->new('123');
 155 ok ($x->round(5,2),'NaN');
 156
 157 $x = $mbf->new('123.45000');
 158 ok ($x->copy()->round(undef,-1,'odd'),'123.5');
 159
 160 # see if rounding is 'sticky'
 161 $x = $mbf->new('123.4567');
 162 $y = $x->copy()->bround();              # no-op since nowhere A or P defined
 163
 164 ok ($y,123.4567);
 165 $y = $x->copy()->round(5);
 166 ok ($y->accuracy(),5);
 167 ok_undef ($y->precision());             # A has precedence, so P still unset
 168 $y = $x->copy()->round(undef,2);
 169 ok ($y->precision(),2);
 170 ok_undef ($y->accuracy());              # P has precedence, so A still unset
 171
 172 # see if setting A clears P and vice versa
 173 $x = $mbf->new('123.4567');
 174 ok ($x,'123.4567');
 175 ok ($x->accuracy(4),4);
 176 ok ($x->precision(-2),-2);              # clear A
 177 ok_undef ($x->accuracy());
 178
 179 $x = $mbf->new('123.4567');
 180 ok ($x,'123.4567');
 181 ok ($x->precision(-2),-2);
 182 ok ($x->accuracy(4),4);                 # clear P
 183 ok_undef ($x->precision());
 184
 185 # does copy work?
 186 $x = $mbf->new(123.456); $x->accuracy(4); $x->precision(2);
 187 $z = $x->copy(); ok_undef ($z->accuracy(),undef); ok ($z->precision(),2);
 188
 189 # does accuracy()/precision work on zeros?
 190 foreach my $class ($mbi,$mbf)
 191   {
 192   $x = $class->bzero(); $x->accuracy(5); ok ($x->{_a},5);
 193   $x = $class->bzero(); $x->precision(5); ok ($x->{_p},5);
 194   $x = $class->new(0); $x->accuracy(5); ok ($x->{_a},5);
 195   $x = $class->new(0); $x->precision(5); ok ($x->{_p},5);
 196
 197   $x = $class->bzero(); $x->round(5); ok ($x->{_a},5);
 198   $x = $class->bzero(); $x->round(undef,5); ok ($x->{_p},5);
 199   $x = $class->new(0); $x->round(5); ok ($x->{_a},5);
 200   $x = $class->new(0); $x->round(undef,5); ok ($x->{_p},5);
 201
 202   # see if trying to increasing A in bzero() doesn't do something
 203   $x = $class->bzero(); $x->{_a} = 3; $x->round(5); ok ($x->{_a},3);
 204   }
 205
 206 ###############################################################################
 207 # test wether operations round properly afterwards
 208 # These tests are not complete, since they do not excercise every "return"
 209 # statement in the op's. But heh, it's better than nothing...
 210
 211 $x = $mbf->new('123.456');
 212 $y = $mbf->new('654.321');
 213 $x->{_a} = 5;           # $x->accuracy(5) would round $x straightaway
 214 $y->{_a} = 4;           # $y->accuracy(4) would round $x straightaway
 215
 216 $z = $x + $y;           ok ($z,'777.8');
 217 $z = $y - $x;           ok ($z,'530.9');
 218 $z = $y * $x;           ok ($z,'80780');
 219 $z = $x ** 2;           ok ($z,'15241');
 220 $z = $x * $x;           ok ($z,'15241');
 221
 222 # not: $z = -$x;                ok ($z,'-123.46'); ok ($x,'123.456');
 223 $z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62);
 224 $x = $mbf->new(123456); $x->{_a} = 4;
 225 $z = $x->copy; $z++;    ok ($z,123500);
 226
 227 $x = $mbi->new(123456);
 228 $y = $mbi->new(654321);
 229 $x->{_a} = 5;           # $x->accuracy(5) would round $x straightaway
 230 $y->{_a} = 4;           # $y->accuracy(4) would round $x straightaway
 231
 232 $z = $x + $y;           ok ($z,777800);
 233 $z = $y - $x;           ok ($z,530900);
 234 $z = $y * $x;           ok ($z,80780000000);
 235 $z = $x ** 2;           ok ($z,15241000000);
 236 # not yet: $z = -$x;            ok ($z,-123460); ok ($x,123456);
 237 $z = $x->copy; $z++;    ok ($z,123460);
 238 $z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000);
 239
 240 $x = $mbi->new(123400); $x->{_a} = 4;
 241 ok ($x->bnot(),-123400);                        # not -1234001
 242
 243 # both babs() and bneg() don't need to round, since the input will already
 244 # be rounded (either as $x or via new($string)), and they don't change the
 245 # value. The two tests below peek at this by using _a (illegally) directly
 246 $x = $mbi->new(-123401); $x->{_a} = 4; ok ($x->babs(),123401);
 247 $x = $mbi->new(-123401); $x->{_a} = 4; ok ($x->bneg(),123401);
 248
 249 # test fdiv rounding to A and R (bug in v1.48 and maybe earlier versions)
 250 $mbf->round_mode('even');
 251 $x = $mbf->new('740.7')->fdiv('6',4,undef,'zero'); ok ($x,'123.4');
 252
 253 ###############################################################################
 254 # test (also under Bare) that bfac() rounds at last step
 255
 256 ok ($mbi->new(12)->bfac(),'479001600');
 257 ok ($mbi->new(12)->bfac(2),'480000000');
 258 $x = $mbi->new(12); $x->accuracy(2); ok ($x->bfac(),'480000000');
 259 $x = $mbi->new(13); $x->accuracy(2); ok ($x->bfac(),'6200000000');
 260 $x = $mbi->new(13); $x->accuracy(3); ok ($x->bfac(),'6230000000');
 261 $x = $mbi->new(13); $x->accuracy(4); ok ($x->bfac(),'6227000000');
 262 # this does 1,2,3...9,10,11,12...20
 263 $x = $mbi->new(20); $x->accuracy(1); ok ($x->bfac(),'2000000000000000000');
 264
 265 ###############################################################################
 266 # test bsqrt) rounding to given A/P/R (bug prior to v1.60)
 267 $x = $mbi->new('123456')->bsqrt(2,undef); ok ($x,'350');        # not 351
 268 $x = $mbi->new('3')->bsqrt(2,undef); ok ($x->accuracy(),2);
 269
 270 $mbi->round_mode('even'); $x = $mbi->new('126025')->bsqrt(2,undef,'+inf');
 271 ok ($x,'360');  # not 355 nor 350
 272
 273 $x = $mbi->new('126025')->bsqrt(undef,2); ok ($x,'400');         # not 355
 274
 275
 276 ###############################################################################
 277 # test mixed arguments
 278
 279 $x = $mbf->new(10);
 280 $u = $mbf->new(2.5);
 281 $y = $mbi->new(2);
 282
 283 $z = $x + $y; ok ($z,12); ok (ref($z),$mbf);
 284 $z = $x / $y; ok ($z,5); ok (ref($z),$mbf);
 285 $z = $u * $y; ok ($z,5); ok (ref($z),$mbf);
 286
 287 $y = $mbi->new(12345);
 288 $z = $u->copy()->bmul($y,2,undef,'odd'); ok ($z,31000);
 289 $z = $u->copy()->bmul($y,3,undef,'odd'); ok ($z,30900);
 290 $z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863);
 291 $z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30863);
 292 $z = $u->copy()->bmul($y,undef,2,'odd'); ok ($z,30860);
 293 $z = $u->copy()->bmul($y,undef,3,'odd'); ok ($z,30900);
 294 $z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5);
 295
 296 # breakage:
 297 # $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000);
 298 # $z = $y * $u; ok ($z,5); ok (ref($z),$mbi);
 299 # $z = $y + $x; ok ($z,12); ok (ref($z),$mbi);
 300 # $z = $y / $x; ok ($z,0); ok (ref($z),$mbi);
 301
 302 ###############################################################################
 303 # rounding in bdiv with fallback and already set A or P
 304
 305 ${"$mbf\::accuracy"} = undef;
 306 ${"$mbf\::precision"} = undef;
 307 ${"$mbf\::div_scale"} = 40;
 308
 309 $x = $mbf->new(10); $x->{_a} = 4;
 310 ok ($x->bdiv(3),'3.333');
 311 ok ($x->{_a},4);                        # set's it since no fallback
 312
 313 $x = $mbf->new(10); $x->{_a} = 4; $y = $mbf->new(3);
 314 ok ($x->bdiv($y),'3.333');
 315 ok ($x->{_a},4);                        # set's it since no fallback
 316
 317 # rounding to P of x
 318 $x = $mbf->new(10); $x->{_p} = -2;
 319 ok ($x->bdiv(3),'3.33');
 320
 321 # round in div with requested P
 322 $x = $mbf->new(10);
 323 ok ($x->bdiv(3,undef,-2),'3.33');
 324
 325 # round in div with requested P greater than fallback
 326 ${"$mbf\::div_scale"} = 5;
 327 $x = $mbf->new(10);
 328 ok ($x->bdiv(3,undef,-8),'3.33333333');
 329 ${"$mbf\::div_scale"} = 40;
 330
 331 $x = $mbf->new(10); $y = $mbf->new(3); $y->{_a} = 4;
 332 ok ($x->bdiv($y),'3.333');
 333 ok ($x->{_a},4); ok ($y->{_a},4);       # set's it since no fallback
 334 ok_undef ($x->{_p}); ok_undef ($y->{_p});
 335
 336 # rounding to P of y
 337 $x = $mbf->new(10); $y = $mbf->new(3); $y->{_p} = -2;
 338 ok ($x->bdiv($y),'3.33');
 339 ok ($x->{_p},-2);
 340  ok ($y->{_p},-2);
 341 ok_undef ($x->{_a}); ok_undef ($y->{_a});
 342
 343 ###############################################################################
 344 # test whether bround(-n) fails in MBF (undocumented in MBI)
 345 eval { $x = $mbf->new(1); $x->bround(-2); };
 346 ok ($@ =~ /^bround\(\) needs positive accuracy/,1);
 347
 348 # test whether rounding to higher accuracy is no-op
 349 $x = $mbf->new(1); $x->{_a} = 4;
 350 ok ($x,'1.000');
 351 $x->bround(6);                  # must be no-op
 352 ok ($x->{_a},4);
 353 ok ($x,'1.000');
 354
 355 $x = $mbi->new(1230); $x->{_a} = 3;
 356 ok ($x,'1230');
 357 $x->bround(6);                  # must be no-op
 358 ok ($x->{_a},3);
 359 ok ($x,'1230');
 360
 361 # bround(n) should set _a
 362 $x->bround(2);                  # smaller works
 363 ok ($x,'1200');
 364 ok ($x->{_a},2);
 365
 366 # bround(-n) is undocumented and only used by MBF
 367 # bround(-n) should set _a
 368 $x = $mbi->new(12345);
 369 $x->bround(-1);
 370 ok ($x,'12300');
 371 ok ($x->{_a},4);
 372
 373 # bround(-n) should set _a
 374 $x = $mbi->new(12345);
 375 $x->bround(-2);
 376 ok ($x,'12000');
 377 ok ($x->{_a},3);
 378
 379 # bround(-n) should set _a
 380 $x = $mbi->new(12345); $x->{_a} = 5;
 381 $x->bround(-3);
 382 ok ($x,'10000');
 383 ok ($x->{_a},2);
 384
 385 # bround(-n) should set _a
 386 $x = $mbi->new(12345); $x->{_a} = 5;
 387 $x->bround(-4);
 388 ok ($x,'0');
 389 ok ($x->{_a},1);
 390
 391 # bround(-n) should be noop if n too big
 392 $x = $mbi->new(12345);
 393 $x->bround(-5);
 394 ok ($x,'0');                    # scale to "big" => 0
 395 ok ($x->{_a},0);
 396
 397 # bround(-n) should be noop if n too big
 398 $x = $mbi->new(54321);
 399 $x->bround(-5);
 400 ok ($x,'100000');               # used by MBF to round 0.0054321 at 0.0_6_00000
 401 ok ($x->{_a},0);
 402
 403 # bround(-n) should be noop if n too big
 404 $x = $mbi->new(54321); $x->{_a} = 5;
 405 $x->bround(-6);
 406 ok ($x,'100000');               # no-op
 407 ok ($x->{_a},0);
 408
 409 # bround(n) should set _a
 410 $x = $mbi->new(12345); $x->{_a} = 5;
 411 $x->bround(5);                  # must be no-op
 412 ok ($x,'12345');
 413 ok ($x->{_a},5);
 414
 415 # bround(n) should set _a
 416 $x = $mbi->new(12345); $x->{_a} = 5;
 417 $x->bround(6);                  # must be no-op
 418 ok ($x,'12345');
 419
 420 $x = $mbf->new('0.0061'); $x->bfround(-2); ok ($x,'0.01');
 421 $x = $mbf->new('0.004'); $x->bfround(-2);  ok ($x,'0.00');
 422 $x = $mbf->new('0.005'); $x->bfround(-2);  ok ($x,'0.00');
 423
 424 $x = $mbf->new('12345'); $x->bfround(2); ok ($x,'12340');
 425 $x = $mbf->new('12340'); $x->bfround(2); ok ($x,'12340');
 426
 427 # MBI::bfround should clear A for negative P
 428 $x = $mbi->new('1234'); $x->accuracy(3); $x->bfround(-2);
 429 ok_undef ($x->{_a});
 430
 431 ###############################################################################
 432 # rounding with already set precision/accuracy
 433
 434 $x = $mbf->new(1); $x->{_p} = -5;
 435 ok ($x,'1.00000');
 436
 437 # further rounding donw
 438 ok ($x->bfround(-2),'1.00');
 439 ok ($x->{_p},-2);
 440
 441 $x = $mbf->new(12345); $x->{_a} = 5;
 442 ok ($x->bround(2),'12000');
 443 ok ($x->{_a},2);
 444
 445 $x = $mbf->new('1.2345'); $x->{_a} = 5;
 446 ok ($x->bround(2),'1.2');
 447 ok ($x->{_a},2);
 448
 449 # mantissa/exponent format and A/P
 450 $x = $mbf->new('12345.678'); $x->accuracy(4);
 451 ok ($x,'12350'); ok ($x->{_a},4); ok_undef ($x->{_p});
 452 ok_undef ($x->{_m}->{_a}); ok_undef ($x->{_e}->{_a});
 453 ok_undef ($x->{_m}->{_p}); ok_undef ($x->{_e}->{_p});
 454
 455 # check for no A/P in case of fallback
 456 # result
 457 $x = $mbf->new(100) / 3;
 458 ok_undef ($x->{_a}); ok_undef ($x->{_p});
 459
 460 # result & reminder
 461 $x = $mbf->new(100) / 3; ($x,$y) = $x->bdiv(3);
 462 ok_undef ($x->{_a}); ok_undef ($x->{_p});
 463 ok_undef ($y->{_a}); ok_undef ($y->{_p});
 464
 465 ###############################################################################
 466 # math with two numbers with differen A and P
 467
 468 $x = $mbf->new(12345); $x->accuracy(4);         # '12340'
 469 $y = $mbf->new(12345); $y->accuracy(2);         # '12000'
 470 ok ($x+$y,24000);                               # 12340+12000=> 24340 => 24000
 471
 472 $x = $mbf->new(54321); $x->accuracy(4);         # '12340'
 473 $y = $mbf->new(12345); $y->accuracy(3);         # '12000'
 474 ok ($x-$y,42000);                               # 54320+12300=> 42020 => 42000
 475
 476 $x = $mbf->new('1.2345'); $x->precision(-2);    # '1.23'
 477 $y = $mbf->new('1.2345'); $y->precision(-4);    # '1.2345'
 478 ok ($x+$y,'2.46');                              # 1.2345+1.2300=> 2.4645 => 2.46
 479
 480 ###############################################################################
 481 # round should find and use proper class
 482
 483 #$x = Foo->new();
 484 #ok ($x->round($Foo::accuracy),'a' x $Foo::accuracy);
 485 #ok ($x->round(undef,$Foo::precision),'p' x $Foo::precision);
 486 #ok ($x->bfround($Foo::precision),'p' x $Foo::precision);
 487 #ok ($x->bround($Foo::accuracy),'a' x $Foo::accuracy);
 488
 489 ###############################################################################
 490 # find out whether _find_round_parameters is doing what's it's supposed to do
 491
 492 ${"$mbi\::accuracy"} = undef;
 493 ${"$mbi\::precision"} = undef;
 494 ${"$mbi\::div_scale"} = 40;
 495 ${"$mbi\::round_mode"} = 'odd';
 496
 497 $x = $mbi->new(123);
 498 my @params = $x->_find_round_parameters();
 499 ok (scalar @params,1);                          # nothing to round
 500
 501 @params = $x->_find_round_parameters(1);
 502 ok (scalar @params,4);                          # a=1
 503 ok ($params[0],$x);                             # self
 504 ok ($params[1],1);                              # a
 505 ok_undef ($params[2]);                          # p
 506 ok ($params[3],'odd');                          # round_mode
 507
 508 @params = $x->_find_round_parameters(undef,2);
 509 ok (scalar @params,4);                          # p=2
 510 ok ($params[0],$x);                             # self
 511 ok_undef ($params[1]);                          # a
 512 ok ($params[2],2);                              # p
 513 ok ($params[3],'odd');                          # round_mode
 514
 515 eval { @params = $x->_find_round_parameters(undef,2,'foo'); };
 516 ok ($@ =~ /^Unknown round mode 'foo'/,1);
 517
 518 @params = $x->_find_round_parameters(undef,2,'+inf');
 519 ok (scalar @params,4);                          # p=2
 520 ok ($params[0],$x);                             # self
 521 ok_undef ($params[1]);                          # a
 522 ok ($params[2],2);                              # p
 523 ok ($params[3],'+inf');                         # round_mode
 524
 525 @params = $x->_find_round_parameters(2,-2,'+inf');
 526 ok (scalar @params,1);                          # error, A and P defined
 527 ok ($params[0],$x);                             # self
 528
 529 ${"$mbi\::accuracy"} = 1;
 530 @params = $x->_find_round_parameters(undef,-2);
 531 ok (scalar @params,1);                          # error, A and P defined
 532 ok ($params[0],$x);                             # self
 533
 534 ${"$mbi\::accuracy"} = undef;
 535 ${"$mbi\::precision"} = 1;
 536 @params = $x->_find_round_parameters(1,undef);
 537 ok (scalar @params,1);                          # error, A and P defined
 538 ok ($params[0],$x);                             # self
 539
 540 ${"$mbi\::precision"} = undef;                  # reset
 541
 542 ###############################################################################
 543 # test whether bone/bzero take additional A & P, or reset it etc
 544
 545 foreach my $c ($mbi,$mbf)
 546   {
 547   $x = $c->new(2)->bzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p});
 548   $x = $c->new(2)->bone();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
 549   $x = $c->new(2)->binf();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
 550   $x = $c->new(2)->bnan();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
 551
 552   $x = $c->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->bnan();
 553   ok_undef ($x->{_a}); ok_undef ($x->{_p});
 554   $x = $c->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->binf();
 555   ok_undef ($x->{_a}); ok_undef ($x->{_p});
 556
 557   $x = $c->new(2,1); ok ($x->{_a},1); ok_undef ($x->{_p});
 558   $x = $c->new(2,undef,1); ok_undef ($x->{_a}); ok ($x->{_p},1);
 559
 560   $x = $c->new(2,1)->bzero(); ok ($x->{_a},1); ok_undef ($x->{_p});
 561   $x = $c->new(2,undef,1)->bzero(); ok_undef ($x->{_a}); ok ($x->{_p},1);
 562
 563   $x = $c->new(2,1)->bone(); ok ($x->{_a},1); ok_undef ($x->{_p});
 564   $x = $c->new(2,undef,1)->bone(); ok_undef ($x->{_a}); ok ($x->{_p},1);
 565
 566   $x = $c->new(2); $x->bone('+',2,undef); ok ($x->{_a},2); ok_undef ($x->{_p});
 567   $x = $c->new(2); $x->bone('+',undef,2); ok_undef ($x->{_a}); ok ($x->{_p},2);
 568   $x = $c->new(2); $x->bone('-',2,undef); ok ($x->{_a},2); ok_undef ($x->{_p});
 569   $x = $c->new(2); $x->bone('-',undef,2); ok_undef ($x->{_a}); ok ($x->{_p},2);
 570
 571   $x = $c->new(2); $x->bzero(2,undef); ok ($x->{_a},2); ok_undef ($x->{_p});
 572   $x = $c->new(2); $x->bzero(undef,2); ok_undef ($x->{_a}); ok ($x->{_p},2);
 573   }
 574
 575 ###############################################################################
 576 # test whether bone/bzero honour globals
 577
 578 for my $c ($mbi,$mbf)
 579   {
 580   $c->accuracy(2);
 581   $x = $c->bone(); ok ($x->accuracy(),2);
 582   $x = $c->bzero(); ok ($x->accuracy(),2);
 583   $c->accuracy(undef);
 584
 585   $c->precision(-2);
 586   $x = $c->bone(); ok ($x->precision(),-2);
 587   $x = $c->bzero(); ok ($x->precision(),-2);
 588   $c->precision(undef);
 589   }
 590
 591 ###############################################################################
 592 # check whether mixing A and P creates a NaN
 593
 594 # new with set accuracy/precision and with parameters
 595
 596 foreach my $c ($mbi,$mbf)
 597   {
 598   ok ($c->new(123,4,-3),'NaN');                 # with parameters
 599   ${"$c\::accuracy"} = 42;
 600   ${"$c\::precision"} = 2;
 601   ok ($c->new(123),'NaN');                      # with globals
 602   ${"$c\::accuracy"} = undef;
 603   ${"$c\::precision"} = undef;
 604   }
 605
 606 # binary ops
 607 foreach my $class ($mbi,$mbf)
 608   {
 609   foreach (qw/add sub mul pow mod/)
 610   #foreach (qw/add sub mul div pow mod/)
 611     {
 612     my $try = "my \$x = $class->new(1234); \$x->accuracy(5); ";
 613       $try .= "my \$y = $class->new(12); \$y->precision(-3); ";
 614       $try .= "\$x->b$_(\$y);";
 615     $rc = eval $try;
 616     print "# Tried: '$try'\n" if !ok ($rc, 'NaN');
 617     }
 618   }
 619
 620 # unary ops
 621 foreach (qw/new bsqrt/)
 622   {
 623   my $try = 'my $x = $mbi->$_(1234,5,-3); ';
 624   $rc = eval $try;
 625   print "# Tried: '$try'\n" if !ok ($rc, 'NaN');
 626   }
 627
 628 # see if $x->bsub(0) and $x->badd(0) really round
 629 foreach my $class ($mbi,$mbf)
 630   {
 631   $x = $class->new(123); $class->accuracy(2); $x->bsub(0);
 632   ok ($x,120);
 633   $class->accuracy(undef);
 634   $x = $class->new(123); $class->accuracy(2); $x->badd(0);
 635   ok ($x,120);
 636   $class->accuracy(undef);
 637   }
 638
 639 ###############################################################################
 640 # test whether shortcuts returning zero/one preserve A and P
 641
 642 my ($ans1,$f,$a,$p,$xp,$yp,$xa,$ya,$try,$ans,@args);
 643 my $CALC = Math::BigInt->config()->{lib};
 644 while (<DATA>)
 645   {
 646   chomp;
 647   next if /^\s*(#|$)/;  # skip comments and empty lines
 648   if (s/^&//)
 649     {
 650     $f = $_; next;      # function
 651     }
 652   @args = split(/:/,$_,99);
 653   my $ans = pop(@args);
 654
 655   ($x,$xa,$xp) = split (/,/,$args[0]);
 656   $xa = $xa || ''; $xp = $xp || '';
 657   $try  = "\$x = $mbi->new('$x'); ";
 658   $try .= "\$x->accuracy($xa); " if $xa ne '';
 659   $try .= "\$x->precision($xp); " if $xp ne '';
 660
 661   ($y,$ya,$yp) = split (/,/,$args[1]);
 662   $ya = $ya || ''; $yp = $yp || '';
 663   $try .= "\$y = $mbi->new('$y'); ";
 664   $try .= "\$y->accuracy($ya); " if $ya ne '';
 665   $try .= "\$y->precision($yp); " if $yp ne '';
 666
 667   $try .= "\$x->$f(\$y);";
 668
 669   #  print "trying $try\n";
 670   $rc = eval $try;
 671   # convert hex/binary targets to decimal
 672   if ($ans =~ /^(0x0x|0b0b)/)
 673     {
 674     $ans =~ s/^0[xb]//;
 675     $ans = $mbi->new($ans)->bstr();
 676     }
 677   print "# Tried: '$try'\n" if !ok ($rc, $ans);
 678   # check internal state of number objects
 679   is_valid($rc,$f) if ref $rc;
 680
 681   # now check whether A and P are set correctly
 682   # only one of $a or $p will be set (no crossing here)
 683   $a = $xa || $ya; $p = $xp || $yp;
 684
 685   # print "Check a=$a p=$p\n";
 686   # print "# Tried: '$try'\n";
 687   if ($a ne '')
 688     {
 689     if (!(ok ($x->{_a}, $a) && ok_undef ($x->{_p})))
 690       {
 691       print "# Check: A=$a and P=undef\n";
 692       print "# Tried: '$try'\n";
 693       }
 694     }
 695   if ($p ne '')
 696     {
 697     if (!(ok ($x->{_p}, $p) && ok_undef ($x->{_a})))
 698       {
 699       print "# Check: A=undef and P=$p\n";
 700       print "# Tried: '$try'\n";
 701       }
 702     }
 703   }
 704
 705 # all done
 706 1;
 707
 708 ###############################################################################
 709 ###############################################################################
 710 # Perl 5.005 does not like ok ($x,undef)
 711
 712 sub ok_undef
 713   {
 714   my $x = shift;
 715
 716   ok (1,1) and return 1 if !defined $x;
 717   ok ($x,'undef');
 718   print "# Called from ",join(' ',caller()),"\n";
 719   return 0;
 720   }
 721
 722 ###############################################################################
 723 # sub to check validity of a BigInt internally, to ensure that no op leaves a
 724 # number object in an invalid state (f.i. "-0")
 725
 726 sub is_valid
 727   {
 728   my ($x,$f) = @_;
 729
 730   my $e = 0;                    # error?
 731   # ok as reference?
 732   $e = 'Not a reference' if !ref($x);
 733
 734   # has ok sign?
 735   $e = "Illegal sign $x->{sign} (expected: '+', '-', '-inf', '+inf' or 'NaN'"
 736    if $e eq '0' && $x->{sign} !~ /^(\+|-|\+inf|-inf|NaN)$/;
 737
 738   $e = "-0 is invalid!" if $e ne '0' && $x->{sign} eq '-' && $x == 0;
 739   $e = $CALC->_check($x->{value}) if $e eq '0';
 740
 741   # test done, see if error did crop up
 742   ok (1,1), return if ($e eq '0');
 743
 744   ok (1,$e." after op '$f'");
 745   }
 746
 747 # format is:
 748 # x,A,P:x,A,P:result
 749 # 123,,3 means 123 with precision 3 (A is undef)
 750 # the A or P of the result is calculated automatically
 751 __DATA__
 752 &badd
 753 123,,:123,,:246
 754 123,3,:0,,:123
 755 123,,-3:0,,:123
 756 123,,:0,3,:123
 757 123,,:0,,-3:123
 758 &bmul
 759 123,,:1,,:123
 760 123,3,:0,,:0
 761 123,,-3:0,,:0
 762 123,,:0,3,:0
 763 123,,:0,,-3:0
 764 123,3,:1,,:123
 765 123,,-3:1,,:123
 766 123,,:1,3,:123
 767 123,,:1,,-3:123
 768 1,3,:123,,:123
 769 1,,-3:123,,:123
 770 1,,:123,3,:123
 771 1,,:123,,-3:123
 772 &bdiv
 773 123,,:1,,:123
 774 123,4,:1,,:123
 775 123,,:1,4,:123
 776 123,,:1,,-4:123
 777 123,,-4:1,,:123
 778 1,4,:123,,:0
 779 1,,:123,4,:0
 780 1,,:123,,-4:0
 781 1,,-4:123,,:0
 782 &band
 783 1,,:3,,:1
 784 1234,1,:0,,:0
 785 1234,,:0,1,:0
 786 1234,,-1:0,,:0
 787 1234,,:0,,-1:0
 788 0xFF,,:0x10,,:0x0x10
 789 0xFF,2,:0xFF,,:250
 790 0xFF,,:0xFF,2,:250
 791 0xFF,,1:0xFF,,:250
 792 0xFF,,:0xFF,,1:250
 793 &bxor
 794 1,,:3,,:2
 795 1234,1,:0,,:1000
 796 1234,,:0,1,:1000
 797 1234,,3:0,,:1000
 798 1234,,:0,,3:1000
 799 0xFF,,:0x10,,:239
 800 # 250 ^ 255 => 5
 801 0xFF,2,:0xFF,,:5
 802 0xFF,,:0xFF,2,:5
 803 0xFF,,1:0xFF,,:5
 804 0xFF,,:0xFF,,1:5
 805 # 250 ^ 4095 = 3845 => 3800
 806 0xFF,2,:0xFFF,,:3800
 807 # 255 ^ 4100 = 4347 => 4300
 808 0xFF,,:0xFFF,2,:4300
 809 0xFF,,2:0xFFF,,:3800
 810 # 255 ^ 4100 = 10fb => 4347 => 4300
 811 0xFF,,:0xFFF,,2:4300
 812 &bior
 813 1,,:3,,:3
 814 1234,1,:0,,:1000
 815 1234,,:0,1,:1000
 816 1234,,3:0,,:1000
 817 1234,,:0,,3:1000
 818 0xFF,,:0x10,,:0x0xFF
 819 # FF | FA = FF => 250
 820 250,2,:0xFF,,:250
 821 0xFF,,:250,2,:250
 822 0xFF,,1:0xFF,,:250
 823 0xFF,,:0xFF,,1:250
 824 &bpow
 825 2,,:3,,:8
 826 2,,:0,,:1
 827 2,2,:0,,:1
 828 2,,:0,2,:1