calc.pm

Astercon2 开源软交换 2.2.0

package Math::BigInt::Calc;

use 5.005;
use strict;
# use warnings;	# dont use warnings for older Perls

use vars qw/$VERSION/;

$VERSION = '0.47';

# Package to store unsigned big integers in decimal and do math with them

# Internally the numbers are stored in an array with at least 1 element, no
# leading zero parts (except the first) and in base 1eX where X is determined
# automatically at loading time to be the maximum possible value

# todo:
# - fully remove funky $# stuff in div() (maybe - that code scares me...)

# USE_MUL: due to problems on certain os (os390, posix-bc) "* 1e-5" is used
# instead of "/ 1e5" at some places, (marked with USE_MUL). Other platforms
# BS2000, some Crays need USE_DIV instead.
# The BEGIN block is used to determine which of the two variants gives the
# correct result.

# Beware of things like:
# $i = $i * $y + $car; $car = int($i / $MBASE); $i = $i % $MBASE;
# This works on x86, but fails on ARM (SA1100, iPAQ) due to whoknows what
# reasons. So, use this instead (slower, but correct):
# $i = $i * $y + $car; $car = int($i / $MBASE); $i -= $MBASE * $car;

##############################################################################
# global constants, flags and accessory

# announce that we are compatible with MBI v1.70 and up
sub api_version () { 1; }
 
# constants for easier life
my ($BASE,$BASE_LEN,$MBASE,$RBASE,$MAX_VAL,$BASE_LEN_SMALL);
my ($AND_BITS,$XOR_BITS,$OR_BITS);
my ($AND_MASK,$XOR_MASK,$OR_MASK);

sub _base_len 
  {
  # set/get the BASE_LEN and assorted other, connected values
  # used only be the testsuite, set is used only by the BEGIN block below
  shift;

  my $b = shift;
  if (defined $b)
    {
    # find whether we can use mul or div or none in mul()/div()
    # (in last case reduce BASE_LEN_SMALL)
    $BASE_LEN_SMALL = $b+1;
    my $caught = 0;
    while (--$BASE_LEN_SMALL > 5)
      {
      $MBASE = int("1e".$BASE_LEN_SMALL);
      $RBASE = abs('1e-'.$BASE_LEN_SMALL);		# see USE_MUL
      $caught = 0;
      $caught += 1 if (int($MBASE * $RBASE) != 1);	# should be 1
      $caught += 2 if (int($MBASE / $MBASE) != 1);	# should be 1
      last if $caught != 3;
      }
    # BASE_LEN is used for anything else than mul()/div()
    $BASE_LEN = $BASE_LEN_SMALL;
    $BASE_LEN = shift if (defined $_[0]);		# one more arg?
    $BASE = int("1e".$BASE_LEN);

    $MBASE = int("1e".$BASE_LEN_SMALL);
    $RBASE = abs('1e-'.$BASE_LEN_SMALL);		# see USE_MUL
    $MAX_VAL = $MBASE-1;
   
    # avoid redefinitions
 
    undef &_mul;
    undef &_div;

    # $caught & 1 != 0 => cannot use MUL
    # $caught & 2 != 0 => cannot use DIV
    # The parens around ($caught & 1) were important, indeed, if we would use
    # & here.
    if ($caught == 2)				# 2
      {
      # must USE_MUL since we cannot use DIV
      *{_mul} = \&_mul_use_mul;
      *{_div} = \&_div_use_mul;
      }
    else					# 0 or 1
      {
      # can USE_DIV instead
      *{_mul} = \&_mul_use_div;
      *{_div} = \&_div_use_div;
      }
    }
  return $BASE_LEN unless wantarray;
  return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL, $BASE);
  }

sub _new
  {
  # (ref to string) return ref to num_array
  # Convert a number from string format (without sign) to internal base
  # 1ex format. Assumes normalized value as input.
  my $il = length($_[1])-1;

  # < BASE_LEN due len-1 above
  return [ int($_[1]) ] if $il < $BASE_LEN;	# shortcut for short numbers

  # this leaves '00000' instead of int 0 and will be corrected after any op
  [ reverse(unpack("a" . ($il % $BASE_LEN+1) 
    . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
  }                                                                             

BEGIN
  {
  # from Daniel Pfeiffer: determine largest group of digits that is precisely
  # multipliable with itself plus carry
  # Test now changed to expect the proper pattern, not a result off by 1 or 2
  my ($e, $num) = 3;	# lowest value we will use is 3+1-1 = 3
  do 
    {
    $num = ('9' x ++$e) + 0;
    $num *= $num + 1.0;
    } while ("$num" =~ /9{$e}0{$e}/);	# must be a certain pattern
  $e--; 				# last test failed, so retract one step
  # the limits below brush the problems with the test above under the rug:
  # the test should be able to find the proper $e automatically
  $e = 5 if $^O =~ /^uts/;	# UTS get's some special treatment
  $e = 5 if $^O =~ /^unicos/;	# unicos is also problematic (6 seems to work
				# there, but we play safe)
  $e = 5 if $] < 5.006;		# cap, for older Perls
  $e = 7 if $e > 7;		# cap, for VMS, OS/390 and other 64 bit systems
				# 8 fails inside random testsuite, so take 7

  __PACKAGE__->_base_len($e);	# set and store

  use integer;
  # find out how many bits _and, _or and _xor can take (old default = 16)
  # I don't think anybody has yet 128 bit scalars, so let's play safe.
  local $^W = 0;	# don't warn about 'nonportable number'
  $AND_BITS = 15; $XOR_BITS = 15; $OR_BITS = 15;

  # find max bits, we will not go higher than numberofbits that fit into $BASE
  # to make _and etc simpler (and faster for smaller, slower for large numbers)
  my $max = 16;
  while (2 ** $max < $BASE) { $max++; }
  {
    no integer;
    $max = 16 if $] < 5.006;	# older Perls might not take >16 too well
  }
  my ($x,$y,$z);
  do {
    $AND_BITS++;
    $x = oct('0b' . '1' x $AND_BITS); $y = $x & $x;
    $z = (2 ** $AND_BITS) - 1;
    } while ($AND_BITS < $max && $x == $z && $y == $x);
  $AND_BITS --;						# retreat one step
  do {
    $XOR_BITS++;
    $x = oct('0b' . '1' x $XOR_BITS); $y = $x ^ 0;
    $z = (2 ** $XOR_BITS) - 1;
    } while ($XOR_BITS < $max && $x == $z && $y == $x);
  $XOR_BITS --;						# retreat one step
  do {
    $OR_BITS++;
    $x = oct('0b' . '1' x $OR_BITS); $y = $x | $x;
    $z = (2 ** $OR_BITS) - 1;
    } while ($OR_BITS < $max && $x == $z && $y == $x);
  $OR_BITS --;						# retreat one step
  
  $AND_MASK = __PACKAGE__->_new( ( 2 ** $AND_BITS ));
  $XOR_MASK = __PACKAGE__->_new( ( 2 ** $XOR_BITS ));
  $OR_MASK = __PACKAGE__->_new( ( 2 ** $OR_BITS ));
  }

###############################################################################

sub _zero
  {
  # create a zero
  [ 0 ];
  }

sub _one
  {
  # create a one
  [ 1 ];
  }

sub _two
  {
  # create a two (used internally for shifting)
  [ 2 ];
  }

sub _ten
  {
  # create a 10 (used internally for shifting)
  [ 10 ];
  }

sub _copy
  {
  # make a true copy
  [ @{$_[1]} ];
  }

# catch and throw away
sub import { }

##############################################################################
# convert back to string and number

sub _str
  {
  # (ref to BINT) return num_str
  # Convert number from internal base 100000 format to string format.
  # internal format is always normalized (no leading zeros, "-0" => "+0")
  my $ar = $_[1];

  my $l = scalar @$ar;				# number of parts
  if ($l < 1)					# should not happen
    {
    require Carp;
    Carp::croak("$_[1] has no elements");
    }

  my $ret = "";
  # handle first one different to strip leading zeros from it (there are no
  # leading zero parts in internal representation)
  $l --; $ret .= int($ar->[$l]); $l--;
  # Interestingly, the pre-padd method uses more time
  # the old grep variant takes longer (14 vs. 10 sec)
  my $z = '0' x ($BASE_LEN-1);                            
  while ($l >= 0)
    {
    $ret .= substr($z.$ar->[$l],-$BASE_LEN); # fastest way I could think of
    $l--;
    }
  $ret;
  }                                                                             

sub _num
  {
  # Make a number (scalar int/float) from a BigInt object 
  my $x = $_[1];

  return 0+$x->[0] if scalar @$x == 1;  # below $BASE
  my $fac = 1;
  my $num = 0;
  foreach (@$x)
    {
    $num += $fac*$_; $fac *= $BASE;
    }
  $num; 
  }

##############################################################################
# actual math code

sub _add
  {
  # (ref to int_num_array, ref to int_num_array)
  # routine to add two base 1eX numbers
  # stolen from Knuth Vol 2 Algorithm A pg 231
  # there are separate routines to add and sub as per Knuth pg 233
  # This routine clobbers up array x, but not y.
 
  my ($c,$x,$y) = @_;

  return $x if (@$y == 1) && $y->[0] == 0;		# $x + 0 => $x
  if ((@$x == 1) && $x->[0] == 0)			# 0 + $y => $y->copy
    {
    # twice as slow as $x = [ @$y ], but necc. to retain $x as ref :(
    @$x = @$y; return $x;		
    }
 
  # for each in Y, add Y to X and carry. If after that, something is left in
  # X, foreach in X add carry to X and then return X, carry
  # Trades one "$j++" for having to shift arrays
  my $i; my $car = 0; my $j = 0;
  for $i (@$y)
    {
    $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
    $j++;
    }
  while ($car != 0)
    {
    $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
    }
  $x;
  }                                                                             

sub _inc
  {
  # (ref to int_num_array, ref to int_num_array)
  # Add 1 to $x, modify $x in place
  my ($c,$x) = @_;

  for my $i (@$x)
    {
    return $x if (($i += 1) < $BASE);		# early out
    $i = 0;					# overflow, next
    }
  push @$x,1 if (($x->[-1] || 0) == 0);		# last overflowed, so extend
  $x;
  }                                                                             

sub _dec
  {
  # (ref to int_num_array, ref to int_num_array)
  # Sub 1 from $x, modify $x in place
  my ($c,$x) = @_;

  my $MAX = $BASE-1;				# since MAX_VAL based on MBASE
  for my $i (@$x)
    {
    last if (($i -= 1) >= 0);			# early out
    $i = $MAX;					# underflow, next
    }
  pop @$x if $x->[-1] == 0 && @$x > 1;		# last underflowed (but leave 0)
  $x;
  }                                                                             

sub _sub
  {
  # (ref to int_num_array, ref to int_num_array, swap)
  # subtract base 1eX numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
  # subtract Y from X by modifying x in place
  my ($c,$sx,$sy,$s) = @_;
 
  my $car = 0; my $i; my $j = 0;
  if (!$s)
    {
    for $i (@$sx)
      {
      last unless defined $sy->[$j] || $car;
      $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++;
      }
    # might leave leading zeros, so fix that
    return __strip_zeros($sx);
    }
  for $i (@$sx)
    {
    # we can't do an early out if $x is < than $y, since we
    # need to copy the high chunks from $y. Found by Bob Mathews.
    #last unless defined $sy->[$j] || $car;
    $sy->[$j] += $BASE
     if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0);
    $j++;
    }
  # might leave leading zeros, so fix that
  __strip_zeros($sy);
  }                                                                             

sub _mul_use_mul
  {
  # (ref to int_num_array, ref to int_num_array)
  # multiply two numbers in internal representation
  # modifies first arg, second need not be different from first
  my ($c,$xv,$yv) = @_;

  if (@$yv == 1)
    {
    # shortcut for two very short numbers (improved by Nathan Zook)
    # works also if xv and yv are the same reference, and handles also $x == 0
    if (@$xv == 1)
      {
      if (($xv->[0] *= $yv->[0]) >= $MBASE)
         {
         $xv->[0] = $xv->[0] - ($xv->[1] = int($xv->[0] * $RBASE)) * $MBASE;
         };
      return $xv;
      }
    # $x * 0 => 0
    if ($yv->[0] == 0)
      {
      @$xv = (0);
      return $xv;
      }
    # multiply a large number a by a single element one, so speed up
    my $y = $yv->[0]; my $car = 0;
    foreach my $i (@$xv)
      {
      $i = $i * $y + $car; $car = int($i * $RBASE); $i -= $car * $MBASE;
      }
    push @$xv, $car if $car != 0;
    return $xv;
    }
  # shortcut for result $x == 0 => result = 0
  return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); 

  # since multiplying $x with $x fails, make copy in this case
  $yv = [@$xv] if $xv == $yv;	# same references?

  my @prod = (); my ($prod,$car,$cty,$xi,$yi);

  for $xi (@$xv)
    {
    $car = 0; $cty = 0;

    # slow variant
#    for $yi (@$yv)
#      {
#      $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
#      $prod[$cty++] =
#       $prod - ($car = int($prod * RBASE)) * $MBASE;  # see USE_MUL
#      }
#    $prod[$cty] += $car if $car; # need really to check for 0?
#    $xi = shift @prod;

    # faster variant
    # looping through this if $xi == 0 is silly - so optimize it away!
    $xi = (shift @prod || 0), next if $xi == 0;
    for $yi (@$yv)
      {
      $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
##     this is actually a tad slower
##        $prod = $prod[$cty]; $prod += ($car + $xi * $yi);	# no ||0 here
      $prod[$cty++] =
       $prod - ($car = int($prod * $RBASE)) * $MBASE;  # see USE_MUL
      }
    $prod[$cty] += $car if $car; # need really to check for 0?
    $xi = shift @prod || 0;	# || 0 makes v5.005_3 happy
    }
  push @$xv, @prod;
  __strip_zeros($xv);
  $xv;
  }                                                                             

sub _mul_use_div
  {
  # (ref to int_num_array, ref to int_num_array)
  # multiply two numbers in internal representation
  # modifies first arg, second need not be different from first
  my ($c,$xv,$yv) = @_;
 
  if (@$yv == 1)
    {
    # shortcut for two small numbers, also handles $x == 0
    if (@$xv == 1)
      {
      # shortcut for two very short numbers (improved by Nathan Zook)
      # works also if xv and yv are the same reference, and handles also $x == 0
      if (($xv->[0] *= $yv->[0]) >= $MBASE)
          {
          $xv->[0] =
              $xv->[0] - ($xv->[1] = int($xv->[0] / $MBASE)) * $MBASE;
          };
      return $xv;
      }
    # $x * 0 => 0
    if ($yv->[0] == 0)
      {
      @$xv = (0);
      return $xv;
      }
    # multiply a large number a by a single element one, so speed up
    my $y = $yv->[0]; my $car = 0;
    foreach my $i (@$xv)
      {
      $i = $i * $y + $car; $car = int($i / $MBASE); $i -= $car * $MBASE;
      }
    push @$xv, $car if $car != 0;
    return $xv;
    }
  # shortcut for result $x == 0 => result = 0
  return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); 

  # since multiplying $x with $x fails, make copy in this case
  $yv = [@$xv] if $xv == $yv;	# same references?

  my @prod = (); my ($prod,$car,$cty,$xi,$yi);
  for $xi (@$xv)
    {
    $car = 0; $cty = 0;
    # looping through this if $xi == 0 is silly - so optimize it away!
    $xi = (shift @prod || 0), next if $xi == 0;
    for $yi (@$yv)
      {
      $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
      $prod[$cty++] =
       $prod - ($car = int($prod / $MBASE)) * $MBASE;
      }
    $prod[$cty] += $car if $car; # need really to check for 0?
    $xi = shift @prod || 0;	# || 0 makes v5.005_3 happy
    }
  push @$xv, @prod;
  __strip_zeros($xv);
  $xv;
  }                                                                             

sub _div_use_mul
  {
  # ref to array, ref to array, modify first array and return remainder if 
  # in list context

  # see comments in _div_use_div() for more explanations

  my ($c,$x,$yorg) = @_;
  
  # the general div algorithmn here is about O(N*N) and thus quite slow, so
  # we first check for some special cases and use shortcuts to handle them.

  # This works, because we store the numbers in a chunked format where each
  # element contains 5..7 digits (depending on system).

  # if both numbers have only one element:
  if (@$x == 1 && @$yorg == 1)
    {
    # shortcut, $yorg and $x are two small numbers
    if (wantarray)
      {
      my $r = [ $x->[0] % $yorg->[0] ];
      $x->[0] = int($x->[0] / $yorg->[0]);
      return ($x,$r); 
      }
    else
      {
      $x->[0] = int($x->[0] / $yorg->[0]);
      return $x; 
      }
    }

  # if x has more than one, but y has only one element: