mbimbf.inc

source of perl for linux application,

$x = $mbi->new(12345);
$x->bround(-1);
ok ($x,'12300');
ok ($x->{_a},4);
 
# bround(-n) should set _a
$x = $mbi->new(12345);
$x->bround(-2);
ok ($x,'12000');
ok ($x->{_a},3);
 
# bround(-n) should set _a
$x = $mbi->new(12345); $x->{_a} = 5;
$x->bround(-3);
ok ($x,'10000');
ok ($x->{_a},2);
 
# bround(-n) should set _a
$x = $mbi->new(12345); $x->{_a} = 5;
$x->bround(-4);
ok ($x,'0');
ok ($x->{_a},1);

# bround(-n) should be noop if n too big
$x = $mbi->new(12345);
$x->bround(-5);
ok ($x,'0');			# scale to "big" => 0
ok ($x->{_a},0);
 
# bround(-n) should be noop if n too big
$x = $mbi->new(54321);
$x->bround(-5);
ok ($x,'100000');		# used by MBF to round 0.0054321 at 0.0_6_00000
ok ($x->{_a},0);
 
# bround(-n) should be noop if n too big
$x = $mbi->new(54321); $x->{_a} = 5;
$x->bround(-6);
ok ($x,'100000');		# no-op
ok ($x->{_a},0);
 
# bround(n) should set _a
$x = $mbi->new(12345); $x->{_a} = 5;
$x->bround(5);                  # must be no-op
ok ($x,'12345');
ok ($x->{_a},5);
 
# bround(n) should set _a
$x = $mbi->new(12345); $x->{_a} = 5;
$x->bround(6);                  # must be no-op
ok ($x,'12345');

$x = $mbf->new('0.0061'); $x->bfround(-2); ok ($x,'0.01');
$x = $mbf->new('0.004'); $x->bfround(-2);  ok ($x,'0.00');
$x = $mbf->new('0.005'); $x->bfround(-2);  ok ($x,'0.00');

$x = $mbf->new('12345'); $x->bfround(2); ok ($x,'12340');
$x = $mbf->new('12340'); $x->bfround(2); ok ($x,'12340');

# MBI::bfround should clear A for negative P
$x = $mbi->new('1234'); $x->accuracy(3); $x->bfround(-2);
ok_undef ($x->{_a});

# test that bfround() and bround() work with large numbers

$x = $mbf->new(1)->bdiv(5678,undef,-63);
ok ($x, '0.000176118351532229658330398027474462839027826699542092286016203');

$x = $mbf->new(1)->bdiv(5678,undef,-90);
ok ($x, '0.000176118351532229658330398027474462839027826699542092286016202888340965128566396618527651');

$x = $mbf->new(1)->bdiv(5678,80);
ok ($x, '0.00017611835153222965833039802747446283902782669954209228601620288834096512856639662');

###############################################################################
# rounding with already set precision/accuracy

$x = $mbf->new(1); $x->{_p} = -5;
ok ($x,'1.00000');

# further rounding donw
ok ($x->bfround(-2),'1.00');
ok ($x->{_p},-2);

$x = $mbf->new(12345); $x->{_a} = 5;
ok ($x->bround(2),'12000');
ok ($x->{_a},2);

$x = $mbf->new('1.2345'); $x->{_a} = 5;
ok ($x->bround(2),'1.2');
ok ($x->{_a},2);

# mantissa/exponent format and A/P
$x = $mbf->new('12345.678'); $x->accuracy(4);
ok ($x,'12350'); ok ($x->{_a},4); ok_undef ($x->{_p});

#ok_undef ($x->{_m}->{_a}); ok_undef ($x->{_e}->{_a});
#ok_undef ($x->{_m}->{_p}); ok_undef ($x->{_e}->{_p});

# check for no A/P in case of fallback
# result
$x = $mbf->new(100) / 3;
ok_undef ($x->{_a}); ok_undef ($x->{_p});

# result & reminder
$x = $mbf->new(100) / 3; ($x,$y) = $x->bdiv(3);
ok_undef ($x->{_a}); ok_undef ($x->{_p});
ok_undef ($y->{_a}); ok_undef ($y->{_p});

###############################################################################
# math with two numbers with differen A and P

$x = $mbf->new(12345); $x->accuracy(4);		# '12340'
$y = $mbf->new(12345); $y->accuracy(2);		# '12000'
ok ($x+$y,24000);				# 12340+12000=> 24340 => 24000

$x = $mbf->new(54321); $x->accuracy(4);		# '12340'
$y = $mbf->new(12345); $y->accuracy(3);		# '12000'
ok ($x-$y,42000);				# 54320+12300=> 42020 => 42000

$x = $mbf->new('1.2345'); $x->precision(-2);	# '1.23'
$y = $mbf->new('1.2345'); $y->precision(-4);	# '1.2345'
ok ($x+$y,'2.46');				# 1.2345+1.2300=> 2.4645 => 2.46

###############################################################################
# round should find and use proper class

#$x = Foo->new();
#ok ($x->round($Foo::accuracy),'a' x $Foo::accuracy);
#ok ($x->round(undef,$Foo::precision),'p' x $Foo::precision);
#ok ($x->bfround($Foo::precision),'p' x $Foo::precision);
#ok ($x->bround($Foo::accuracy),'a' x $Foo::accuracy);

###############################################################################
# find out whether _find_round_parameters is doing what's it's supposed to do

{
  no strict 'refs'; 
  ${"$mbi\::accuracy"} = undef;
  ${"$mbi\::precision"} = undef;
  ${"$mbi\::div_scale"} = 40;
  ${"$mbi\::round_mode"} = 'odd';
}

$x = $mbi->new(123);
my @params = $x->_find_round_parameters();
ok (scalar @params,1);				# nothing to round

@params = $x->_find_round_parameters(1);
ok (scalar @params,4);				# a=1
ok ($params[0],$x);				# self
ok ($params[1],1);				# a
ok_undef ($params[2]);				# p
ok ($params[3],'odd');				# round_mode

@params = $x->_find_round_parameters(undef,2);
ok (scalar @params,4);				# p=2
ok ($params[0],$x);				# self
ok_undef ($params[1]);				# a
ok ($params[2],2);				# p
ok ($params[3],'odd');				# round_mode

eval { @params = $x->_find_round_parameters(undef,2,'foo'); };
ok ($@ =~ /^Unknown round mode 'foo'/,1);

@params = $x->_find_round_parameters(undef,2,'+inf');
ok (scalar @params,4);				# p=2
ok ($params[0],$x);				# self
ok_undef ($params[1]);				# a
ok ($params[2],2);				# p
ok ($params[3],'+inf');				# round_mode

@params = $x->_find_round_parameters(2,-2,'+inf');
ok (scalar @params,1);				# error, A and P defined
ok ($params[0],$x);				# self

{
  no strict 'refs';
  ${"$mbi\::accuracy"} = 1;
  @params = $x->_find_round_parameters(undef,-2);
  ok (scalar @params,1);			# error, A and P defined
  ok ($params[0],$x);				# self
  ok ($x->is_nan(),1);				# and must be NaN

  ${"$mbi\::accuracy"} = undef;
  ${"$mbi\::precision"} = 1;
  @params = $x->_find_round_parameters(1,undef);
  ok (scalar @params,1);			# error, A and P defined
  ok ($params[0],$x);				# self
  ok ($x->is_nan(),1);				# and must be NaN
 
  ${"$mbi\::precision"} = undef;		# reset
}

###############################################################################
# test whether bone/bzero take additional A & P, or reset it etc

foreach my $c ($mbi,$mbf)
  {
  $x = $c->new(2)->bzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p});
  $x = $c->new(2)->bone();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
  $x = $c->new(2)->binf();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
  $x = $c->new(2)->bnan();  ok_undef ($x->{_a}); ok_undef ($x->{_p});

  $x = $c->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->bnan();
  ok_undef ($x->{_a}); ok_undef ($x->{_p});
  $x = $c->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->binf();
  ok_undef ($x->{_a}); ok_undef ($x->{_p});

  $x = $c->new(2,1); ok ($x->{_a},1); ok_undef ($x->{_p});
  $x = $c->new(2,undef,1); ok_undef ($x->{_a}); ok ($x->{_p},1);
  
  $x = $c->new(2,1)->bzero(); ok ($x->{_a},1); ok_undef ($x->{_p});
  $x = $c->new(2,undef,1)->bzero(); ok_undef ($x->{_a}); ok ($x->{_p},1);

  $x = $c->new(2,1)->bone(); ok ($x->{_a},1); ok_undef ($x->{_p});
  $x = $c->new(2,undef,1)->bone(); ok_undef ($x->{_a}); ok ($x->{_p},1);

  $x = $c->new(2); $x->bone('+',2,undef); ok ($x->{_a},2); ok_undef ($x->{_p});
  $x = $c->new(2); $x->bone('+',undef,2); ok_undef ($x->{_a}); ok ($x->{_p},2);
  $x = $c->new(2); $x->bone('-',2,undef); ok ($x->{_a},2); ok_undef ($x->{_p});
  $x = $c->new(2); $x->bone('-',undef,2); ok_undef ($x->{_a}); ok ($x->{_p},2);
  
  $x = $c->new(2); $x->bzero(2,undef); ok ($x->{_a},2); ok_undef ($x->{_p});
  $x = $c->new(2); $x->bzero(undef,2); ok_undef ($x->{_a}); ok ($x->{_p},2);
  }

###############################################################################
# test whether bone/bzero honour globals

for my $c ($mbi,$mbf)
  {
  $c->accuracy(2);
  $x = $c->bone(); ok ($x->accuracy(),2);
  $x = $c->bzero(); ok ($x->accuracy(),2);
  $c->accuracy(undef);
  
  $c->precision(-2);
  $x = $c->bone(); ok ($x->precision(),-2);
  $x = $c->bzero(); ok ($x->precision(),-2);
  $c->precision(undef);
  }

###############################################################################
# check whether mixing A and P creates a NaN

# new with set accuracy/precision and with parameters
{
  no strict 'refs'; 
  foreach my $c ($mbi,$mbf)
    {
    ok ($c->new(123,4,-3),'NaN');			# with parameters
    ${"$c\::accuracy"} = 42;
    ${"$c\::precision"} = 2;
    ok ($c->new(123),'NaN');			# with globals
    ${"$c\::accuracy"} = undef;
    ${"$c\::precision"} = undef;
    }
}

# binary ops
foreach my $class ($mbi,$mbf)
  {
  foreach (qw/add sub mul pow mod/)
  #foreach (qw/add sub mul div pow mod/)
    {
    my $try = "my \$x = $class->new(1234); \$x->accuracy(5); ";
      $try .= "my \$y = $class->new(12); \$y->precision(-3); ";
      $try .= "\$x->b$_(\$y);";
    $rc = eval $try;
    print "# Tried: '$try'\n" if !ok ($rc, 'NaN');
    }
  }

# unary ops
foreach (qw/new bsqrt/)
  {
  my $try = 'my $x = $mbi->$_(1234,5,-3); ';
  $rc = eval $try;
  print "# Tried: '$try'\n" if !ok ($rc, 'NaN');
  }

# see if $x->bsub(0) and $x->badd(0) really round
foreach my $class ($mbi,$mbf)
  {
  $x = $class->new(123); $class->accuracy(2); $x->bsub(0);
  ok ($x,120);
  $class->accuracy(undef);
  $x = $class->new(123); $class->accuracy(2); $x->badd(0);
  ok ($x,120);
  $class->accuracy(undef);
  }

###############################################################################
# test whether shortcuts returning zero/one preserve A and P

my ($ans1,$f,$a,$p,$xp,$yp,$xa,$ya,$try,$ans,@args);
my $CALC = Math::BigInt->config()->{lib};
while (<DATA>)
  {
  $_ =~ s/[\n\r]//g;	# remove newlines
  next if /^\s*(#|$)/;	# skip comments and empty lines
  if (s/^&//)
    {
    $f = $_; next;	# function
    }
  @args = split(/:/,$_,99);
  my $ans = pop(@args);

  ($x,$xa,$xp) = split (/,/,$args[0]);
  $xa = $xa || ''; $xp = $xp || '';
  $try  = "\$x = $mbi->new('$x'); ";
  $try .= "\$x->accuracy($xa); " if $xa ne '';
  $try .= "\$x->precision($xp); " if $xp ne '';

  ($y,$ya,$yp) = split (/,/,$args[1]);
  $ya = $ya || ''; $yp = $yp || '';
  $try .= "\$y = $mbi->new('$y'); ";
  $try .= "\$y->accuracy($ya); " if $ya ne '';
  $try .= "\$y->precision($yp); " if $yp ne '';
  
  $try .= "\$x->$f(\$y);";
  
  # print "trying $try\n";
  $rc = eval $try;
  # convert hex/binary targets to decimal
  if ($ans =~ /^(0x0x|0b0b)/)
    {
    $ans =~ s/^0[xb]//;
    $ans = $mbi->new($ans)->bstr();
    }
  print "# Tried: '$try'\n" if !ok ($rc, $ans);
  # check internal state of number objects
  is_valid($rc,$f) if ref $rc;

  # now check whether A and P are set correctly
  # only one of $a or $p will be set (no crossing here)
  $a = $xa || $ya; $p = $xp || $yp;

  # print "Check a=$a p=$p\n";
  # print "# Tried: '$try'\n";
  if ($a ne '')
    {
    if (!(ok ($x->{_a}, $a) && ok_undef ($x->{_p})))
      {
      print "# Check: A=$a and P=undef\n";
      print "# Tried: '$try'\n";
      } 
    }
  if ($p ne '')
    {
    if (!(ok ($x->{_p}, $p) && ok_undef ($x->{_a})))
      {
      print "# Check: A=undef and P=$p\n";
      print "# Tried: '$try'\n";
      }
    }
  }

# all done
1;

###############################################################################
###############################################################################
# Perl 5.005 does not like ok ($x,undef)

sub ok_undef
  {
  my $x = shift;

  ok (1,1) and return 1 if !defined $x;
  ok ($x,'undef');
  print "# Called from ",join(' ',caller()),"\n";
  return 0;
  }

###############################################################################
# sub to check validity of a BigInt internally, to ensure that no op leaves a
# number object in an invalid state (f.i. "-0")

sub is_valid
  {
  my ($x,$f) = @_;

  my $e = 0;                    # error?
  # ok as reference?
  $e = 'Not a reference' if !ref($x);

  # has ok sign?
  $e = "Illegal sign $x->{sign} (expected: '+', '-', '-inf', '+inf' or 'NaN'"
   if $e eq '0' && $x->{sign} !~ /^(\+|-|\+inf|-inf|NaN)$/;

  $e = "-0 is invalid!" if $e ne '0' && $x->{sign} eq '-' && $x == 0;
  $e = $CALC->_check($x->{value}) if $e eq '0';

  # test done, see if error did crop up
  ok (1,1), return if ($e eq '0');

  ok (1,$e." after op '$f'");
  } 

# format is:
# x,A,P:x,A,P:result
# 123,,3 means 123 with precision 3 (A is undef)
# the A or P of the result is calculated automatically
__DATA__
&badd
123,,:123,,:246
123,3,:0,,:123
123,,-3:0,,:123
123,,:0,3,:123
123,,:0,,-3:123
&bmul
123,,:1,,:123
123,3,:0,,:0
123,,-3:0,,:0
123,,:0,3,:0
123,,:0,,-3:0
123,3,:1,,:123
123,,-3:1,,:123
123,,:1,3,:123
123,,:1,,-3:123
1,3,:123,,:123
1,,-3:123,,:123
1,,:123,3,:123
1,,:123,,-3:123
&bdiv
123,,:1,,:123
123,4,:1,,:123
123,,:1,4,:123
123,,:1,,-4:123
123,,-4:1,,:123
1,4,:123,,:0
1,,:123,4,:0
1,,:123,,-4:0
1,,-4:123,,:0
&band
1,,:3,,:1
1234,1,:0,,:0
1234,,:0,1,:0
1234,,-1:0,,:0
1234,,:0,,-1:0
0xFF,,:0x10,,:0x0x10
0xFF,2,:0xFF,,:250
0xFF,,:0xFF,2,:250
0xFF,,1:0xFF,,:250
0xFF,,:0xFF,,1:250
&bxor
1,,:3,,:2
1234,1,:0,,:1000
1234,,:0,1,:1000
1234,,3:0,,:1000
1234,,:0,,3:1000
0xFF,,:0x10,,:239
# 250 ^ 255 => 5
0xFF,2,:0xFF,,:5
0xFF,,:0xFF,2,:5
0xFF,,1:0xFF,,:5
0xFF,,:0xFF,,1:5
# 250 ^ 4095 = 3845 => 3800
0xFF,2,:0xFFF,,:3800
# 255 ^ 4100 = 4347 => 4300
0xFF,,:0xFFF,2,:4300
0xFF,,2:0xFFF,,:3800
# 255 ^ 4100 = 10fb => 4347 => 4300
0xFF,,:0xFFF,,2:4300
&bior
1,,:3,,:3
1234,1,:0,,:1000
1234,,:0,1,:1000
1234,,3:0,,:1000
1234,,:0,,3:1000
0xFF,,:0x10,,:0x0xFF
# FF | FA = FF => 250
250,2,:0xFF,,:250
0xFF,,:250,2,:250
0xFF,,1:0xFF,,:250
0xFF,,:0xFF,,1:250
&bpow
2,,:3,,:8
2,,:0,,:1
2,2,:0,,:1
2,,:0,2,:1