diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Math/BigInt.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Math/BigInt.pm | 399 |
1 files changed, 292 insertions, 107 deletions
diff --git a/Master/tlpkg/tlperl/lib/Math/BigInt.pm b/Master/tlpkg/tlperl/lib/Math/BigInt.pm index a443cd4a5d4..185f8028350 100644 --- a/Master/tlpkg/tlperl/lib/Math/BigInt.pm +++ b/Master/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 |