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