bigintpm.inc

source of perl for linux application,

#include this file into another for subclass testing

my $version = ${"$class\::VERSION"};

use strict;

##############################################################################
# for testing inheritance of _swap

package Math::Foo;

use Math::BigInt lib => $main::CL;
use vars qw/@ISA/;
@ISA = (qw/Math::BigInt/);

use overload
# customized overload for sub, since original does not use swap there
'-'     =>      sub { my @a = ref($_[0])->_swap(@_);
                   $a[0]->bsub($a[1])};

sub _swap
  {
  # a fake _swap, which reverses the params
  my $self = shift;                     # for override in subclass
  if ($_[2])
    {
    my $c = ref ($_[0] ) || 'Math::Foo';
    return ( $_[0]->copy(), $_[1] );
    }
  else
    {
    return ( Math::Foo->new($_[1]), $_[0] );
    }
  }

##############################################################################
package main;

my $CALC = $class->config()->{lib}; ok ($CALC,$CL);

my ($f,$z,$a,$exp,@a,$m,$e,$round_mode,$expected_class);

while (<DATA>) 
  {
  $_ =~ s/[\n\r]//g;	# remove newlines
  next if /^#/;	# skip comments
  if (s/^&//) 
    {
    $f = $_; next;
    }
  elsif (/^\$/) 
    {
    $round_mode = $_; $round_mode =~ s/^\$/$class\->/; next;
    }

  @args = split(/:/,$_,99); $ans = pop(@args);
  $expected_class = $class;
  if ($ans =~ /(.*?)=(.*)/)
    {
    $expected_class = $2; $ans = $1;
    }
  $try = "\$x = $class->new(\"$args[0]\");";
  if ($f eq "bnorm")
    {
    $try = "\$x = $class->bnorm(\"$args[0]\");";
  # some is_xxx tests
   } elsif ($f =~ /^is_(zero|one|odd|even|negative|positive|nan|int)$/) {
    $try .= "\$x->$f() || 0;";
   } elsif ($f eq "is_inf") {
    $try .= "\$x->is_inf('$args[1]');";
   } elsif ($f eq "binf") {
    $try .= "\$x->binf('$args[1]');";
   } elsif ($f eq "bone") {
    $try .= "\$x->bone('$args[1]');";
  # some unary ops
   } elsif ($f =~ /^b(nan|floor|ceil|sstr|neg|abs|inc|dec|not|sqrt|fac)$/) {
    $try .= "\$x->$f();";
   } elsif ($f =~ /^(numify|length|stringify|as_hex|as_bin)$/) {
    $try .= "\$x->$f();";
   } elsif ($f eq "exponent"){
    # ->bstr() to see if an object is returned
    $try .= '$x = $x->exponent()->bstr();';
   } elsif ($f eq "mantissa"){
    # ->bstr() to see if an object is returned
    $try .= '$x = $x->mantissa()->bstr();';
   } elsif ($f eq "parts"){
    $try .= '($m,$e) = $x->parts();'; 
    # ->bstr() to see if an object is returned
    $try .= '$m = $m->bstr(); $m = "NaN" if !defined $m;';
    $try .= '$e = $e->bstr(); $e = "NaN" if !defined $e;';
    $try .= '"$m,$e";';
   }elsif ($f eq "bexp"){
    $try .= "\$x->bexp();";
   } elsif ($f eq "bpi"){
    $try .= "$class\->bpi(\$x);";
   } else {
    # binary ops
    $try .= "\$y = $class->new('$args[1]');";
    if ($f eq "bcmp")
      {
      $try .= '$x->bcmp($y);';
      } elsif ($f eq "bround") {
      $try .= "$round_mode; \$x->bround(\$y);";
      } elsif ($f eq "bacmp"){
      $try .= '$x->bacmp($y);';
      } elsif ($f eq "badd"){
      $try .= '$x + $y;';
      } elsif ($f eq "bsub"){
      $try .= '$x - $y;';
      } elsif ($f eq "bmul"){
      $try .= '$x * $y;';
      } elsif ($f eq "bdiv"){
      $try .= '$x / $y;';
      } elsif ($f eq "bdiv-list"){
      $try .= 'join (",",$x->bdiv($y));';
      # overload via x=
      } elsif ($f =~ /^.=$/){
      $try .= "\$x $f \$y;";
      # overload via x
      } elsif ($f =~ /^.$/){
      $try .= "\$x $f \$y;";
      } elsif ($f eq "bmod"){
      $try .= '$x % $y;';
      } elsif ($f eq "bgcd")
        {
        if (defined $args[2])
          {
          $try .= " \$z = $class->new('$args[2]'); ";
          }
        $try .= "$class\::bgcd(\$x, \$y";
        $try .= ", \$z" if (defined $args[2]);
        $try .= " );";
        }
      elsif ($f eq "blcm")
        {
        if (defined $args[2])
          {
          $try .= " \$z = $class->new('$args[2]'); ";
          }
        $try .= "$class\::blcm(\$x, \$y";
        $try .= ", \$z" if (defined $args[2]);
        $try .= " );";
      }elsif ($f eq "blsft"){
        if (defined $args[2])
          {
          $try .= "\$x->blsft(\$y,$args[2]);";
          }
        else
          {
          $try .= "\$x << \$y;";
          }
      }elsif ($f eq "brsft"){
        if (defined $args[2])
          {
          $try .= "\$x->brsft(\$y,$args[2]);";
          }
        else
          {
          $try .= "\$x >> \$y;";
          }
      }elsif ($f eq "bnok"){
        $try .= "\$x->bnok(\$y);";
      }elsif ($f eq "broot"){
        $try .= "\$x->broot(\$y);";
      }elsif ($f eq "blog"){
        $try .= "\$x->blog(\$y);";
      }elsif ($f eq "band"){
        $try .= "\$x & \$y;";
      }elsif ($f eq "bior"){
        $try .= "\$x | \$y;";
      }elsif ($f eq "bxor"){
        $try .= "\$x ^ \$y;";
      }elsif ($f eq "bpow"){
        $try .= "\$x ** \$y;";
      } elsif( $f eq "bmodinv") {
       $try .= "\$x->bmodinv(\$y);";
      }elsif ($f eq "digit"){
        $try .= "\$x->digit(\$y);";
      }elsif ($f eq "batan2"){
        $try .= "\$x->batan2(\$y);";
      } else {
       # Functions with three arguments
       $try .= "\$z = $class->new(\"$args[2]\");";

       if( $f eq "bmodpow") {
         $try .= "\$x->bmodpow(\$y,\$z);";
      } elsif ($f eq "bmuladd"){
         $try .= "\$x->bmuladd(\$y,\$z);";
       } else { warn "Unknown op '$f'"; }
      }
    } # end else all other ops

  $ans1 = eval $try;
  # convert hex/binary targets to decimal	
  if ($ans =~ /^(0x0x|0b0b)/)
    {
    $ans =~ s/^0[xb]//; $ans = Math::BigInt->new($ans)->bstr();
    }
  if ($ans eq "")
    {
    ok_undef ($ans1); 
    }
  else
    {
    # print "try: $try ans: $ans1 $ans\n";
    print "# Tried: '$try'\n" if !ok ($ans1, $ans);
    ok (ref($ans),$expected_class) if $expected_class ne $class;
    }
  # check internal state of number objects
  is_valid($ans1,$f) if ref $ans1; 
  } # endwhile data tests
close DATA;

# test some more
@a = ();
for (my $i = 1; $i < 10; $i++) 
  {
  push @a, $i;
  }
ok "@a", "1 2 3 4 5 6 7 8 9";

# test whether self-multiplication works correctly (result is 2**64)
$try = "\$x = $class->new('4294967296');";
$try .= '$a = $x->bmul($x);';
$ans1 = eval $try;
print "# Tried: '$try'\n" if !ok ($ans1, $class->new(2) ** 64);
# test self-pow
$try = "\$x = $class->new(10);";
$try .= '$a = $x->bpow($x);';
$ans1 = eval $try;
print "# Tried: '$try'\n" if !ok ($ans1, $class->new(10) ** 10);

###############################################################################
# test whether op destroys args or not (should better not)

$x = $class->new(3);
$y = $class->new(4);
$z = $x & $y;
ok ($x,3);
ok ($y,4);
ok ($z,0);
$z = $x | $y;
ok ($x,3);
ok ($y,4);
ok ($z,7);
$x = $class->new(1);
$y = $class->new(2);
$z = $x | $y;
ok ($x,1);
ok ($y,2);
ok ($z,3);

$x = $class->new(5);
$y = $class->new(4);
$z = $x ^ $y;
ok ($x,5);
ok ($y,4);
ok ($z,1);

$x = $class->new(-5); $y = -$x;
ok ($x, -5);

$x = $class->new(-5); $y = abs($x);
ok ($x, -5);

$x = $class->new(8);
$y = $class->new(-1);
$z = $class->new(5033);
my $u = $x->copy()->bmodpow($y,$z);
ok ($u,4404);
ok ($y,-1);
ok ($z,5033);

$x = $class->new(-5); $y = -$x; ok ($x,-5); ok ($y,5);
$x = $class->new(-5); $y = $x->copy()->bneg(); ok ($x,-5); ok ($y,5);

$x = $class->new(-5); $y = $class->new(3); $x->bmul($y); ok ($x,-15); ok ($y,3);
$x = $class->new(-5); $y = $class->new(3); $x->badd($y); ok ($x,-2); ok ($y,3);
$x = $class->new(-5); $y = $class->new(3); $x->bsub($y); ok ($x,-8); ok ($y,3);
$x = $class->new(-15); $y = $class->new(3); $x->bdiv($y); ok ($x,-5); ok ($y,3);
$x = $class->new(-5); $y = $class->new(3); $x->bmod($y); ok ($x,1); ok ($y,3);

$x = $class->new(5); $y = $class->new(3); $x->bmul($y); ok ($x,15); ok ($y,3);
$x = $class->new(5); $y = $class->new(3); $x->badd($y); ok ($x,8); ok ($y,3);
$x = $class->new(5); $y = $class->new(3); $x->bsub($y); ok ($x,2); ok ($y,3);
$x = $class->new(15); $y = $class->new(3); $x->bdiv($y); ok ($x,5); ok ($y,3);
$x = $class->new(5); $y = $class->new(3); $x->bmod($y); ok ($x,2); ok ($y,3);

$x = $class->new(5); $y = $class->new(-3); $x->bmul($y); ok ($x,-15); ok($y,-3);
$x = $class->new(5); $y = $class->new(-3); $x->badd($y); ok ($x,2); ok($y,-3);
$x = $class->new(5); $y = $class->new(-3); $x->bsub($y); ok ($x,8); ok($y,-3);
$x = $class->new(15); $y = $class->new(-3); $x->bdiv($y); ok ($x,-5); ok($y,-3);
$x = $class->new(5); $y = $class->new(-3); $x->bmod($y); ok ($x,-1); ok($y,-3);

###############################################################################
# check whether overloading cmp works
$try = "\$x = $class->new(0);";
$try .= "\$y = 10;";
$try .= "'false' if \$x ne \$y;";
$ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "false" ); 

# we cant test for working cmpt with other objects here, we would need a dummy
# object with stringify overload for this. see Math::String tests as example

###############################################################################
# check reversed order of arguments

$try = "\$x = $class->new(10); \$x = 2 ** \$x;";
$try .= "'ok' if \$x == 1024;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class->new(10); \$x = 2 * \$x;";
$try .= "'ok' if \$x == 20;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class->new(10); \$x = 2 + \$x;";
$try .= "'ok' if \$x == 12;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class\->new(10); \$x = 2 - \$x;";
$try .= "'ok' if \$x == -8;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class\->new(10); \$x = 20 / \$x;";
$try .= "'ok' if \$x == 2;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class\->new(3); \$x = 20 % \$x;";
$try .= "'ok' if \$x == 2;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class\->new(7); \$x = 20 & \$x;";
$try .= "'ok' if \$x == 4;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class\->new(7); \$x = 0x20 | \$x;";
$try .= "'ok' if \$x == 0x27;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

$try = "\$x = $class\->new(7); \$x = 0x20 ^ \$x;";
$try .= "'ok' if \$x == 0x27;"; $ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

###############################################################################
# check badd(4,5) form

$try = "\$x = $class\->badd(4,5);";
$try .= "'ok' if \$x == 9;";
$ans = eval $try;
print "# For '$try'\n" if (!ok "$ans" , "ok" ); 

###############################################################################
# check undefs: NOT DONE YET

###############################################################################
# bool

$x = $class->new(1); if ($x) { ok (1,1); } else { ok($x,'to be true') }
$x = $class->new(0); if (!$x) { ok (1,1); } else { ok($x,'to be false') }

###############################################################################
# objectify()

@args = Math::BigInt::objectify(2,4,5);
ok (scalar @args,3);		# $class, 4, 5
ok ($args[0] =~ /^Math::BigInt/);
ok ($args[1],4);
ok ($args[2],5);

@args = Math::BigInt::objectify(0,4,5);
ok (scalar @args,3);		# $class, 4, 5
ok ($args[0] =~ /^Math::BigInt/);
ok ($args[1],4);
ok ($args[2],5);

@args = Math::BigInt::objectify(2,4,5);
ok (scalar @args,3);		# $class, 4, 5
ok ($args[0] =~ /^Math::BigInt/);
ok ($args[1],4);
ok ($args[2],5);

@args = Math::BigInt::objectify(2,4,5,6,7);
ok (scalar @args,5);		# $class, 4, 5, 6, 7
ok ($args[0] =~ /^Math::BigInt/);
ok ($args[1],4); ok (ref($args[1]),$args[0]);
ok ($args[2],5); ok (ref($args[2]),$args[0]);
ok ($args[3],6); ok (ref($args[3]),'');
ok ($args[4],7); ok (ref($args[4]),'');

@args = Math::BigInt::objectify(2,$class,4,5,6,7);
ok (scalar @args,5);		# $class, 4, 5, 6, 7
ok ($args[0],$class);
ok ($args[1],4); ok (ref($args[1]),$args[0]);
ok ($args[2],5); ok (ref($args[2]),$args[0]);
ok ($args[3],6); ok (ref($args[3]),'');
ok ($args[4],7); ok (ref($args[4]),'');

###############################################################################
# test whether an opp calls objectify properly or not (or at least does what
# it should do given non-objects, w/ or w/o objectify())

ok ($class->new(123)->badd(123),246);
ok ($class->badd(123,321),444);
ok ($class->badd(123,$class->new(321)),444);

ok ($class->new(123)->bsub(122),1);
ok ($class->bsub(321,123),198);
ok ($class->bsub(321,$class->new(123)),198);

ok ($class->new(123)->bmul(123),15129);
ok ($class->bmul(123,123),15129);
ok ($class->bmul(123,$class->new(123)),15129);

ok ($class->new(15129)->bdiv(123),123);
ok ($class->bdiv(15129,123),123);
ok ($class->bdiv(15129,$class->new(123)),123);

ok ($class->new(15131)->bmod(123),2);
ok ($class->bmod(15131,123),2);
ok ($class->bmod(15131,$class->new(123)),2);

ok ($class->new(2)->bpow(16),65536);
ok ($class->bpow(2,16),65536);
ok ($class->bpow(2,$class->new(16)),65536);

ok ($class->new(2**15)->brsft(1),2**14);
ok ($class->brsft(2**15,1),2**14);
ok ($class->brsft(2**15,$class->new(1)),2**14);

ok ($class->new(2**13)->blsft(1),2**14);
ok ($class->blsft(2**13,1),2**14);
ok ($class->blsft(2**13,$class->new(1)),2**14);

###############################################################################
# test for floating-point input (other tests in bnorm() below)

$z = 1050000000000000;          # may be int on systems with 64bit?
$x = $class->new($z); ok ($x->bsstr(),'105e+13');	# not 1.05e+15
$z = 1e+129;			# definitely a float (may fail on UTS)
# don't compare to $z, since some Perl versions stringify $z into something
# like '1.e+129' or something equally ugly
$x = $class->new($z); ok ($x->bsstr(),'1e+129');

###############################################################################
# test for whitespace inlcuding newlines to be handled correctly

# ok ($Math::BigInt::strict,1);		# the default

foreach my $c (
  qw/1 12 123 1234 12345 123456 1234567 12345678 123456789 1234567890/)
  {
  my $m = $class->new($c);
  ok ($class->new("$c"),$m);
  ok ($class->new(" $c"),$m);
  ok ($class->new("$c "),$m);
  ok ($class->new(" $c "),$m);
  ok ($class->new("\n$c"),$m);
  ok ($class->new("$c\n"),$m);
  ok ($class->new("\n$c\n"),$m);
  ok ($class->new(" \n$c\n"),$m);
  ok ($class->new(" \n$c \n"),$m);
  ok ($class->new(" \n$c\n "),$m);
  ok ($class->new(" \n$c\n1"),'NaN');
  ok ($class->new("1 \n$c\n1"),'NaN');
  }

###############################################################################
# prime number tests, also test for **= and length()
# found on: http://www.utm.edu/research/primes/notes/by_year.html

# ((2^148)-1)/17
$x = $class->new(2); $x **= 148; $x++; $x = $x / 17;
ok ($x,"20988936657440586486151264256610222593863921");
ok ($x->length(),length "20988936657440586486151264256610222593863921");

# MM7 = 2^127-1
$x = $class->new(2); $x **= 127; $x--;
ok ($x,"170141183460469231731687303715884105727");

$x = $class->new('215960156869840440586892398248');
($x,$y) = $x->length();
ok ($x,30); ok ($y,0);

$x = $class->new('1_000_000_000_000');
($x,$y) = $x->length();
ok ($x,13); ok ($y,0);

# test <<=, >>=
$x = $class->new('2');
my $y = $class->new('18');
ok ($x <<= $y, 2 << 18);
ok ($x, 2 << 18);
ok ($x >>= $y, 2);
ok ($x, 2);

# I am afraid the following is not yet possible due to slowness
# Also, testing for 2 meg output is a bit hard ;)
#$x = $class->new(2); $x **= 6972593; $x--;

# 593573509*2^332162+1 has exactly 1,000,000 digits
# takes about 24 mins on 300 Mhz, so cannot be done yet ;)
#$x = $class->new(2); $x **= 332162; $x *= "593573509"; $x++;
#ok ($x->length(),1_000_000);

###############################################################################
# inheritance and overriding of _swap

$x = Math::Foo->new(5);
$x = $x - 8;		# 8 - 5 instead of 5-8
ok ($x,3);
ok (ref($x),'Math::Foo');

$x = Math::Foo->new(5);
$x = 8 - $x;		# 5 - 8 instead of 8 - 5
ok ($x,-3);
ok (ref($x),'Math::Foo');

###############################################################################
# Test whether +inf eq inf
# This tried to test whether BigInt inf equals Perl inf. Unfortunately, Perl
# hasn't (before 5.7.3 at least) a consistent way to say inf, and some things
# like 1e100000 crash on some platforms. So simple test for the string 'inf'
$x = $class->new('+inf'); ok ($x,'inf');

###############################################################################
###############################################################################
# the followin tests only make sense with Math::BigInt::Calc or BareCalc or
# FastCalc

exit if $CALC !~ /^Math::BigInt::(|Bare|Fast)Calc$/; # for Pari et al.

###############################################################################
# check proper length of internal arrays

my $bl = $CL->_base_len();
my $BASE = '9' x $bl;
my $MAX = $BASE;
$BASE++;

$x = $class->new($MAX); is_valid($x);	# f.i. 9999
$x += 1; ok ($x,$BASE); is_valid($x); 	# 10000
$x -= 1; ok ($x,$MAX); is_valid($x);	# 9999 again

###############################################################################
# check numify

$x = $class->new($BASE-1);     ok ($x->numify(),$BASE-1); 
$x = $class->new(-($BASE-1));  ok ($x->numify(),-($BASE-1)); 

# +0 is to protect from 1e15 vs 100000000 (stupid to_string aaaarglburblll...)
$x = $class->new($BASE);       ok ($x->numify()+0,$BASE+0); 	
$x = $class->new(-$BASE);      ok ($x->numify(),-$BASE);
$x = $class->new( -($BASE*$BASE*1+$BASE*1+1) ); 
ok($x->numify(),-($BASE*$BASE*1+$BASE*1+1)); 

###############################################################################
# test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1

$x = $class->new($BASE-2); $x++; $x++; $x++; $x++;
if ($x > $BASE) { ok (1,1) } else { ok ("$x < $BASE","$x > $BASE"); }

$x = $class->new($BASE+3); $x++;
if ($x > $BASE) { ok (1,1) } else { ok ("$x > $BASE","$x < $BASE"); }

# test for +0 instead of int(): 
$x = $class->new($MAX); ok ($x->length(), length($MAX));

###############################################################################
# test bug that $class->digit($string) did not work

ok ($class->digit(123,2),1);

###############################################################################
# bug in sub where number with at least 6 trailing zeros after any op failed

$x = $class->new(123456); $z = $class->new(10000); $z *= 10; $x -= $z;
ok ($z, 100000);
ok ($x, 23456);

###############################################################################
# bug in shortcut in mul()

# construct a number with a zero-hole of BASE_LEN_SMALL
{
 my @bl = $CL->_base_len(); my $bl = $bl[4];

 $x = '1' x $bl . '0' x $bl . '1' x $bl . '0' x $bl;
 $y = '1' x (2*$bl);
 $x = $class->new($x)->bmul($y);
 # result is 123..$bl .  $bl x (3*bl-1) . $bl...321 . '0' x $bl
 $y = ''; my $d = '';
 for (my $i = 1; $i <= $bl; $i++)
   {
   $y .= $i; $d = $i.$d;
   }
 $y .= $bl x (3*$bl-1) . $d . '0' x $bl;
 ok ($x,$y);


  #############################################################################
  # see if mul shortcut for small numbers works

  $x = '9' x $bl;
  $x = $class->new($x); 
  # 999 * 999 => 998 . 001, 9999*9999 => 9998 . 0001
  ok ($x*$x, '9' x ($bl-1) . '8' . '0' x ($bl-1) . '1');
}

###############################################################################
# bug with rest "-0" in div, causing further div()s to fail

$x = $class->new('-322056000'); ($x,$y) = $x->bdiv('-12882240');

ok ($y,'0'); is_valid($y);	# $y not '-0'

###############################################################################
# bug in $x->bmod($y)

# if $x < 0 and $y > 0
$x = $class->new('-629'); ok ($x->bmod(5033),4404);

###############################################################################
# bone/binf etc as plain calls (Lite failed them)

ok ($class->bzero(),0);