diff options
author | Norbert Preining <norbert@preining.info> | 2021-04-02 03:20:54 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2021-04-02 03:20:54 +0000 |
commit | 3f173002d4a4a84e7d1fa5a74755fdd00d08a9c2 (patch) | |
tree | 5ed380344702de1f9ab53b68b6c3bcd6b8458087 /systems/texlive/tlnet/tlpkg/tlperl/lib/Math | |
parent | f78ba658b3ecd56053fe0837a4404d0c6c16a707 (diff) |
CTAN sync 202104020320
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Math')
5 files changed, 1094 insertions, 480 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm index 8a92b5818d..f1d7a1a0a0 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigFloat.pm @@ -19,8 +19,9 @@ use warnings; use Carp qw< carp croak >; use Math::BigInt (); -our $VERSION = '1.999816'; +our $VERSION = '1.999818'; +require Exporter; our @ISA = qw/Math::BigInt/; our @EXPORT_OK = qw/bpi/; @@ -28,8 +29,6 @@ our @EXPORT_OK = qw/bpi/; our ($AUTOLOAD, $accuracy, $precision, $div_scale, $round_mode, $rnd_mode, $upgrade, $downgrade, $_trap_nan, $_trap_inf); -my $class = "Math::BigFloat"; - use overload # overload key: with_assign @@ -273,7 +272,7 @@ sub AUTOLOAD { my $name = $AUTOLOAD; $name =~ s/(.*):://; # split package - my $c = $1 || $class; + my $c = $1 || __PACKAGE__; no strict 'refs'; $c->import() if $IMPORT == 0; if (!_method_alias($name)) { @@ -418,7 +417,8 @@ sub new { return $self; } - # Handle hexadecimal numbers. + # Handle hexadecimal numbers. We auto-detect hexadecimal numbers if they + # have a "0x" or "0X" prefix. if ($wanted =~ /^\s*[+-]?0[Xx]/) { $self = $class -> from_hex($wanted); @@ -426,7 +426,42 @@ sub new { return $self; } - # Handle binary numbers. + # Handle octal numbers. We auto-detect octal numbers if they have a "0" + # prefix and a binary exponent. + + if ($wanted =~ / + ^ + \s* + + # sign + [+-]? + + # prefix + 0 + + # significand using the octal digits 0..7 + [0-7]+ (?: _ [0-7]+ )* + (?: + \. + (?: [0-7]+ (?: _ [0-7]+ )* )? + )? + + # exponent (power of 2) using decimal digits + [Pp] + [+-]? + \d+ (?: _ \d+ )* + + \s* + $ + /x) + { + $self = $class -> from_oct($wanted); + $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; + return $self; + } + + # Handle binary numbers. We auto-detect binary numbers if they have a "0b" + # or "0B" prefix. if ($wanted =~ /^\s*[+-]?0[Bb]/) { $self = $class -> from_bin($wanted); @@ -781,6 +816,165 @@ sub from_bin { return $self->bnan(); } +sub from_ieee754 { + my $self = shift; + my $selfref = ref $self; + my $class = $selfref || $self; + + # Don't modify constant (read-only) objects. + + return if $selfref && $self->modify('from_ieee754'); + + my $in = shift; # input string (or raw bytes) + my $format = shift; # format ("binary32", "decimal64" etc.) + my $enc; # significand encoding (applies only to decimal) + my $k; # storage width in bits + my $b; # base + + if ($format =~ /^binary(\d+)\z/) { + $k = $1; + $b = 2; + } elsif ($format =~ /^decimal(\d+)(dpd|bcd)?\z/) { + $k = $1; + $b = 10; + $enc = $2 || 'dpd'; # default is dencely-packed decimals (DPD) + } elsif ($format eq 'half') { + $k = 16; + $b = 2; + } elsif ($format eq 'single') { + $k = 32; + $b = 2; + } elsif ($format eq 'double') { + $k = 64; + $b = 2; + } elsif ($format eq 'quadruple') { + $k = 128; + $b = 2; + } elsif ($format eq 'octuple') { + $k = 256; + $b = 2; + } elsif ($format eq 'sexdecuple') { + $k = 512; + $b = 2; + } + + if ($b == 2) { + + # Get the parameters for this format. + + my $p; # precision (in bits) + my $t; # number of bits in significand + my $w; # number of bits in exponent + + if ($k == 16) { # binary16 (half-precision) + $p = 11; + $t = 10; + $w = 5; + } elsif ($k == 32) { # binary32 (single-precision) + $p = 24; + $t = 23; + $w = 8; + } elsif ($k == 64) { # binary64 (double-precision) + $p = 53; + $t = 52; + $w = 11; + } else { # binaryN (quadruple-precision and above) + if ($k < 128 || $k != 32 * sprintf('%.0f', $k / 32)) { + croak "Number of bits must be 16, 32, 64, or >= 128 and", + " a multiple of 32"; + } + $p = $k - sprintf('%.0f', 4 * log($k) / log(2)) + 13; + $t = $p - 1; + $w = $k - $t - 1; + } + + # The maximum exponent, minimum exponent, and exponent bias. + + my $emax = Math::BigInt -> new(2) -> bpow($w - 1) -> bdec(); + my $emin = 1 - $emax; + my $bias = $emax; + + # Undefined input. + + unless (defined $in) { + carp("Input is undefined"); + return $self -> bzero(); + } + + # Make sure input string is a string of zeros and ones. + + my $len = CORE::length $in; + if (8 * $len == $k) { # bytes + $in = unpack "B*", $in; + } elsif (4 * $len == $k) { # hexadecimal + if ($in =~ /([^\da-f])/i) { + croak "Illegal hexadecimal digit '$1'"; + } + $in = unpack "B*", pack "H*", $in; + } elsif ($len == $k) { # bits + if ($in =~ /([^01])/) { + croak "Illegal binary digit '$1'"; + } + } else { + croak "Unknown input -- $in"; + } + + # Split bit string into sign, exponent, and mantissa/significand. + + my $sign = substr($in, 0, 1) eq '1' ? '-' : '+'; + my $expo = $class -> from_bin(substr($in, 1, $w)); + my $mant = $class -> from_bin(substr($in, $w + 1)); + + my $x; + + $expo -> bsub($bias); # subtract bias + + if ($expo < $emin) { # zero and subnormals + if ($mant == 0) { # zero + $x = $class -> bzero(); + } else { # subnormals + # compute (1/$b)**(N) rather than ($b)**(-N) + $x = $class -> new("0.5"); # 1/$b + $x -> bpow($bias + $t - 1) -> bmul($mant); + $x -> bneg() if $sign eq '-'; + } + } + + elsif ($expo > $emax) { # inf and nan + if ($mant == 0) { # inf + $x = $class -> binf($sign); + } else { # nan + $x = $class -> bnan(); + } + } + + else { # normals + $mant = $class -> new(2) -> bpow($t) -> badd($mant); + if ($expo < $t) { + # compute (1/$b)**(N) rather than ($b)**(-N) + $x = $class -> new("0.5"); # 1/$b + $x -> bpow($t - $expo) -> bmul($mant); + } else { + $x = $class -> new(2); + $x -> bpow($expo - $t) -> bmul($mant); + } + $x -> bneg() if $sign eq '-'; + } + + if ($selfref) { + $self -> {sign} = $x -> {sign}; + $self -> {_m} = $x -> {_m}; + $self -> {_es} = $x -> {_es}; + $self -> {_e} = $x -> {_e}; + } else { + $self = $x; + } + return $self; + } + + croak("The format '$format' is not yet supported."); +} + sub bzero { # create/assign '+0' @@ -3023,7 +3217,7 @@ sub bsqrt { return $x if $x->modify('bsqrt'); - return $x->bnan() if $x->{sign} !~ /^[+]/; # NaN, -inf or < 0 + return $x->bnan() if $x->{sign} !~ /^\+/; # NaN, -inf or < 0 return $x if $x->{sign} eq '+inf'; # sqrt(inf) == inf return $x->round($a, $p, $r) if $x->is_zero() || $x->is_one(); @@ -3783,7 +3977,7 @@ sub mantissa { if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; - $s =~ s/^[+]//; + $s =~ s/^\+//; return Math::BigInt->new($s, undef, undef); # -inf, +inf => +inf } my $m = Math::BigInt->new($LIB->_str($x->{_m}), undef, undef); @@ -3798,7 +3992,7 @@ sub exponent { if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; -$s =~ s/^[+-]//; + $s =~ s/^[+-]//; return Math::BigInt->new($s, undef, undef); # -inf, +inf => +inf } Math::BigInt->new($x->{_es} . $LIB->_str($x->{_e}), undef, undef); @@ -3810,9 +4004,9 @@ sub parts { if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; -$s =~ s/^[+]//; -my $se = $s; -$se =~ s/^[-]//; + $s =~ s/^\+//; + my $se = $s; + $se =~ s/^-//; return ($class->new($s), $class->new($se)); # +inf => inf and -inf, +inf => inf } my $m = Math::BigInt->bzero(); @@ -3981,9 +4175,9 @@ sub bstr { } my $es = '0'; -my $len = 1; -my $cad = 0; -my $dot = '.'; + my $len = 1; + my $cad = 0; + my $dot = '.'; # $x is zero? my $not_zero = !($x->{sign} eq '+' && $LIB->_is_zero($x->{_m})); @@ -4007,8 +4201,8 @@ my $dot = '.'; } elsif ($e > 0) { # expand with zeros $es .= '0' x $e; -$len += $e; -$cad = 0; + $len += $e; + $cad = 0; } } # if not zero @@ -4160,6 +4354,197 @@ sub to_bin { return $x->{sign} eq '-' ? "-$str" : $str; } +sub to_ieee754 { + my $x = shift; + my $format = shift; + my $class = ref $x; + + my $enc; # significand encoding (applies only to decimal) + my $k; # storage width in bits + my $b; # base + + if ($format =~ /^binary(\d+)\z/) { + $k = $1; + $b = 2; + } elsif ($format =~ /^decimal(\d+)(dpd|bcd)?\z/) { + $k = $1; + $b = 10; + $enc = $2 || 'dpd'; # default is dencely-packed decimals (DPD) + } elsif ($format eq 'half') { + $k = 16; + $b = 2; + } elsif ($format eq 'single') { + $k = 32; + $b = 2; + } elsif ($format eq 'double') { + $k = 64; + $b = 2; + } elsif ($format eq 'quadruple') { + $k = 128; + $b = 2; + } elsif ($format eq 'octuple') { + $k = 256; + $b = 2; + } elsif ($format eq 'sexdecuple') { + $k = 512; + $b = 2; + } + + if ($b == 2) { + + # Get the parameters for this format. + + my $p; # precision (in bits) + my $t; # number of bits in significand + my $w; # number of bits in exponent + + if ($k == 16) { # binary16 (half-precision) + $p = 11; + $t = 10; + $w = 5; + } elsif ($k == 32) { # binary32 (single-precision) + $p = 24; + $t = 23; + $w = 8; + } elsif ($k == 64) { # binary64 (double-precision) + $p = 53; + $t = 52; + $w = 11; + } else { # binaryN (quadruple-precition and above) + if ($k < 128 || $k != 32 * sprintf('%.0f', $k / 32)) { + croak "Number of bits must be 16, 32, 64, or >= 128 and", + " a multiple of 32"; + } + $p = $k - sprintf('%.0f', 4 * log($k) / log(2)) + 13; + $t = $p - 1; + $w = $k - $t - 1; + } + + # The maximum exponent, minimum exponent, and exponent bias. + + my $emax = $class -> new(2) -> bpow($w - 1) -> bdec(); + my $emin = 1 - $emax; + my $bias = $emax; + + # Get numerical sign, exponent, and mantissa/significand for bit + # string. + + my $sign = 0; + my $expo; + my $mant; + + if ($x -> is_nan()) { # nan + $sign = 1; + $expo = $emax -> copy() -> binc(); + $mant = $class -> new(2) -> bpow($t - 1); + } elsif ($x -> is_inf()) { # inf + $sign = 1 if $x -> is_neg(); + $expo = $emax -> copy() -> binc(); + $mant = $class -> bzero(); + } elsif ($x -> is_zero()) { # zero + $expo = $emin -> copy() -> bdec(); + $mant = $class -> bzero(); + } else { # normal and subnormal + + $sign = 1 if $x -> is_neg(); + + # Now we need to compute the mantissa and exponent in base $b. + + my $binv = $class -> new("0.5"); + my $b = $class -> new(2); + my $one = $class -> bone(); + + # We start off by initializing the exponent to zero and the + # mantissa to the input value. Then we increase the mantissa and + # decrease the exponent, or vice versa, until the mantissa is in + # the desired range or we hit one of the limits for the exponent. + + $mant = $x -> copy() -> babs(); + + # We need to find the base 2 exponent. First make an estimate of + # the base 2 exponent, before adjusting it below. We could skip + # this estimation and go straight to the while-loops below, but the + # loops are slow, especially when the final exponent is far from + # zero and even more so if the number of digits is large. This + # initial estimation speeds up the computation dramatically. + # + # log2($m * 10**$e) = log10($m + 10**$e) * log(10)/log(2) + # = (log10($m) + $e) * log(10)/log(2) + # = (log($m)/log(10) + $e) * log(10)/log(2) + + my ($m, $e) = $x -> nparts(); + my $ms = $m -> numify(); + my $es = $e -> numify(); + + my $expo_est = (log(abs($ms))/log(10) + $es) * log(10)/log(2); + $expo_est = int($expo_est); + + # Limit the exponent. + + if ($expo_est > $emax) { + $expo_est = $emax; + } elsif ($expo_est < $emin) { + $expo_est = $emin; + } + + # Don't multiply by a number raised to a negative exponent. This + # will cause a division, whose result is truncated to some fixed + # number of digits. Instead, multiply by the inverse number raised + # to a positive exponent. + + $expo = $class -> new($expo_est); + if ($expo_est > 0) { + $mant -> bmul($binv -> copy() -> bpow($expo)); + } elsif ($expo_est < 0) { + my $expo_abs = $expo -> copy() -> bneg(); + $mant -> bmul($b -> copy() -> bpow($expo_abs)); + } + + # Final adjustment. + + while ($mant >= $b && $expo <= $emax) { + $mant -> bmul($binv); + $expo -> binc(); + } + + while ($mant < $one && $expo >= $emin) { + $mant -> bmul($b); + $expo -> bdec(); + } + + # Encode as infinity, normal number or subnormal number? + + if ($expo > $emax) { # overflow => infinity + $expo = $emax -> copy() -> binc(); + $mant = $class -> bzero(); + } elsif ($expo < $emin) { # subnormal number + my $const = $class -> new(2) -> bpow($t - 1); + $mant -> bmul($const); + $mant -> bfround(0); + } else { # normal number + $mant -> bdec(); # remove implicit leading bit + my $const = $class -> new(2) -> bpow($t); + $mant -> bmul($const) -> bfround(0); + } + } + + $expo -> badd($bias); # add bias + + my $signbit = "$sign"; + + my $mantbits = $mant -> to_bin(); + $mantbits = ("0" x ($t - CORE::length($mantbits))) . $mantbits; + + my $expobits = $expo -> to_bin(); + $expobits = ("0" x ($w - CORE::length($expobits))) . $expobits; + + my $bin = $signbit . $expobits . $mantbits; + return pack "B*", $bin; + } + + croak("The format '$format' is not yet supported."); +} + sub as_hex { # return number as hexadecimal string (only for integers defined) @@ -4231,7 +4616,7 @@ sub numify { } # Create a string and let Perl's atoi()/atof() handle the rest. - return 0 + $x -> bsstr(); + return 0 + $x -> bnstr(); } ############################################################################### @@ -4242,7 +4627,7 @@ sub import { my $class = shift; my $l = scalar @_; my $lib = ''; -my @a; + my @a; my $lib_kind = 'try'; $IMPORT=1; for (my $i = 0; $i < $l ; $i++) { @@ -4314,7 +4699,7 @@ sub _len_to_steps { # D = 50 => N => 42, so L = 40 and R = 50 my $l = 40; -my $r = $d; + my $r = $d; # Otherwise this does not work under -Mbignum and we do not yet have "no bignum;" :( $l = $l->numify if ref($l); @@ -4370,7 +4755,6 @@ sub _log { $over->bmul($u); $factor = $class->new(3); $f = $class->new(2); - my $steps = 0; $limit = $class->new("1E-". ($scale-1)); while (3 < 5) { @@ -4717,7 +5101,6 @@ sub _pow { $over = $u->copy(); $limit = $class->new("1E-". ($scale-1)); - #my $steps = 0; while (3 < 5) { # we calculate the next term, and add it to the last # when the next term is below our limit, it won't affect the outcome @@ -4731,8 +5114,6 @@ sub _pow { $factor->binc(); last if $x->{sign} !~ /^[-+]$/; - - #$steps++; } if ($do_invert) { @@ -4795,6 +5176,7 @@ Math::BigFloat - Arbitrary size floating point math package $x = Math::BigFloat->from_oct('0377'); # ditto $x = Math::BigFloat->from_bin('0b1.1001p-4'); # from binary $x = Math::BigFloat->from_bin('0101'); # ditto + $x = Math::BigFloat->from_ieee754($b, "binary64"); # from IEEE-754 bytes $x = Math::BigFloat->bzero(); # create a +0 $x = Math::BigFloat->bone(); # create a +1 $x = Math::BigFloat->bone('-'); # create a -1 @@ -4926,6 +5308,7 @@ Math::BigFloat - Arbitrary size floating point math package $x->as_hex(); # as signed hexadecimal string with prefixed 0x $x->as_bin(); # as signed binary string with prefixed 0b $x->as_oct(); # as signed octal string with prefixed 0 + $x->to_ieee754($format); # to bytes encoded according to IEEE 754-2008 # Other conversion methods @@ -5106,6 +5489,17 @@ using decimal digits. If called as an instance method, the value is assigned to the invocand. +=item from_ieee754() + +Interpret the input as a value encoded as described in IEEE754-2008. The input +can be given as a byte string, hex string or binary string. The input is +assumed to be in big-endian byte-order. + + # both $dbl and $mbf are 3.141592... + $bytes = "\x40\x09\x21\xfb\x54\x44\x2d\x18"; + $dbl = unpack "d>", $bytes; + $mbf = Math::BigFloat -> from_ieee754($bytes, "binary64"); + =item bpi() print Math::BigFloat->bpi(100), "\n"; @@ -5225,6 +5619,29 @@ C<ref($x)-E<gt>new()> can parse to create an object. In Math::BigFloat, C<as_float()> has the same effect as C<copy()>. +=item to_ieee754() + +Encodes the invocand as a byte string in the given format as specified in IEEE +754-2008. Note that the encoded value is the nearest possible representation of +the value. This value might not be exactly the same as the value in the +invocand. + + # $x = 3.1415926535897932385 + $x = Math::BigFloat -> bpi(30); + + $b = $x -> to_ieee754("binary64"); # encode as 8 bytes + $h = unpack "H*", $b; # "400921fb54442d18" + + # 3.141592653589793115997963... + $y = Math::BigFloat -> from_ieee754($h, "binary64"); + +All binary formats in IEEE 754-2008 are accepted. For convenience, som aliases +are recognized: "half" for "binary16", "single" for "binary32", "double" for +"binary64", "quadruple" for "binary128", "octuple" for "binary256", and +"sexdecuple" for "binary512". + +See also L<https://en.wikipedia.org/wiki/IEEE_754>. + =back =head2 ACCURACY AND PRECISION @@ -5552,11 +5969,11 @@ L<http://annocpan.org/dist/Math-BigInt> =item * CPAN Ratings -L<http://cpanratings.perl.org/dist/Math-BigInt> +L<https://cpanratings.perl.org/dist/Math-BigInt> -=item * Search CPAN +=item * MetaCPAN -L<http://search.cpan.org/dist/Math-BigInt/> +L<https://metacpan.org/release/Math-BigInt> =item * CPAN Testers Matrix diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm index a443cd4a5d..185f802835 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt.pm @@ -1,3 +1,5 @@ +# -*- coding: utf-8-unix -*- + package Math::BigInt; # @@ -20,14 +22,12 @@ use warnings; use Carp qw< carp croak >; -our $VERSION = '1.999816'; +our $VERSION = '1.999818'; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(objectify bgcd blcm); -my $class = "Math::BigInt"; - # Inside overload, the first arg is always an object. If the original code had # it reversed (like $x = 2 * $y), then the third parameter is true. # In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes @@ -232,9 +232,7 @@ my $LIB = 'Math::BigInt::Calc'; # module to do the low level math # default is Calc.pm my $IMPORT = 0; # was import() called yet? # used to make require work -my %WARN; # warn only once for low-level libs my %CALLBACKS; # callbacks to notify on lib loads -my $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math ############################################################################## # the old code had $rnd_mode, so we need to support it, too @@ -1135,7 +1133,7 @@ sub bpi { if (@_ == 1) { # called like Math::BigInt::bpi(10); $n = $self; - $self = $class; + $self = __PACKAGE__; } $self = ref($self) if ref($self); @@ -1234,6 +1232,24 @@ sub is_negative { $x->{sign} =~ /^-/ ? 1 : 0; # -inf is negative, but NaN is not } +sub is_non_negative { + # Return true if argument is non-negative (>= 0). + my ($class, $x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); + + return 1 if $x->{sign} =~ /^\+/; + return 1 if $x -> is_zero(); + return 0; +} + +sub is_non_positive { + # Return true if argument is non-positive (<= 0). + my ($class, $x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); + + return 1 if $x->{sign} =~ /^\-/; + return 1 if $x -> is_zero(); + return 0; +} + sub is_odd { # return true when arg (BINT or num_str) is odd, false for even my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); @@ -2354,7 +2370,7 @@ sub bmodpow { $num->{value} = $value; $num->{sign} = $sign; - return $num; + return $num -> round(@r); } sub bpow { @@ -2401,21 +2417,14 @@ sub bpow { $r[3] = $y; # no push! - # cases 0 ** Y, X ** 0, X ** 1, 1 ** Y are handled by Calc or Emu - - my $new_sign = '+'; - $new_sign = $y->is_odd() ? '-' : '+' if ($x->{sign} ne '+'); + # 0 ** -y => ( 1 / (0 ** y)) => 1 / 0 => +inf + return $x->binf() if $y->is_negative() && $x->is_zero(); - # 0 ** -7 => ( 1 / (0 ** 7)) => 1 / 0 => +inf - return $x->binf() - if $y->{sign} eq '-' && $x->{sign} eq '+' && $LIB->_is_zero($x->{value}); # 1 ** -y => 1 / (1 ** |y|) - # so do test for negative $y after above's clause - return $x->bnan() if $y->{sign} eq '-' && !$LIB->_is_one($x->{value}); + return $x->bzero() if $y->is_negative() && !$LIB->_is_one($x->{value}); $x->{value} = $LIB->_pow($x->{value}, $y->{value}); - $x->{sign} = $new_sign; - $x->{sign} = '+' if $LIB->_is_zero($y->{value}); + $x->{sign} = $x->is_negative() && $y->is_odd() ? '-' : '+'; $x->round(@r); } @@ -2483,7 +2492,7 @@ sub blog { return $x; } - my ($rc, $exact) = $LIB->_log_int($x->{value}, $base->{value}); + my ($rc) = $LIB->_log_int($x->{value}, $base->{value}); return $x->bnan() unless defined $rc; # not possible to take log? $x->{value} = $rc; $x->round(@r); @@ -2602,6 +2611,126 @@ sub bnok { $n->round(@r); } +sub buparrow { + my $a = shift; + my $y = $a -> uparrow(@_); + $a -> {value} = $y -> {value}; + return $a; +} + +sub uparrow { + # Knuth's up-arrow notation buparrow(a, n, b) + # + # The following is a simple, recursive implementation of the up-arrow + # notation, just to show the idea. Such implementations cause "Deep + # recursion on subroutine ..." warnings, so we use a faster, non-recursive + # algorithm below with @_ as a stack. + # + # sub buparrow { + # my ($a, $n, $b) = @_; + # return $a ** $b if $n == 1; + # return $a * $b if $n == 0; + # return 1 if $b == 0; + # return buparrow($a, $n - 1, buparrow($a, $n, $b - 1)); + # } + + my ($a, $b, $n) = @_; + my $class = ref $a; + croak("a must be non-negative") if $a < 0; + croak("n must be non-negative") if $n < 0; + croak("b must be non-negative") if $b < 0; + + while (@_ >= 3) { + + # return $a ** $b if $n == 1; + + if ($_[-2] == 1) { + my ($a, $n, $b) = splice @_, -3; + push @_, $a ** $b; + next; + } + + # return $a * $b if $n == 0; + + if ($_[-2] == 0) { + my ($a, $n, $b) = splice @_, -3; + push @_, $a * $b; + next; + } + + # return 1 if $b == 0; + + if ($_[-1] == 0) { + splice @_, -3; + push @_, $class -> bone(); + next; + } + + # return buparrow($a, $n - 1, buparrow($a, $n, $b - 1)); + + my ($a, $n, $b) = splice @_, -3; + push @_, ($a, $n - 1, + $a, $n, $b - 1); + + } + + pop @_; +} + +sub backermann { + my $m = shift; + my $y = $m -> ackermann(@_); + $m -> {value} = $y -> {value}; + return $m; +} + +sub ackermann { + # Ackermann's function ackermann(m, n) + # + # The following is a simple, recursive implementation of the ackermann + # function, just to show the idea. Such implementations cause "Deep + # recursion on subroutine ..." warnings, so we use a faster, non-recursive + # algorithm below with @_ as a stack. + # + # sub ackermann { + # my ($m, $n) = @_; + # return $n + 1 if $m == 0; + # return ackermann($m - 1, 1) if $m > 0 && $n == 0; + # return ackermann($m - 1, ackermann($m, $n - 1) if $m > 0 && $n > 0; + # } + + my ($m, $n) = @_; + my $class = ref $m; + croak("m must be non-negative") if $m < 0; + croak("n must be non-negative") if $n < 0; + + my $two = $class -> new("2"); + my $three = $class -> new("3"); + my $thirteen = $class -> new("13"); + + $n = pop; + $n = $class -> new($n) unless ref($n); + while (@_) { + my $m = pop; + if ($m > $three) { + push @_, (--$m) x $n; + while (--$m >= $three) { + push @_, $m; + } + $n = $thirteen; + } elsif ($m == $three) { + $n = $class -> bone() -> blsft($n + $three) -> bsub($three); + } elsif ($m == $two) { + $n -> bmul($two) -> badd($three); + } elsif ($m >= 0) { + $n -> badd($m) -> binc(); + } else { + die "negative m!"; + } + } + $n; +} + sub bsin { # Calculate sinus(x) to N digits. Unless upgrading is in effect, returns the # result truncated to an integer. @@ -2654,9 +2783,9 @@ sub batan { return $upgrade->new($x)->batan(@r) if defined $upgrade; # calculate the result and truncate it to integer - my $t = Math::BigFloat->new($x)->batan(@r); + my $tmp = Math::BigFloat->new($x)->batan(@r); - $x->{value} = $LIB->_new($x->as_int()->bstr()); + $x->{value} = $LIB->_new($tmp->as_int()->bstr()); $x->round(@r); } @@ -2902,12 +3031,19 @@ sub blsft { # (BINT or num_str, BINT or num_str) return BINT # compute x << y, base n, y >= 0 - # set up parameters - my ($class, $x, $y, $b, @r) = (ref($_[0]), @_); + my ($class, $x, $y, $b, @r); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, $b, @r) = objectify(2, @_); + # Objectify the base only when it is defined, since an undefined base, as + # in $x->blsft(3) or $x->blog(3, undef) means use the default base 2. + + if (!ref($_[0]) && $_[0] =~ /^[A-Za-z]|::/) { + # E.g., Math::BigInt->blog(256, 5, 2) + ($class, $x, $y, $b, @r) = + defined $_[3] ? objectify(3, @_) : objectify(2, @_); + } else { + # E.g., Math::BigInt::blog(256, 5, 2) or $x->blog(5, 2) + ($class, $x, $y, $b, @r) = + defined $_[2] ? objectify(3, @_) : objectify(2, @_); } return $x if $x -> modify('blsft'); @@ -2915,7 +3051,15 @@ sub blsft { $y -> {sign} !~ /^[+-]$/); return $x -> round(@r) if $y -> is_zero(); - $b = 2 if !defined $b; + $b = defined($b) ? $b -> numify() : 2; + + # While some of the libraries support an arbitrarily large base, not all of + # them do, so rather than returning an incorrect result in those cases, + # disallow bases that don't work with all libraries. + + my $uintmax = ~0; + croak("Base is too large.") if $b > $uintmax; + return $x -> bnan() if $b <= 0 || $y -> {sign} eq '-'; $x -> {value} = $LIB -> _lsft($x -> {value}, $y -> {value}, $b); @@ -3146,7 +3290,7 @@ sub bround { # do not return $x->bnorm(), but $x my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; my ($scale, $mode) = $x->_scale_a(@_); return $x if !defined $scale || $x->modify('bround'); # no-op @@ -3264,7 +3408,7 @@ sub fround { # Exists to make life easier for switch between MBF and MBI (should we # autoload fxxx() like MBF does for bxxx()?) my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; $x->bround(@_); } @@ -3356,6 +3500,31 @@ sub digit { $LIB->_digit($x->{value}, $n || 0); } +sub bdigitsum { + # like digitsum(), but assigns the result to the invocand + my $x = shift; + + return $x if $x -> is_nan(); + return $x -> bnan() if $x -> is_inf(); + + $x -> {value} = $LIB -> _digitsum($x -> {value}); + $x -> {sign} = '+'; + return $x; +} + +sub digitsum { + # compute sum of decimal digits and return it + my $x = shift; + my $class = ref $x; + + return $class -> bnan() if $x -> is_nan(); + return $class -> bnan() if $x -> is_inf(); + + my $y = $class -> bzero(); + $y -> {value} = $LIB -> _digitsum($x -> {value}); + return $y; +} + sub length { my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); @@ -3652,7 +3821,7 @@ sub bdstr { sub to_hex { # return as hex string, with prefixed 0x my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3663,7 +3832,7 @@ sub to_hex { sub to_oct { # return as octal string, with prefixed 0 my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3674,7 +3843,7 @@ sub to_oct { sub to_bin { # return as binary string, with prefixed 0b my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3685,7 +3854,7 @@ sub to_bin { sub to_bytes { # return a byte string my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); croak("to_bytes() requires a finite, non-negative integer") if $x -> is_neg() || ! $x -> is_int(); @@ -3699,13 +3868,13 @@ sub to_bytes { sub to_base { # return a base anything string my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); croak("the value to convert must be a finite, non-negative integer") if $x -> is_neg() || !$x -> is_int(); my $base = shift; - $base = $class->new($base) unless ref($base); + $base = __PACKAGE__->new($base) unless ref($base); croak("the base must be a finite integer >= 2") if $base < 2 || ! $base -> is_int(); @@ -3729,7 +3898,7 @@ sub to_base { sub as_hex { # return as hex string, with prefixed 0x my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3740,7 +3909,7 @@ sub as_hex { sub as_oct { # return as octal string, with prefixed 0 my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3751,7 +3920,7 @@ sub as_oct { sub as_bin { # return as binary string, with prefixed 0b my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3768,7 +3937,7 @@ sub as_bin { sub numify { # Make a Perl scalar number from a Math::BigInt object. my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; if ($x -> is_nan()) { require Math::Complex; @@ -3817,7 +3986,7 @@ sub objectify { # Check the context. unless (wantarray) { - croak("${class}::objectify() needs list context"); + croak(__PACKAGE__ . "::objectify() needs list context"); } # Get the number of arguments to objectify. @@ -3935,10 +4104,9 @@ sub objectify { sub import { my $class = shift; $IMPORT++; # remember we did import() - my @a; - my $l = scalar @_; + my @a; # unrecognized arguments my $warn_or_die = 0; # 0 - no warn, 1 - warn, 2 - die - for (my $i = 0; $i < $l ; $i++) { + for (my $i = 0; $i <= $#_ ; $i++) { if ($_[$i] eq ':constant') { # this causes overlord er load to step in overload::constant @@ -3951,7 +4119,9 @@ sub import { } elsif ($_[$i] =~ /^(lib|try|only)\z/) { # this causes a different low lib to take care... $LIB = $_[$i+1] || ''; - # lib => 1 (warn on fallback), try => 0 (no warn), only => 2 (die on fallback) + # try => 0 (no warn) + # lib => 1 (warn on fallback) + # only => 2 (die on fallback) $warn_or_die = 1 if $_[$i] eq 'lib'; $warn_or_die = 2 if $_[$i] eq 'only'; $i++; @@ -3968,77 +4138,34 @@ sub import { # try to load core math lib my @c = split /\s*,\s*/, $LIB; foreach (@c) { - $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters + tr/a-zA-Z0-9://cd; # limit to sane characters } push @c, \'Calc' # if all fail, try these if $warn_or_die < 2; # but not for "only" - $LIB = ''; # signal error + $LIB = ''; # signal error foreach my $l (@c) { # fallback libraries are "marked" as \'string', extract string if nec. my $lib = $l; $lib = $$l if ref($l); - next if ($lib || '') eq ''; + next unless defined($lib) && CORE::length($lib); $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i; $lib =~ s/\.pm$//; - if ($] < 5.006) { - # Perl < 5.6.0 dies with "out of memory!" when eval("") and ':constant' is - # used in the same script, or eval("") inside import(). - my @parts = split /::/, $lib; # Math::BigInt => Math BigInt - my $file = pop @parts; - $file .= '.pm'; # BigInt => BigInt.pm - require File::Spec; - $file = File::Spec->catfile (@parts, $file); - eval { - require "$file"; - $lib->import(@c); - } - } else { - eval "use $lib qw/@c/;"; - } + my @parts = split /::/, $lib; # Math::BigInt => Math BigInt + $parts[-1] .= '.pm'; # BigInt => BigInt.pm + require File::Spec; + my $file = File::Spec->catfile(@parts); + eval { require $file; }; if ($@ eq '') { - my $ok = 1; - # loaded it ok, see if the api_version() is high enough - if ($lib->can('api_version') && $lib->api_version() >= 1.0) { - $ok = 0; - # api_version matches, check if it really provides anything we need - for my $method (qw/ - one two ten - str num - add mul div sub dec inc - acmp len digit is_one is_zero is_even is_odd - is_two is_ten - zeros new copy check - from_hex from_oct from_bin as_hex as_bin as_oct - rsft lsft xor and or - mod sqrt root fac pow modinv modpow log_int gcd - /) { - if (!$lib->can("_$method")) { - if (($WARN{$lib} || 0) < 2) { - carp("$lib is missing method '_$method'"); - $WARN{$lib} = 1; # still warn about the lib - } - $ok++; - last; - } - } - } - if ($ok == 0) { - $LIB = $lib; - if ($warn_or_die > 0 && ref($l)) { - my $msg = "Math::BigInt: couldn't load specified" - . " math lib(s), fallback to $lib"; - carp($msg) if $warn_or_die == 1; - croak($msg) if $warn_or_die == 2; - } - last; # found a usable one, break - } else { - if (($WARN{$lib} || 0) < 2) { - my $ver = eval "\$$lib\::VERSION" || 'unknown'; - carp("Cannot load outdated $lib v$ver, please upgrade"); - $WARN{$lib} = 2; # never warn again - } + $lib->import(); + $LIB = $lib; + if ($warn_or_die > 0 && ref($l)) { + my $msg = "Math::BigInt: couldn't load specified" + . " math lib(s), fallback to $lib"; + carp($msg) if $warn_or_die == 1; + croak($msg) if $warn_or_die == 2; } + last; # found a usable one, break } } if ($LIB eq '') { @@ -4210,7 +4337,7 @@ sub _split { sub _trailing_zeros { # return the amount of trailing zeros in $x (as scalar) my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; return 0 if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf etc @@ -4423,6 +4550,8 @@ Math::BigInt - Arbitrary size integer/float math package $x->blog($base); # logarithm of $x to base $base (e.g., base 2) $x->bexp(); # calculate e ** $x where e is Euler's number $x->bnok($y); # x over y (binomial coefficient n over k) + $x->buparrow($n, $y); # Knuth's up-arrow notation + $x->backermann($y); # the Ackermann function $x->bsin(); # sine $x->bcos(); # cosine $x->batan(); # inverse tangent @@ -4987,6 +5116,18 @@ neither positive nor negative. Returns true if the invocand is negative and false otherwise. A C<NaN> is neither positive nor negative. +=item is_non_positive() + + $x->is_non_positive(); # true if <= 0 + +Returns true if the invocand is negative or zero. + +=item is_non_negative() + + $x->is_non_negative(); # true if >= 0 + +Returns true if the invocand is positive or zero. + =item is_odd() $x->is_odd(); # true if odd, false for even @@ -5292,6 +5433,38 @@ pseudo-code: The behaviour is identical to the behaviour of the Maple and Mathematica function for negative integers n, k. +=item buparrow() + +=item uparrow() + + $a -> buparrow($n, $b); # modifies $a + $x = $a -> uparrow($n, $b); # does not modify $a + +This method implements Knuth's up-arrow notation, where $n is a non-negative +integer representing the number of up-arrows. $n = 0 gives multiplication, $n = +1 gives exponentiation, $n = 2 gives tetration, $n = 3 gives hexation etc. The +following illustrates the relation between the first values of $n. + +See L<https://en.wikipedia.org/wiki/Knuth%27s_up-arrow_notation>. + +=item backermann() + +=item ackermann() + + $m -> backermann($n); # modifies $a + $x = $m -> ackermann($n); # does not modify $a + +This method implements the Ackermann function: + + / n + 1 if m = 0 + A(m, n) = | A(m-1, 1) if m > 0 and n = 0 + \ A(m-1, A(m, n-1)) if m > 0 and n > 0 + +Its value grows rapidly, even for small inputs. For example, A(4, 2) is an +integer of 19729 decimal digits. + +See https://en.wikipedia.org/wiki/Ackermann_function + =item bsin() my $x = Math::BigInt->new(1); @@ -5590,6 +5763,18 @@ If you want $x to have a certain sign, use one of the following methods: If C<$n> is negative, returns the digit counting from left. +=item digitsum() + + $x->digitsum(); + +Computes the sum of the base 10 digits and returns it. + +=item bdigitsum() + + $x->bdigitsum(); + +Computes the sum of the base 10 digits and assigns the result to the invocand. + =item length() $x->length(); @@ -6696,11 +6881,11 @@ L<http://annocpan.org/dist/Math-BigInt> =item * CPAN Ratings -L<http://cpanratings.perl.org/dist/Math-BigInt> +L<https://cpanratings.perl.org/dist/Math-BigInt> -=item * Search CPAN +=item * MetaCPAN -L<http://search.cpan.org/dist/Math-BigInt/> +L<https://metacpan.org/release/Math-BigInt> =item * CPAN Testers Matrix diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Calc.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Calc.pm index 2bb06a0976..cd8f1ee44e 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Calc.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Calc.pm @@ -7,7 +7,7 @@ use warnings; use Carp qw< carp croak >; use Math::BigInt::Lib; -our $VERSION = '1.999816'; +our $VERSION = '1.999818'; our @ISA = ('Math::BigInt::Lib'); @@ -35,9 +35,6 @@ our @ISA = ('Math::BigInt::Lib'); ############################################################################## # global constants, flags and accessory -# announce that we are compatible with MBI v1.83 and up -sub api_version () { 2; } - # constants for easier life my ($BASE, $BASE_LEN, $RBASE, $MAX_VAL); my ($AND_BITS, $XOR_BITS, $OR_BITS); @@ -50,9 +47,7 @@ sub _base_len { my ($class, $b, $int) = @_; if (defined $b) { - # avoid redefinitions - undef &_mul; - undef &_div; + no warnings "redefine"; if ($] >= 5.008 && $int && $b > 7) { $BASE_LEN = $b; @@ -403,13 +398,14 @@ sub _mul_use_mul { 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 + # 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]) >= $BASE) { - $xv->[0] = $xv->[0] - ($xv->[1] = int($xv->[0] * $RBASE)) * $BASE; + my $rem = $xv->[0] % $BASE; + $xv->[1] = ($xv->[0] - $rem) * $RBASE; + $xv->[0] = $rem; } - ; return $xv; } # $x * 0 => 0 @@ -417,56 +413,44 @@ sub _mul_use_mul { @$xv = (0); return $xv; } + # multiply a large number a by a single element one, so speed up my $y = $yv->[0]; my $car = 0; + my $rem; foreach my $i (@$xv) { $i = $i * $y + $car; - $car = int($i * $RBASE); - $i -= $car * $BASE; + $rem = $i % $BASE; + $car = ($i - $rem) * $RBASE; + $i = $rem; } 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? + $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); - my ($prod, $car, $cty, $xi, $yi); - + my ($prod, $rem, $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)) * $BASE; # 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; + $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)) * $BASE; # see USE_MUL + $rem = $prod % $BASE; + $car = int(($prod - $rem) * $RBASE); + $prod[$cty++] = $rem; } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy + $prod[$cty] += $car if $car; # need really to check for 0? + $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; - # can't have leading zeros - # __strip_zeros($xv); $xv; } @@ -478,11 +462,11 @@ sub _mul_use_div_64 { my ($c, $xv, $yv) = @_; use integer; + if (@$yv == 1) { - # shortcut for two small numbers, also handles $x == 0 + # 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) { - # 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]) >= $BASE) { $xv->[0] = $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE; @@ -494,6 +478,7 @@ sub _mul_use_div_64 { @$xv = (0); return $xv; } + # multiply a large number a by a single element one, so speed up my $y = $yv->[0]; my $car = 0; @@ -505,11 +490,12 @@ sub _mul_use_div_64 { push @$xv, $car if $car != 0; return $xv; } + # shortcut for result $x == 0 => result = 0 - return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); + return $xv if @$xv == 1 && $xv->[0] == 0; # since multiplying $x with $x fails, make copy in this case - $yv = $c->_copy($xv) if $xv == $yv; # same references? + $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); my ($prod, $car, $cty, $xi, $yi); @@ -517,13 +503,13 @@ sub _mul_use_div_64 { $car = 0; $cty = 0; # looping through this if $xi == 0 is silly - so optimize it away! - $xi = (shift @prod || 0), next if $xi == 0; + $xi = (shift(@prod) || 0), next if $xi == 0; for $yi (@$yv) { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE; } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy + $prod[$cty] += $car if $car; # need really to check for 0? + $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; $xv; @@ -536,15 +522,14 @@ sub _mul_use_div { my ($c, $xv, $yv) = @_; if (@$yv == 1) { - # shortcut for two small numbers, also handles $x == 0 + # 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) { - # 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]) >= $BASE) { - $xv->[0] = - $xv->[0] - ($xv->[1] = int($xv->[0] / $BASE)) * $BASE; + my $rem = $xv->[0] % $BASE; + $xv->[1] = ($xv->[0] - $rem) / $BASE; + $xv->[0] = $rem; } - ; return $xv; } # $x * 0 => 0 @@ -552,42 +537,44 @@ sub _mul_use_div { @$xv = (0); return $xv; } + # multiply a large number a by a single element one, so speed up my $y = $yv->[0]; my $car = 0; + my $rem; foreach my $i (@$xv) { $i = $i * $y + $car; - $car = int($i / $BASE); - $i -= $car * $BASE; - # This (together with use integer;) does not work on 32-bit Perls - #$i = $i * $y + $car; $i -= ($car = $i / $BASE) * $BASE; + $rem = $i % $BASE; + $car = ($i - $rem) / $BASE; + $i = $rem; } push @$xv, $car if $car != 0; return $xv; } + # shortcut for result $x == 0 => result = 0 - return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); + return $xv if @$xv == 1 && $xv->[0] == 0; # since multiplying $x with $x fails, make copy in this case - $yv = $c->_copy($xv) if $xv == $yv; # same references? + $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); - my ($prod, $car, $cty, $xi, $yi); + my ($prod, $rem, $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; + $xi = (shift(@prod) || 0), next if $xi == 0; for $yi (@$yv) { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; - $prod[$cty++] = $prod - ($car = int($prod / $BASE)) * $BASE; + $rem = $prod % $BASE; + $car = ($prod - $rem) / $BASE; + $prod[$cty++] = $rem; } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy + $prod[$cty] += $car if $car; # need really to check for 0? + $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; - # can't have leading zeros - # __strip_zeros($xv); $xv; } @@ -595,28 +582,19 @@ 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 algorithm 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 $rem = [ $x->[0] % $yorg->[0] ]; - bless $rem, $c; - $x->[0] = int($x->[0] / $yorg->[0]); - return ($x, $rem); - } else { - $x->[0] = int($x->[0] / $yorg->[0]); - return $x; - } + my $rem = [ $x->[0] % $yorg->[0] ]; + bless $rem, $c; + $x->[0] = ($x->[0] - $rem->[0]) / $yorg->[0]; + return ($x, $rem) if wantarray; + return $x; } # if x has more than one, but y has only one element: @@ -631,120 +609,120 @@ sub _div_use_mul { my $b; while ($j-- > 0) { $b = $r * $BASE + $x->[$j]; - $x->[$j] = int($b/$y); $r = $b % $y; + $x->[$j] = ($b - $r) / $y; } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero + pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero return ($x, $rem) if wantarray; return $x; } # now x and y have more than one element - # check whether y has more elements than x, if yet, the result will be 0 + # check whether y has more elements than x, if so, the result is 0 if (@$yorg > @$x) { my $rem; - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now + $rem = $c->_copy($x) if wantarray; # make copy + @$x = 0; # set to 0 + return ($x, $rem) if wantarray; # including remainder? + return $x; # only x, which is [0] now } + # check whether the numbers have the same number of elements, in that case # the result will fit into one element and can be computed efficiently if (@$yorg == @$x) { + my $cmp = 0; + for (my $j = $#$x ; $j >= 0 ; --$j) { + last if $cmp = $x->[$j] - $yorg->[$j]; + } - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) { - my $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? + if ($cmp == 0) { # x = y + @$x = 1; + return $x, $c->_zero() if wantarray; return $x; } - # now calculate $x / $yorg - if (length(int($yorg->[-1])) == length(int($x->[-1]))) { - # same length, so make full compare - my $a = 0; - my $j = @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) { - last if ($a = $x->[$j] - $yorg->[$j]); - $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) { - # a = 0 => x == y => rem 0 - # a < 0 => x < y => rem = x - my $rem = $a == 0 ? $c->_zero() : $c->_copy($x); - @$x = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x, $rem) if wantarray; - return $x; + if ($cmp < 0) { # x < y + if (wantarray) { + my $rem = $c->_copy($x); + @$x = 0; + return $x, $rem; } - # $x >= $y, so proceed normally + @$x = 0; + return $x; } } # all other cases: - my $y = $c->_copy($yorg); # always make copy to preserve + my $y = $c->_copy($yorg); # always make copy to preserve - my ($car, $bar, $prd, $dd, $xi, $yi, @q, $v2, $v1, $tmp, $q, $u2, $u1, $u0); - - $car = $bar = $prd = 0; - if (($dd = int($BASE / ($y->[-1] + 1))) != 1) { - for $xi (@$x) { + my $tmp = $y->[-1] + 1; + my $rem = $BASE % $tmp; + my $dd = ($BASE - $rem) / $tmp; + if ($dd != 1) { + my $car = 0; + for my $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL + $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL } push(@$x, $car); $car = 0; - for $yi (@$y) { + for my $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL + $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL } } else { push(@$x, 0); } - @q = (); - ($v2, $v1) = @$y[-2, -1]; + + # @q will accumulate the final result, $q contains the current computed + # part of the final result + + my @q = (); + my ($v2, $v1) = @$y[-2, -1]; $v2 = 0 unless $v2; while ($#$x > $#$y) { - ($u2, $u1, $u0) = @$x[-3 .. -1]; + my ($u2, $u1, $u0) = @$x[-3 .. -1]; $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0 * $BASE + $u1) / $v1)); - --$q while ($v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2); + my $tmp = $u0 * $BASE + $u1; + my $rem = $tmp % $v1; + my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); + --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; if ($q) { - ($car, $bar) = (0, 0); - for ($yi = 0, $xi = $#$x - $#$y-1; $yi <= $#$y; ++$yi, ++$xi) { + my $prd; + my ($car, $bar) = (0, 0); + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL + $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; - for ($yi = 0, $xi = $#$x - $#$y-1; $yi <= $#$y; ++$yi, ++$xi) { + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE)); + if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); } } } pop(@$x); unshift(@q, $q); } + if (wantarray) { my $d = bless [], $c; if ($dd != 1) { - $car = 0; - for $xi (reverse @$x) { + my $car = 0; + my ($prd, $rem); + for my $xi (reverse @$x) { $prd = $car * $BASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL - unshift(@$d, $tmp); + $rem = $prd % $dd; + $tmp = ($prd - $rem) / $dd; + $car = $rem; + unshift @$d, $tmp; } } else { @$d = @$x; @@ -762,29 +740,29 @@ sub _div_use_mul { sub _div_use_div_64 { # ref to array, ref to array, modify first array and return remainder if # in list context - # This version works on 64 bit integers - my ($c, $x, $yorg) = @_; + # This version works on integers use integer; + + my ($c, $x, $yorg) = @_; + # the general div algorithm 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 $rem = [ $x->[0] % $yorg->[0] ]; bless $rem, $c; - $x->[0] = int($x->[0] / $yorg->[0]); + $x->[0] = $x->[0] / $yorg->[0]; return ($x, $rem); } else { - $x->[0] = int($x->[0] / $yorg->[0]); + $x->[0] = $x->[0] / $yorg->[0]; return $x; } } + # if x has more than one, but y has only one element: if (@$yorg == 1) { my $rem; @@ -797,78 +775,67 @@ sub _div_use_div_64 { my $b; while ($j-- > 0) { $b = $r * $BASE + $x->[$j]; - $x->[$j] = int($b/$y); $r = $b % $y; + $x->[$j] = $b / $y; } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero + pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero return ($x, $rem) if wantarray; return $x; } + # now x and y have more than one element - # check whether y has more elements than x, if yet, the result will be 0 + # check whether y has more elements than x, if so, the result is 0 if (@$yorg > @$x) { my $rem; - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now + $rem = $c->_copy($x) if wantarray; # make copy + @$x = 0; # set to 0 + return ($x, $rem) if wantarray; # including remainder? + return $x; # only x, which is [0] now } + # check whether the numbers have the same number of elements, in that case # the result will fit into one element and can be computed efficiently if (@$yorg == @$x) { - my $rem; - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) { - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; + my $cmp = 0; + for (my $j = $#$x ; $j >= 0 ; --$j) { + last if $cmp = $x->[$j] - $yorg->[$j]; } - # now calculate $x / $yorg - if (length(int($yorg->[-1])) == length(int($x->[-1]))) { - # same length, so make full compare + if ($cmp == 0) { # x = y + @$x = 1; + return $x, $c->_zero() if wantarray; + return $x; + } - my $a = 0; - my $j = @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) { - last if ($a = $x->[$j] - $yorg->[$j]); - $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) { - $rem = $c->_zero(); # a = 0 => x == y => rem 0 - $rem = $c->_copy($x) if $a != 0; # a < 0 => x < y => rem = x - @$x = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x, $rem) if wantarray; # including remainder? - return $x; + if ($cmp < 0) { # x < y + if (wantarray) { + my $rem = $c->_copy($x); + @$x = 0; + return $x, $rem; } - # $x >= $y, so proceed normally + @$x = 0; + return $x; } } # all other cases: - my $y = $c->_copy($yorg); # always make copy to preserve - - my ($car, $bar, $prd, $dd, $xi, $yi, @q, $v2, $v1, $tmp, $q, $u2, $u1, $u0); + my $y = $c->_copy($yorg); # always make copy to preserve - $car = $bar = $prd = 0; - if (($dd = int($BASE / ($y->[-1] + 1))) != 1) { - for $xi (@$x) { + my $tmp; + my $dd = $BASE / ($y->[-1] + 1); + if ($dd != 1) { + my $car = 0; + for my $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi / $BASE)) * $BASE; + $xi -= ($car = $xi / $BASE) * $BASE; } push(@$x, $car); $car = 0; - for $yi (@$y) { + for my $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi / $BASE)) * $BASE; + $yi -= ($car = $yi / $BASE) * $BASE; } } else { push(@$x, 0); @@ -877,43 +844,48 @@ sub _div_use_div_64 { # @q will accumulate the final result, $q contains the current computed # part of the final result - @q = (); - ($v2, $v1) = @$y[-2, -1]; + my @q = (); + my ($v2, $v1) = @$y[-2, -1]; $v2 = 0 unless $v2; while ($#$x > $#$y) { - ($u2, $u1, $u0) = @$x[-3..-1]; + my ($u2, $u1, $u0) = @$x[-3 .. -1]; $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0 * $BASE + $u1) / $v1)); - --$q while ($v2 * $q > ($u0 * $BASE +$ u1- $q*$v1) * $BASE + $u2); + my $tmp = $u0 * $BASE + $u1; + my $rem = $tmp % $v1; + my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); + --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; if ($q) { - ($car, $bar) = (0, 0); - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + my $prd; + my ($car, $bar) = (0, 0); + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $prd = $q * $y->[$yi] + $car; $prd -= ($car = int($prd / $BASE)) * $BASE; - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE)); + if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); } } } pop(@$x); unshift(@q, $q); } + if (wantarray) { my $d = bless [], $c; if ($dd != 1) { - $car = 0; - for $xi (reverse @$x) { + my $car = 0; + my $prd; + for my $xi (reverse @$x) { $prd = $car * $BASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; - unshift(@$d, $tmp); + $car = $prd - ($tmp = $prd / $dd) * $dd; + unshift @$d, $tmp; } } else { @$d = @$x; @@ -931,27 +903,22 @@ sub _div_use_div_64 { sub _div_use_div { # ref to array, ref to array, modify first array and return remainder if # in list context + my ($c, $x, $yorg) = @_; # the general div algorithm 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 $rem = [ $x->[0] % $yorg->[0] ]; - bless $rem, $c; - $x->[0] = int($x->[0] / $yorg->[0]); - return ($x, $rem); - } else { - $x->[0] = int($x->[0] / $yorg->[0]); - return $x; - } + my $rem = [ $x->[0] % $yorg->[0] ]; + bless $rem, $c; + $x->[0] = ($x->[0] - $rem->[0]) / $yorg->[0]; + return ($x, $rem) if wantarray; + return $x; } + # if x has more than one, but y has only one element: if (@$yorg == 1) { my $rem; @@ -964,80 +931,72 @@ sub _div_use_div { my $b; while ($j-- > 0) { $b = $r * $BASE + $x->[$j]; - $x->[$j] = int($b/$y); $r = $b % $y; + $x->[$j] = ($b - $r) / $y; } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero + pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero return ($x, $rem) if wantarray; return $x; } + # now x and y have more than one element - # check whether y has more elements than x, if yet, the result will be 0 + # check whether y has more elements than x, if so, the result is 0 if (@$yorg > @$x) { my $rem; - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now + $rem = $c->_copy($x) if wantarray; # make copy + @$x = 0; # set to 0 + return ($x, $rem) if wantarray; # including remainder? + return $x; # only x, which is [0] now } + # check whether the numbers have the same number of elements, in that case # the result will fit into one element and can be computed efficiently if (@$yorg == @$x) { - my $rem; - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) { - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; + my $cmp = 0; + for (my $j = $#$x ; $j >= 0 ; --$j) { + last if $cmp = $x->[$j] - $yorg->[$j]; } - # now calculate $x / $yorg - if (length(int($yorg->[-1])) == length(int($x->[-1]))) { - # same length, so make full compare + if ($cmp == 0) { # x = y + @$x = 1; + return $x, $c->_zero() if wantarray; + return $x; + } - my $a = 0; - my $j = @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) { - last if ($a = $x->[$j] - $yorg->[$j]); - $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) { - $rem = $c->_zero(); # a = 0 => x == y => rem 0 - $rem = $c->_copy($x) if $a != 0; # a < 0 => x < y => rem = x + if ($cmp < 0) { # x < y + if (wantarray) { + my $rem = $c->_copy($x); @$x = 0; - $x->[0] = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x, $rem) if wantarray; # including remainder? - return $x; + return $x, $rem; } - # $x >= $y, so proceed normally - + @$x = 0; + return $x; } } # all other cases: - my $y = $c->_copy($yorg); # always make copy to preserve - - my ($car, $bar, $prd, $dd, $xi, $yi, @q, $v2, $v1, @d, $tmp, $q, $u2, $u1, $u0); + my $y = $c->_copy($yorg); # always make copy to preserve - $car = $bar = $prd = 0; - if (($dd = int($BASE / ($y->[-1] + 1))) != 1) { - for $xi (@$x) { + my $tmp = $y->[-1] + 1; + my $rem = $BASE % $tmp; + my $dd = ($BASE - $rem) / $tmp; + if ($dd != 1) { + my $car = 0; + for my $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi / $BASE)) * $BASE; + $rem = $xi % $BASE; + $car = ($xi - $rem) / $BASE; + $xi = $rem; } push(@$x, $car); $car = 0; - for $yi (@$y) { + for my $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi / $BASE)) * $BASE; + $rem = $yi % $BASE; + $car = ($yi - $rem) / $BASE; + $yi = $rem; } } else { push(@$x, 0); @@ -1046,43 +1005,52 @@ sub _div_use_div { # @q will accumulate the final result, $q contains the current computed # part of the final result - @q = (); - ($v2, $v1) = @$y[-2, -1]; + my @q = (); + my ($v2, $v1) = @$y[-2, -1]; $v2 = 0 unless $v2; while ($#$x > $#$y) { - ($u2, $u1, $u0) = @$x[-3..-1]; + my ($u2, $u1, $u0) = @$x[-3 .. -1]; $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0 * $BASE + $u1) / $v1)); - --$q while ($v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2); + my $tmp = $u0 * $BASE + $u1; + my $rem = $tmp % $v1; + my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); + --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; if ($q) { - ($car, $bar) = (0, 0); - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + my $prd; + my ($car, $bar) = (0, 0); + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd / $BASE)) * $BASE; - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $rem = $prd % $BASE; + $car = ($prd - $rem) / $BASE; + $prd -= $car * $BASE; + $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE)); + if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); } } } pop(@$x); unshift(@q, $q); } + if (wantarray) { my $d = bless [], $c; if ($dd != 1) { - $car = 0; - for $xi (reverse @$x) { + my $car = 0; + my ($prd, $rem); + for my $xi (reverse @$x) { $prd = $car * $BASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; - unshift(@$d, $tmp); + $rem = $prd % $dd; + $tmp = ($prd - $rem) / $dd; + $car = $rem; + unshift @$d, $tmp; } } else { @$d = @$x; @@ -1385,7 +1353,7 @@ sub _rsft { $dst++; } splice(@$x, $dst) if $dst > 0; # kill left-over array elems - pop @$x if $x->[-1] == 0 && @$x > 1; # kill last element if 0 + pop(@$x) if $x->[-1] == 0 && @$x > 1; # kill last element if 0 } # else rem == 0 $x; } @@ -1393,49 +1361,64 @@ sub _rsft { sub _lsft { my ($c, $x, $n, $b) = @_; - return $x if $c->_is_zero($x); - - # Handle the special case when the base is a power of 10. Don't check - # whether log($b)/log(10) is an integer, because log(1000)/log(10) is not - # exactly 3. - - my $log10 = sprintf "%.0f", log($b) / log(10); - if ($b == 10 ** $log10) { - $b = 10; - $n = $c->_mul($n, $c->_new($log10)); - - # shortcut (faster) for shifting by 10) since we are in base 10eX - # multiples of $BASE_LEN: - my $src = @$x; # source - my $len = $c->_num($n); # shift-len as normal int - my $rem = $len % $BASE_LEN; # remainder to shift - my $dst = $src + int($len / $BASE_LEN); # destination - my $vd; # further speedup - $x->[$src] = 0; # avoid first ||0 for speed - my $z = '0' x $BASE_LEN; - while ($src >= 0) { - $vd = $x->[$src]; - $vd = $z . $vd; - $vd = substr($vd, -$BASE_LEN + $rem, $BASE_LEN - $rem); - $vd .= $src > 0 ? substr($z . $x->[$src - 1], -$BASE_LEN, $rem) - : '0' x $rem; - $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN; - $x->[$dst] = int($vd); - $dst--; - $src--; + return $x if $c->_is_zero($x) || $c->_is_zero($n); + + # For backwards compatibility, allow the base $b to be a scalar. + + $b = $c->_new($b) unless ref $b; + + # If the base is a power of 10, use shifting, since the internal + # representation is in base 10eX. + + my $bstr = $c->_str($b); + if ($bstr =~ /^1(0+)\z/) { + + # Adjust $n so that we're shifting in base 10. Do this by multiplying + # $n by the base 10 logarithm of $b: $b ** $n = 10 ** (log10($b) * $n). + + my $log10b = length($1); + $n = $c->_mul($c->_new($log10b), $n); + $n = $c->_num($n); # shift-len as normal int + + # $q is the number of places to shift the elements within the array, + # and $r is the number of places to shift the values within the + # elements. + + my $r = $n % $BASE_LEN; + my $q = ($n - $r) / $BASE_LEN; + + # If we must shift the values within the elements ... + + if ($r) { + my $i = @$x; # index + $x->[$i] = 0; # initialize most significant element + my $z = '0' x $BASE_LEN; + my $vd; + while ($i >= 0) { + $vd = $x->[$i]; + $vd = $z . $vd; + $vd = substr($vd, $r - $BASE_LEN, $BASE_LEN - $r); + $vd .= $i > 0 ? substr($z . $x->[$i - 1], -$BASE_LEN, $r) + : '0' x $r; + $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN; + $x->[$i] = int($vd); # e.g., "0...048" -> 48 etc. + $i--; + } + + pop(@$x) if $x->[-1] == 0; # if most significant element is zero } - # set lowest parts to 0 - while ($dst >= 0) { - $x->[$dst--] = 0; + + # If we must shift the elements within the array ... + + if ($q) { + unshift @$x, (0) x $q; } - # fix spurious last zero element - splice @$x, -1 if $x->[-1] == 0; - return $x; + } else { - $b = $c->_new($b); - #print $c->_str($b); - return $c->_mul($x, $c->_pow($b, $n)); + $x = $c->_mul($x, $c->_pow($b, $n)); } + + return $x; } sub _pow { diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm index 3e772e92a3..4e903bd4f1 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm @@ -8,7 +8,7 @@ use Math::BigInt::Calc 1.999801; our @ISA = qw< Math::BigInt::Calc >; -our $VERSION = '0.5008'; +our $VERSION = '0.5009'; ############################################################################## # global constants, flags and accessory diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Lib.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Lib.pm index 883f31f4c9..fde281297f 100755 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Lib.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Math/BigInt/Lib.pm @@ -4,7 +4,7 @@ use 5.006001; use strict; use warnings; -our $VERSION = '1.999816'; +our $VERSION = '1.999818'; use Carp; @@ -251,13 +251,6 @@ use overload ; -# Do we need api_version() at all, now that we have a virtual parent class that -# will provide any missing methods? Fixme! - -sub api_version () { - croak "@{[(caller 0)[3]]} method not implemented"; -} - sub _new { croak "@{[(caller 0)[3]]} method not implemented"; } @@ -386,6 +379,20 @@ sub _digit { substr($class ->_str($x), -($n+1), 1); } +sub _digitsum { + my ($class, $x) = @_; + + my $len = $class -> _len($x); + my $sum = $class -> _zero(); + for (my $i = 0 ; $i < $len ; ++$i) { + my $digit = $class -> _digit($x, $i); + $digit = $class -> _new($digit); + $sum = $class -> _add($sum, $digit); + } + + return $sum; +} + sub _zeros { my ($class, $x) = @_; my $str = $class -> _str($x); @@ -1428,16 +1435,20 @@ sub _to_base { if (@_) { $collseq = shift(); } else { - if ($class -> _acmp($base, $class -> _new("62")) <= 0) { - $collseq = '0123456789' . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - . 'abcdefghijklmnopqrstuvwxyz'; + if ($class -> _acmp($base, $class -> _new("94")) <= 0) { + $collseq = '0123456789' # 48 .. 57 + . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' # 65 .. 90 + . 'abcdefghijklmnopqrstuvwxyz' # 97 .. 122 + . '!"#$%&\'()*+,-./' # 33 .. 47 + . ':;<=>?@' # 58 .. 64 + . '[\\]^_`' # 91 .. 96 + . '{|}~'; # 123 .. 126 } else { - croak "When base > 62, a collation sequence must be given"; + croak "When base > 94, a collation sequence must be given"; } } my @collseq = split '', $collseq; - my %collseq = map { $_ => $collseq[$_] } 0 .. $#collseq; my $str = ''; my $tmp = $class -> _copy($x); @@ -1573,11 +1584,16 @@ sub _from_base { if ($class -> _acmp($base, $class -> _new("36")) <= 0) { $str = uc $str; $collseq = '0123456789' . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; - } elsif ($class -> _acmp($base, $class -> _new("62")) <= 0) { - $collseq = '0123456789' . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - . 'abcdefghijklmnopqrstuvwxyz'; + } elsif ($class -> _acmp($base, $class -> _new("94")) <= 0) { + $collseq = '0123456789' # 48 .. 57 + . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' # 65 .. 90 + . 'abcdefghijklmnopqrstuvwxyz' # 97 .. 122 + . '!"#$%&\'()*+,-./' # 33 .. 47 + . ':;<=>?@' # 58 .. 64 + . '[\\]^_`' # 91 .. 96 + . '{|}~'; # 123 .. 126 } else { - croak "When base > 62, a collation sequence must be given"; + croak "When base > 94, a collation sequence must be given"; } $collseq = substr $collseq, 0, $class -> _num($base); } @@ -1920,11 +1936,8 @@ comparison routines. =item CLASS-E<gt>api_version() -Return API version as a Perl scalar, 1 for Math::BigInt v1.70, 2 for -Math::BigInt v1.83. - -This method is no longer used. Methods that are not implemented by a subclass -will be inherited from this class. +This method is no longer used and can be omitted. Methods that are not +implemented by a subclass will be inherited from this class. =back @@ -1986,10 +1999,20 @@ COLLSEQ. Each character in STR represents a numerical value identical to the character's position in COLLSEQ. All characters in STR must be present in COLLSEQ. -If BASE is less than or equal to 62, and a collation sequence is not specified, -a default collation sequence consisting of the 62 characters 0..9, A..Z, and -a..z is used. If the default collation sequence is used, and the BASE is less -than or equal to 36, the letter case in STR is ignored. +If BASE is less than or equal to 94, and a collation sequence is not specified, +the following default collation sequence is used. It contains of all the 94 +printable ASCII characters except space/blank: + + 0123456789 # ASCII 48 to 57 + ABCDEFGHIJKLMNOPQRSTUVWXYZ # ASCII 65 to 90 + abcdefghijklmnopqrstuvwxyz # ASCII 97 to 122 + !"#$%&'()*+,-./ # ASCII 33 to 47 + :;<=>?@ # ASCII 58 to 64 + [\]^_` # ASCII 91 to 96 + {|}~ # ASCII 123 to 126 + +If the default collation sequence is used, and the BASE is less than or equal +to 36, the letter case in STR is ignored. For instance, with base 3 and collation sequence "-/|", the character "-" represents 0, "/" represents 1, and "|" represents 2. So if STR is "/|-", the @@ -2005,10 +2028,12 @@ conversion. All examples return 250. Some more examples, all returning 250: - $x = $class -> _from_base("100021", 3, "012") - $x = $class -> _from_base("3322", 4, "0123") - $x = $class -> _from_base("2000", 5, "01234") + $x = $class -> _from_base("100021", 3) + $x = $class -> _from_base("3322", 4) + $x = $class -> _from_base("2000", 5) $x = $class -> _from_base("caaa", 5, "abcde") + $x = $class -> _from_base("42", 62) + $x = $class -> _from_base("2!", 94) =back @@ -2301,6 +2326,10 @@ from the left (most significant digit). If $obj represents the number 123, then CLASS->_digit($obj, 2) # returns 1 CLASS->_digit($obj, -1) # returns 1 +=item CLASS-E<gt>_digitsum(OBJ) + +Returns the sum of the base 10 digits. + =item CLASS-E<gt>_check(OBJ) Returns true if the object is invalid and false otherwise. Preferably, the true @@ -2394,11 +2423,11 @@ L<http://annocpan.org/dist/Math-BigInt> =item * CPAN Ratings -L<http://cpanratings.perl.org/dist/Math-BigInt> +L<https://cpanratings.perl.org/dist/Math-BigInt> -=item * Search CPAN +=item * MetaCPAN -L<http://search.cpan.org/dist/Math-BigInt/> +L<https://metacpan.org/release/Math-BigInt> =item * CPAN Testers Matrix |